1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 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"
37 scm_is_array (SCM obj
)
39 return scm_i_array_implementation_for_obj (obj
) ? 1 : 0;
42 SCM_DEFINE (scm_array_p
, "array?", 1, 0, 0,
44 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
46 #define FUNC_NAME s_scm_array_p
48 return scm_from_bool (scm_is_array (obj
));
53 scm_is_typed_array (SCM obj
, SCM type
)
56 if (scm_i_array_implementation_for_obj (obj
))
60 scm_array_get_handle (obj
, &h
);
61 ret
= scm_is_eq (scm_array_handle_element_type (&h
), type
);
62 scm_array_handle_release (&h
);
68 SCM_DEFINE (scm_typed_array_p
, "typed-array?", 2, 0, 0,
70 "Return @code{#t} if the @var{obj} is an array of type\n"
71 "@var{type}, and @code{#f} if not.")
72 #define FUNC_NAME s_scm_typed_array_p
74 return scm_from_bool (scm_is_typed_array (obj
, type
));
79 scm_c_array_rank (SCM array
)
81 scm_t_array_handle handle
;
84 scm_array_get_handle (array
, &handle
);
85 res
= scm_array_handle_rank (&handle
);
86 scm_array_handle_release (&handle
);
90 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
92 "Return the number of dimensions of the array @var{array.}\n")
93 #define FUNC_NAME s_scm_array_rank
95 return scm_from_size_t (scm_c_array_rank (array
));
100 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
102 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
103 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
105 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
107 #define FUNC_NAME s_scm_array_dimensions
109 scm_t_array_handle handle
;
114 scm_array_get_handle (ra
, &handle
);
115 s
= scm_array_handle_dims (&handle
);
116 k
= scm_array_handle_rank (&handle
);
119 res
= scm_cons (s
[k
].lbnd
120 ? scm_cons2 (scm_from_ssize_t (s
[k
].lbnd
),
121 scm_from_ssize_t (s
[k
].ubnd
),
123 : scm_from_ssize_t (1 + s
[k
].ubnd
),
126 scm_array_handle_release (&handle
);
132 #include "libguile/bytevectors.h"
134 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
137 #define FUNC_NAME s_scm_array_type
139 scm_t_array_handle h
;
142 /* a hack, until srfi-4 and bytevectors are reunited */
143 if (scm_is_bytevector (ra
))
144 return scm_from_locale_symbol ("vu8");
146 scm_array_get_handle (ra
, &h
);
147 type
= scm_array_handle_element_type (&h
);
148 scm_array_handle_release (&h
);
154 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
156 "Return @code{#t} if its arguments would be acceptable to\n"
158 #define FUNC_NAME s_scm_array_in_bounds_p
160 SCM res
= SCM_BOOL_T
;
163 scm_t_array_handle handle
;
165 SCM_VALIDATE_REST_ARGUMENT (args
);
167 scm_array_get_handle (ra
, &handle
);
168 s
= scm_array_handle_dims (&handle
);
169 ndim
= scm_array_handle_rank (&handle
);
171 for (k
= 0; k
< ndim
; k
++)
175 if (!scm_is_pair (args
))
176 SCM_WRONG_NUM_ARGS ();
177 ind
= scm_to_long (SCM_CAR (args
));
178 args
= SCM_CDR (args
);
180 if (ind
< s
[k
].lbnd
|| ind
> s
[k
].ubnd
)
183 /* We do not stop the checking after finding a violation
184 since we want to validate the type-correctness and
185 number of arguments in any case.
190 scm_array_handle_release (&handle
);
195 SCM_DEFINE (scm_array_ref
, "array-ref", 1, 0, 1,
197 "Return the element at the @code{(index1, index2)} element in\n"
199 #define FUNC_NAME s_scm_array_ref
201 scm_t_array_handle handle
;
204 scm_array_get_handle (v
, &handle
);
205 res
= scm_array_handle_ref (&handle
, scm_array_handle_pos (&handle
, args
));
206 scm_array_handle_release (&handle
);
212 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
213 (SCM v
, SCM obj
, SCM args
),
214 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
215 "@var{new-value}. The value returned by array-set! is unspecified.")
216 #define FUNC_NAME s_scm_array_set_x
218 scm_t_array_handle handle
;
220 scm_array_get_handle (v
, &handle
);
221 scm_array_handle_set (&handle
, scm_array_handle_pos (&handle
, args
), obj
);
222 scm_array_handle_release (&handle
);
223 return SCM_UNSPECIFIED
;
228 array_to_list (scm_t_array_handle
*h
, size_t dim
, unsigned long pos
)
230 if (dim
== scm_array_handle_rank (h
))
231 return scm_array_handle_ref (h
, pos
);
238 i
= h
->dims
[dim
].ubnd
;
239 lbnd
= h
->dims
[dim
].lbnd
;
240 inc
= h
->dims
[dim
].inc
;
241 pos
+= (i
- h
->dims
[dim
].ubnd
) * inc
;
243 for (; i
>= lbnd
; i
--, pos
-= inc
)
244 res
= scm_cons (array_to_list (h
, dim
+ 1, pos
), res
);
249 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
251 "FIXME description a list consisting of all the elements, in order, of\n"
253 #define FUNC_NAME s_scm_array_to_list
255 scm_t_array_handle h
;
258 scm_array_get_handle (array
, &h
);
259 res
= array_to_list (&h
, 0, 0);
260 scm_array_handle_release (&h
);
267 scm_init_generalized_arrays ()
269 #include "libguile/generalized-arrays.x"