1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2013, 2014 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30 #include "libguile/_scm.h"
31 #include "libguile/__scm.h"
32 #include "libguile/array-handle.h"
33 #include "libguile/generalized-arrays.h"
36 SCM_INTERNAL SCM
scm_i_array_ref (SCM v
,
37 SCM idx0
, SCM idx1
, SCM idxN
);
38 SCM_INTERNAL SCM
scm_i_array_set_x (SCM v
, SCM obj
,
39 SCM idx0
, SCM idx1
, SCM idxN
);
43 scm_is_array (SCM obj
)
45 if (!SCM_HEAP_OBJECT_P (obj
))
48 switch (SCM_TYP7 (obj
))
52 case scm_tc7_bitvector
:
53 case scm_tc7_bytevector
:
61 SCM_DEFINE (scm_array_p_2
, "array?", 1, 0, 0,
63 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
65 #define FUNC_NAME s_scm_array_p_2
67 return scm_from_bool (scm_is_array (obj
));
71 /* The array type predicate, with an extra argument kept for backward
72 compatibility. Note that we can't use `SCM_DEFINE' directly because there
73 would be an argument count mismatch that would be caught by
74 `snarf-check-and-output-texi.scm'. */
76 scm_array_p (SCM obj
, SCM unused
)
78 return scm_array_p_2 (obj
);
82 scm_is_typed_array (SCM obj
, SCM type
)
85 if (scm_is_array (obj
))
89 scm_array_get_handle (obj
, &h
);
90 ret
= scm_is_eq (scm_array_handle_element_type (&h
), type
);
91 scm_array_handle_release (&h
);
97 SCM_DEFINE (scm_typed_array_p
, "typed-array?", 2, 0, 0,
99 "Return @code{#t} if the @var{obj} is an array of type\n"
100 "@var{type}, and @code{#f} if not.")
101 #define FUNC_NAME s_scm_typed_array_p
103 return scm_from_bool (scm_is_typed_array (obj
, type
));
108 scm_c_array_rank (SCM array
)
110 scm_t_array_handle handle
;
113 scm_array_get_handle (array
, &handle
);
114 res
= scm_array_handle_rank (&handle
);
115 scm_array_handle_release (&handle
);
119 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
121 "Return the number of dimensions of the array @var{array.}\n")
122 #define FUNC_NAME s_scm_array_rank
124 return scm_from_size_t (scm_c_array_rank (array
));
130 scm_c_array_length (SCM array
)
132 scm_t_array_handle handle
;
135 scm_array_get_handle (array
, &handle
);
136 if (scm_array_handle_rank (&handle
) < 1)
138 scm_array_handle_release (&handle
);
139 scm_wrong_type_arg_msg (NULL
, 0, array
, "array of nonzero rank");
141 res
= handle
.dims
[0].ubnd
- handle
.dims
[0].lbnd
+ 1;
142 scm_array_handle_release (&handle
);
147 SCM_DEFINE (scm_array_length
, "array-length", 1, 0, 0,
149 "Return the length of an array: its first dimension.\n"
150 "It is an error to ask for the length of an array of rank 0.")
151 #define FUNC_NAME s_scm_array_length
153 return scm_from_size_t (scm_c_array_length (array
));
158 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
160 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
161 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
163 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
165 #define FUNC_NAME s_scm_array_dimensions
167 scm_t_array_handle handle
;
172 scm_array_get_handle (ra
, &handle
);
173 s
= scm_array_handle_dims (&handle
);
174 k
= scm_array_handle_rank (&handle
);
177 res
= scm_cons (s
[k
].lbnd
178 ? scm_cons2 (scm_from_ssize_t (s
[k
].lbnd
),
179 scm_from_ssize_t (s
[k
].ubnd
),
181 : scm_from_ssize_t (1 + s
[k
].ubnd
),
184 scm_array_handle_release (&handle
);
189 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
192 #define FUNC_NAME s_scm_array_type
194 scm_t_array_handle h
;
197 scm_array_get_handle (ra
, &h
);
198 type
= scm_array_handle_element_type (&h
);
199 scm_array_handle_release (&h
);
205 SCM_DEFINE (scm_array_type_code
,
206 "array-type-code", 1, 0, 0,
208 "Return the type of the elements in @var{array},\n"
209 "as an integer code.")
210 #define FUNC_NAME s_scm_array_type_code
212 scm_t_array_handle h
;
213 scm_t_array_element_type element_type
;
215 scm_array_get_handle (array
, &h
);
216 element_type
= h
.element_type
;
217 scm_array_handle_release (&h
);
219 return scm_from_uint16 (element_type
);
223 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
225 "Return @code{#t} if its arguments would be acceptable to\n"
227 #define FUNC_NAME s_scm_array_in_bounds_p
229 SCM res
= SCM_BOOL_T
;
232 scm_t_array_handle handle
;
234 SCM_VALIDATE_REST_ARGUMENT (args
);
236 scm_array_get_handle (ra
, &handle
);
237 s
= scm_array_handle_dims (&handle
);
238 ndim
= scm_array_handle_rank (&handle
);
240 for (k
= 0; k
< ndim
; k
++)
244 if (!scm_is_pair (args
))
245 SCM_WRONG_NUM_ARGS ();
246 ind
= scm_to_long (SCM_CAR (args
));
247 args
= SCM_CDR (args
);
249 if (ind
< s
[k
].lbnd
|| ind
> s
[k
].ubnd
)
252 /* We do not stop the checking after finding a violation
253 since we want to validate the type-correctness and
254 number of arguments in any case.
259 scm_array_handle_release (&handle
);
266 scm_c_array_ref_1 (SCM array
, ssize_t idx0
)
268 scm_t_array_handle handle
;
271 scm_array_get_handle (array
, &handle
);
272 res
= scm_array_handle_ref (&handle
, scm_array_handle_pos_1 (&handle
, idx0
));
273 scm_array_handle_release (&handle
);
279 scm_c_array_ref_2 (SCM array
, ssize_t idx0
, ssize_t idx1
)
281 scm_t_array_handle handle
;
284 scm_array_get_handle (array
, &handle
);
285 res
= scm_array_handle_ref (&handle
, scm_array_handle_pos_2 (&handle
, idx0
, idx1
));
286 scm_array_handle_release (&handle
);
292 scm_array_ref (SCM v
, SCM args
)
294 scm_t_array_handle handle
;
297 scm_array_get_handle (v
, &handle
);
298 res
= scm_array_handle_ref (&handle
, scm_array_handle_pos (&handle
, args
));
299 scm_array_handle_release (&handle
);
305 scm_c_array_set_1_x (SCM array
, SCM obj
, ssize_t idx0
)
307 scm_t_array_handle handle
;
309 scm_array_get_handle (array
, &handle
);
310 scm_array_handle_set (&handle
, scm_array_handle_pos_1 (&handle
, idx0
),
312 scm_array_handle_release (&handle
);
317 scm_c_array_set_2_x (SCM array
, SCM obj
, ssize_t idx0
, ssize_t idx1
)
319 scm_t_array_handle handle
;
321 scm_array_get_handle (array
, &handle
);
322 scm_array_handle_set (&handle
, scm_array_handle_pos_2 (&handle
, idx0
, idx1
),
324 scm_array_handle_release (&handle
);
329 scm_array_set_x (SCM v
, SCM obj
, SCM args
)
331 scm_t_array_handle handle
;
333 scm_array_get_handle (v
, &handle
);
334 scm_array_handle_set (&handle
, scm_array_handle_pos (&handle
, args
), obj
);
335 scm_array_handle_release (&handle
);
336 return SCM_UNSPECIFIED
;
340 SCM_DEFINE (scm_i_array_ref
, "array-ref", 1, 2, 1,
341 (SCM v
, SCM idx0
, SCM idx1
, SCM idxN
),
342 "Return the element at the @code{(idx0, idx1, idxN...)}\n"
343 "position in array @var{v}.")
344 #define FUNC_NAME s_scm_i_array_ref
346 if (SCM_UNBNDP (idx0
))
347 return scm_array_ref (v
, SCM_EOL
);
348 else if (SCM_UNBNDP (idx1
))
349 return scm_c_array_ref_1 (v
, scm_to_ssize_t (idx0
));
350 else if (scm_is_null (idxN
))
351 return scm_c_array_ref_2 (v
, scm_to_ssize_t (idx0
), scm_to_ssize_t (idx1
));
353 return scm_array_ref (v
, scm_cons (idx0
, scm_cons (idx1
, idxN
)));
358 SCM_DEFINE (scm_i_array_set_x
, "array-set!", 2, 2, 1,
359 (SCM v
, SCM obj
, SCM idx0
, SCM idx1
, SCM idxN
),
360 "Set the element at the @code{(idx0, idx1, idxN...)} position\n"
361 "in the array @var{v} to @var{obj}. The value returned by\n"
362 "@code{array-set!} is unspecified.")
363 #define FUNC_NAME s_scm_i_array_set_x
365 if (SCM_UNBNDP (idx0
))
366 scm_array_set_x (v
, obj
, SCM_EOL
);
367 else if (SCM_UNBNDP (idx1
))
368 scm_c_array_set_1_x (v
, obj
, scm_to_ssize_t (idx0
));
369 else if (scm_is_null (idxN
))
370 scm_c_array_set_2_x (v
, obj
, scm_to_ssize_t (idx0
), scm_to_ssize_t (idx1
));
372 scm_array_set_x (v
, obj
, scm_cons (idx0
, scm_cons (idx1
, idxN
)));
374 return SCM_UNSPECIFIED
;
380 array_to_list (scm_t_array_handle
*h
, size_t dim
, unsigned long pos
)
382 if (dim
== scm_array_handle_rank (h
))
383 return scm_array_handle_ref (h
, pos
);
390 i
= h
->dims
[dim
].ubnd
- h
->dims
[dim
].lbnd
+ 1;
391 inc
= h
->dims
[dim
].inc
;
392 pos
+= (i
- 1) * inc
;
394 for (; i
> 0; i
--, pos
-= inc
)
395 res
= scm_cons (array_to_list (h
, dim
+ 1, pos
), res
);
400 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
402 "Return a list representation of @var{array}.\n\n"
403 "It is easiest to specify the behavior of this function by\n"
406 "(array->list #0(a)) @result{} 1\n"
407 "(array->list #1(a b)) @result{} (a b)\n"
408 "(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n"
410 #define FUNC_NAME s_scm_array_to_list
412 scm_t_array_handle h
;
415 scm_array_get_handle (array
, &h
);
416 res
= array_to_list (&h
, 0, 0);
417 scm_array_handle_release (&h
);
424 scm_init_generalized_arrays ()
426 #include "libguile/generalized-arrays.x"