1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2013 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 return scm_i_array_implementation_for_obj (obj
) ? 1 : 0;
48 SCM_DEFINE (scm_array_p_2
, "array?", 1, 0, 0,
50 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
52 #define FUNC_NAME s_scm_array_p_2
54 return scm_from_bool (scm_is_array (obj
));
58 /* The array type predicate, with an extra argument kept for backward
59 compatibility. Note that we can't use `SCM_DEFINE' directly because there
60 would be an argument count mismatch that would be caught by
61 `snarf-check-and-output-texi.scm'. */
63 scm_array_p (SCM obj
, SCM unused
)
65 return scm_array_p_2 (obj
);
69 scm_is_typed_array (SCM obj
, SCM type
)
72 if (scm_i_array_implementation_for_obj (obj
))
76 scm_array_get_handle (obj
, &h
);
77 ret
= scm_is_eq (scm_array_handle_element_type (&h
), type
);
78 scm_array_handle_release (&h
);
84 SCM_DEFINE (scm_typed_array_p
, "typed-array?", 2, 0, 0,
86 "Return @code{#t} if the @var{obj} is an array of type\n"
87 "@var{type}, and @code{#f} if not.")
88 #define FUNC_NAME s_scm_typed_array_p
90 return scm_from_bool (scm_is_typed_array (obj
, type
));
95 scm_c_array_rank (SCM array
)
97 scm_t_array_handle handle
;
100 scm_array_get_handle (array
, &handle
);
101 res
= scm_array_handle_rank (&handle
);
102 scm_array_handle_release (&handle
);
106 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
108 "Return the number of dimensions of the array @var{array.}\n")
109 #define FUNC_NAME s_scm_array_rank
111 return scm_from_size_t (scm_c_array_rank (array
));
117 scm_c_array_length (SCM array
)
119 scm_t_array_handle handle
;
122 scm_array_get_handle (array
, &handle
);
123 if (scm_array_handle_rank (&handle
) < 1)
125 scm_array_handle_release (&handle
);
126 scm_wrong_type_arg_msg (NULL
, 0, array
, "array of nonzero rank");
128 res
= handle
.dims
[0].ubnd
- handle
.dims
[0].lbnd
+ 1;
129 scm_array_handle_release (&handle
);
134 SCM_DEFINE (scm_array_length
, "array-length", 1, 0, 0,
136 "Return the length of an array: its first dimension.\n"
137 "It is an error to ask for the length of an array of rank 0.")
138 #define FUNC_NAME s_scm_array_rank
140 return scm_from_size_t (scm_c_array_length (array
));
145 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
147 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
148 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
150 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
152 #define FUNC_NAME s_scm_array_dimensions
154 scm_t_array_handle handle
;
159 scm_array_get_handle (ra
, &handle
);
160 s
= scm_array_handle_dims (&handle
);
161 k
= scm_array_handle_rank (&handle
);
164 res
= scm_cons (s
[k
].lbnd
165 ? scm_cons2 (scm_from_ssize_t (s
[k
].lbnd
),
166 scm_from_ssize_t (s
[k
].ubnd
),
168 : scm_from_ssize_t (1 + s
[k
].ubnd
),
171 scm_array_handle_release (&handle
);
176 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
179 #define FUNC_NAME s_scm_array_type
181 scm_t_array_handle h
;
184 scm_array_get_handle (ra
, &h
);
185 type
= scm_array_handle_element_type (&h
);
186 scm_array_handle_release (&h
);
192 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
194 "Return @code{#t} if its arguments would be acceptable to\n"
196 #define FUNC_NAME s_scm_array_in_bounds_p
198 SCM res
= SCM_BOOL_T
;
201 scm_t_array_handle handle
;
203 SCM_VALIDATE_REST_ARGUMENT (args
);
205 scm_array_get_handle (ra
, &handle
);
206 s
= scm_array_handle_dims (&handle
);
207 ndim
= scm_array_handle_rank (&handle
);
209 for (k
= 0; k
< ndim
; k
++)
213 if (!scm_is_pair (args
))
214 SCM_WRONG_NUM_ARGS ();
215 ind
= scm_to_long (SCM_CAR (args
));
216 args
= SCM_CDR (args
);
218 if (ind
< s
[k
].lbnd
|| ind
> s
[k
].ubnd
)
221 /* We do not stop the checking after finding a violation
222 since we want to validate the type-correctness and
223 number of arguments in any case.
228 scm_array_handle_release (&handle
);
235 scm_c_array_ref_1 (SCM array
, ssize_t idx0
)
237 scm_t_array_handle handle
;
240 scm_array_get_handle (array
, &handle
);
241 res
= scm_array_handle_ref (&handle
, scm_array_handle_pos_1 (&handle
, idx0
));
242 scm_array_handle_release (&handle
);
248 scm_c_array_ref_2 (SCM array
, ssize_t idx0
, ssize_t idx1
)
250 scm_t_array_handle handle
;
253 scm_array_get_handle (array
, &handle
);
254 res
= scm_array_handle_ref (&handle
, scm_array_handle_pos_2 (&handle
, idx0
, idx1
));
255 scm_array_handle_release (&handle
);
261 scm_array_ref (SCM v
, SCM args
)
263 scm_t_array_handle handle
;
266 scm_array_get_handle (v
, &handle
);
267 res
= scm_array_handle_ref (&handle
, scm_array_handle_pos (&handle
, args
));
268 scm_array_handle_release (&handle
);
274 scm_c_array_set_1_x (SCM array
, SCM obj
, ssize_t idx0
)
276 scm_t_array_handle handle
;
278 scm_array_get_handle (array
, &handle
);
279 scm_array_handle_set (&handle
, scm_array_handle_pos_1 (&handle
, idx0
),
281 scm_array_handle_release (&handle
);
286 scm_c_array_set_2_x (SCM array
, SCM obj
, ssize_t idx0
, ssize_t idx1
)
288 scm_t_array_handle handle
;
290 scm_array_get_handle (array
, &handle
);
291 scm_array_handle_set (&handle
, scm_array_handle_pos_2 (&handle
, idx0
, idx1
),
293 scm_array_handle_release (&handle
);
298 scm_array_set_x (SCM v
, SCM obj
, SCM args
)
300 scm_t_array_handle handle
;
302 scm_array_get_handle (v
, &handle
);
303 scm_array_handle_set (&handle
, scm_array_handle_pos (&handle
, args
), obj
);
304 scm_array_handle_release (&handle
);
305 return SCM_UNSPECIFIED
;
309 SCM_DEFINE (scm_i_array_ref
, "array-ref", 1, 2, 1,
310 (SCM v
, SCM idx0
, SCM idx1
, SCM idxN
),
311 "Return the element at the @code{(idx0, idx1, idxN...)}\n"
312 "position in array @var{v}.")
313 #define FUNC_NAME s_scm_i_array_ref
315 if (SCM_UNBNDP (idx0
))
316 return scm_array_ref (v
, SCM_EOL
);
317 else if (SCM_UNBNDP (idx1
))
318 return scm_c_array_ref_1 (v
, scm_to_ssize_t (idx0
));
319 else if (scm_is_null (idxN
))
320 return scm_c_array_ref_2 (v
, scm_to_ssize_t (idx0
), scm_to_ssize_t (idx1
));
322 return scm_array_ref (v
, scm_cons (idx0
, scm_cons (idx1
, idxN
)));
327 SCM_DEFINE (scm_i_array_set_x
, "array-set!", 2, 2, 1,
328 (SCM v
, SCM obj
, SCM idx0
, SCM idx1
, SCM idxN
),
329 "Set the element at the @code{(idx0, idx1, idxN...)} position\n"
330 "in the array @var{v} to @var{obj}. The value returned by\n"
331 "@code{array-set!} is unspecified.")
332 #define FUNC_NAME s_scm_i_array_set_x
334 if (SCM_UNBNDP (idx0
))
335 scm_array_set_x (v
, obj
, SCM_EOL
);
336 else if (SCM_UNBNDP (idx1
))
337 scm_c_array_set_1_x (v
, obj
, scm_to_ssize_t (idx0
));
338 else if (scm_is_null (idxN
))
339 scm_c_array_set_2_x (v
, obj
, scm_to_ssize_t (idx0
), scm_to_ssize_t (idx1
));
341 scm_array_set_x (v
, obj
, scm_cons (idx0
, scm_cons (idx1
, idxN
)));
343 return SCM_UNSPECIFIED
;
349 array_to_list (scm_t_array_handle
*h
, size_t dim
, unsigned long pos
)
351 if (dim
== scm_array_handle_rank (h
))
352 return scm_array_handle_ref (h
, pos
);
359 i
= h
->dims
[dim
].ubnd
- h
->dims
[dim
].lbnd
+ 1;
360 inc
= h
->dims
[dim
].inc
;
361 pos
+= (i
- 1) * inc
;
363 for (; i
> 0; i
--, pos
-= inc
)
364 res
= scm_cons (array_to_list (h
, dim
+ 1, pos
), res
);
369 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
371 "Return a list representation of @var{array}.\n\n"
372 "It is easiest to specify the behavior of this function by\n"
375 "(array->list #0(a)) @result{} 1\n"
376 "(array->list #1(a b)) @result{} (a b)\n"
377 "(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n"
379 #define FUNC_NAME s_scm_array_to_list
381 scm_t_array_handle h
;
384 scm_array_get_handle (array
, &h
);
385 res
= array_to_list (&h
, 0, 0);
386 scm_array_handle_release (&h
);
393 scm_init_generalized_arrays ()
395 #include "libguile/generalized-arrays.x"