HCoop / bpt / guile.git / blob
? search:


84e9f88a177e7a6f32b414d7b1da7b315472525b
[bpt/guile.git] / libguile / array-handle.c
1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
2 * 2006, 2009, 2011, 2013, 2014 Free Software Foundation, Inc.
3 *
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
8 *
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
13 *
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
17 * 02110-1301 USA
18 */
19
20
21 \f
22
23 #ifdef HAVE_CONFIG_H
24 # include <config.h>
25 #endif
26
27 #include "libguile/_scm.h"
28 #include "libguile/__scm.h"
29
30 #include "libguile/array-handle.h"
31
32
33 SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1];
34
35
36 /* Bytevectors as generalized vectors & arrays. */
37
38 #define DEFINE_BYTEVECTOR_ACCESSORS(type, tag, infix) \
39 static SCM \
40 bytevector_##tag##_ref (SCM bv, size_t pos) \
41 { \
42 SCM idx = scm_from_size_t (pos * sizeof (type)); \
43 return scm_bytevector_##infix##_ref (bv, idx); \
44 } \
45 static void \
46 bytevector_##tag##_set (SCM bv, size_t pos, SCM val) \
47 { \
48 SCM idx = scm_from_size_t (pos * sizeof (type)); \
49 scm_bytevector_##infix##_set_x (bv, idx, val); \
50 }
51
52 DEFINE_BYTEVECTOR_ACCESSORS (uint8_t, u8, u8);
53 DEFINE_BYTEVECTOR_ACCESSORS (int8_t, s8, s8);
54 DEFINE_BYTEVECTOR_ACCESSORS (uint16_t, u16, u16_native);
55 DEFINE_BYTEVECTOR_ACCESSORS (int16_t, s16, s16_native);
56 DEFINE_BYTEVECTOR_ACCESSORS (uint32_t, u32, u32_native);
57 DEFINE_BYTEVECTOR_ACCESSORS (int32_t, s32, s32_native);
58 DEFINE_BYTEVECTOR_ACCESSORS (uint64_t, u64, u64_native);
59 DEFINE_BYTEVECTOR_ACCESSORS (int64_t, s64, s64_native);
60 DEFINE_BYTEVECTOR_ACCESSORS (float, f32, ieee_single_native);
61 DEFINE_BYTEVECTOR_ACCESSORS (double, f64, ieee_double_native);
62
63 /* Since these functions are only called by Guile's C code, we can abort
64 instead of throwing if there is an error. */
65 static SCM
66 bytevector_c32_ref (SCM bv, size_t pos)
67 {
68 char *c_bv;
69 float real, imag;
70
71 if (!SCM_BYTEVECTOR_P (bv))
72 abort ();
73 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
74 pos *= 2 * sizeof (float);
75 if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
76 abort ();
77
78 memcpy (&real, &c_bv[pos], sizeof (float));
79 memcpy (&imag, &c_bv[pos + sizeof (float)], sizeof (float));
80 return scm_c_make_rectangular (real, imag);
81 }
82
83 static SCM
84 bytevector_c64_ref (SCM bv, size_t pos)
85 {
86 char *c_bv;
87 double real, imag;
88
89 if (!SCM_BYTEVECTOR_P (bv))
90 abort ();
91 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
92 pos *= 2 * sizeof (double);
93 if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
94 abort ();
95
96 memcpy (&real, &c_bv[pos], sizeof (double));
97 memcpy (&imag, &c_bv[pos + sizeof (double)], sizeof (double));
98 return scm_c_make_rectangular (real, imag);
99 }
100
101 static void
102 bytevector_c32_set (SCM bv, size_t pos, SCM val)
103 {
104 char *c_bv;
105 float real, imag;
106
107 if (!SCM_BYTEVECTOR_P (bv))
108 abort ();
109 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
110 pos *= 2 * sizeof (float);
111 if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
112 abort ();
113
114 real = scm_c_real_part (val);
115 imag = scm_c_imag_part (val);
116 memcpy (&c_bv[pos], &real, sizeof (float));
117 memcpy (&c_bv[pos + sizeof (float)], &imag, sizeof (float));
118 }
119
120 static void
121 bytevector_c64_set (SCM bv, size_t pos, SCM val)
122 {
123 char *c_bv;
124 double real, imag;
125
126 if (!SCM_BYTEVECTOR_P (bv))
127 abort ();
128 c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
129 pos *= 2 * sizeof (double);
130 if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
131 abort ();
132
133 real = scm_c_real_part (val);
134 imag = scm_c_imag_part (val);
135 memcpy (&c_bv[pos], &real, sizeof (double));
136 memcpy (&c_bv[pos + sizeof (double)], &imag, sizeof (double));
137 }
138
139 static void
140 initialize_vector_handle (scm_t_array_handle *h, size_t len,
141 scm_t_array_element_type element_type,
142 scm_t_vector_ref vref, scm_t_vector_set vset,
143 void *writable_elements)
144 {
145 h->base = 0;
146 h->ndims = 1;
147 h->dims = &h->dim0;
148 h->dim0.lbnd = 0;
149 h->dim0.ubnd = (ssize_t) (len - 1U);
150 h->dim0.inc = 1;
151 h->element_type = element_type;
152 h->elements = h->writable_elements = writable_elements;
153 h->vector = h->array;
154 h->vref = vref;
155 h->vset = vset;
156 }
157
158 void
159 scm_array_get_handle (SCM array, scm_t_array_handle *h)
160 {
161 if (!SCM_HEAP_OBJECT_P (array))
162 scm_wrong_type_arg_msg (NULL, 0, array, "array");
163
164 h->array = array;
165
166 switch (SCM_TYP7 (array))
167 {
168 case scm_tc7_string:
169 initialize_vector_handle (h, scm_c_string_length (array),
170 SCM_ARRAY_ELEMENT_TYPE_CHAR,
171 scm_c_string_ref, scm_c_string_set_x,
172 NULL);
173 break;
174 case scm_tc7_vector:
175 initialize_vector_handle (h, scm_c_vector_length (array),
176 SCM_ARRAY_ELEMENT_TYPE_SCM,
177 scm_c_vector_ref, scm_c_vector_set_x,
178 SCM_I_VECTOR_WELTS (array));
179 break;
180 case scm_tc7_bitvector:
181 initialize_vector_handle (h, scm_c_bitvector_length (array),
182 SCM_ARRAY_ELEMENT_TYPE_BIT,
183 scm_c_bitvector_ref, scm_c_bitvector_set_x,
184 scm_i_bitvector_bits (array));
185 break;
186 case scm_tc7_bytevector:
187 {
188 size_t byte_length, length, element_byte_size;
189 scm_t_array_element_type element_type;
190 scm_t_vector_ref vref;
191 scm_t_vector_set vset;
192
193 byte_length = scm_c_bytevector_length (array);
194 element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (array);
195 element_byte_size = scm_i_array_element_type_sizes[element_type] / 8;
196 length = byte_length / element_byte_size;
197
198 switch (element_type)
199 {
200 #define ACCESSOR_CASE(tag, TAG) \
201 case SCM_ARRAY_ELEMENT_TYPE_##TAG: \
202 vref = bytevector_##tag##_ref; \
203 vset = bytevector_##tag##_set; \
204 break
205
206 case SCM_ARRAY_ELEMENT_TYPE_VU8:
207 ACCESSOR_CASE(u8, U8);
208 ACCESSOR_CASE(s8, S8);
209 ACCESSOR_CASE(u16, U16);
210 ACCESSOR_CASE(s16, S16);
211 ACCESSOR_CASE(u32, U32);
212 ACCESSOR_CASE(s32, S32);
213 ACCESSOR_CASE(u64, U64);
214 ACCESSOR_CASE(s64, S64);
215 ACCESSOR_CASE(f32, F32);
216 ACCESSOR_CASE(f64, F64);
217 ACCESSOR_CASE(c32, C32);
218 ACCESSOR_CASE(c64, C64);
219
220 case SCM_ARRAY_ELEMENT_TYPE_SCM:
221 case SCM_ARRAY_ELEMENT_TYPE_BIT:
222 case SCM_ARRAY_ELEMENT_TYPE_CHAR:
223 default:
224 abort ();
225
226 #undef ACCESSOR_CASE
227 }
228
229 initialize_vector_handle (h, length, element_type, vref, vset,
230 SCM_BYTEVECTOR_CONTENTS (array));
231 }
232 break;
233 case scm_tc7_array:
234 h->base = SCM_I_ARRAY_BASE (array);
235 h->ndims = SCM_I_ARRAY_NDIM (array);
236 h->dims = SCM_I_ARRAY_DIMS (array);
237 {
238 scm_t_array_handle vh;
239
240 scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
241 h->element_type = vh.element_type;
242 h->elements = vh.elements;
243 h->writable_elements = vh.writable_elements;
244 h->vector = vh.vector;
245 h->vref = vh.vref;
246 h->vset = vh.vset;
247 scm_array_handle_release (&vh);
248 }
249 break;
250 default:
251 scm_wrong_type_arg_msg (NULL, 0, array, "array");
252 }
253 }
254
255 ssize_t
256 scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
257 {
258 scm_t_array_dim *s = scm_array_handle_dims (h);
259 ssize_t pos = 0, i;
260 size_t k = scm_array_handle_rank (h);
261
262 while (k > 0 && scm_is_pair (indices))
263 {
264 i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
265 pos += (i - s->lbnd) * s->inc;
266 k--;
267 s++;
268 indices = SCM_CDR (indices);
269 }
270 if (k > 0 || !scm_is_null (indices))
271 scm_misc_error (NULL, "wrong number of indices, expecting ~a",
272 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
273 return pos;
274 }
275
276 static void
277 check_array_index_bounds (scm_t_array_dim *dim, ssize_t idx)
278 {
279 if (idx < dim->lbnd || idx > dim->ubnd)
280 scm_error (scm_out_of_range_key, NULL, "Value out of range ~S to ~S: ~S",
281 scm_list_3 (scm_from_ssize_t (dim->lbnd),
282 scm_from_ssize_t (dim->ubnd),
283 scm_from_ssize_t (idx)),
284 scm_list_1 (scm_from_ssize_t (idx)));
285 }
286
287 ssize_t
288 scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0)
289 {
290 scm_t_array_dim *dim = scm_array_handle_dims (h);
291
292 if (scm_array_handle_rank (h) != 1)
293 scm_misc_error (NULL, "wrong number of indices, expecting ~A",
294 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
295
296 check_array_index_bounds (&dim[0], idx0);
297
298 return (idx0 - dim[0].lbnd) * dim[0].inc;
299 }
300
301 ssize_t
302 scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1)
303 {
304 scm_t_array_dim *dim = scm_array_handle_dims (h);
305
306 if (scm_array_handle_rank (h) != 2)
307 scm_misc_error (NULL, "wrong number of indices, expecting ~A",
308 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
309
310 check_array_index_bounds (&dim[0], idx0);
311 check_array_index_bounds (&dim[1], idx1);
312
313 return ((idx0 - dim[0].lbnd) * dim[0].inc
314 + (idx1 - dim[1].lbnd) * dim[1].inc);
315 }
316
317 SCM
318 scm_array_handle_element_type (scm_t_array_handle *h)
319 {
320 if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST)
321 abort (); /* guile programming error */
322 return scm_i_array_element_types[h->element_type];
323 }
324
325 void
326 scm_array_handle_release (scm_t_array_handle *h)
327 {
328 /* Nothing to do here until arrays need to be reserved for real.
329 */
330 }
331
332 const SCM *
333 scm_array_handle_elements (scm_t_array_handle *h)
334 {
335 if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
336 scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
337 return ((const SCM*)h->elements) + h->base;
338 }
339
340 SCM *
341 scm_array_handle_writable_elements (scm_t_array_handle *h)
342 {
343 if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
344 scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
345 return ((SCM*)h->elements) + h->base;
346 }
347
348 void
349 scm_init_array_handle (void)
350 {
351 #define DEFINE_ARRAY_TYPE(tag, TAG) \
352 scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_utf8_symbol (#tag)
353
354 scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
355 DEFINE_ARRAY_TYPE (a, CHAR);
356 DEFINE_ARRAY_TYPE (b, BIT);
357 DEFINE_ARRAY_TYPE (vu8, VU8);
358 DEFINE_ARRAY_TYPE (u8, U8);
359 DEFINE_ARRAY_TYPE (s8, S8);
360 DEFINE_ARRAY_TYPE (u16, U16);
361 DEFINE_ARRAY_TYPE (s16, S16);
362 DEFINE_ARRAY_TYPE (u32, U32);
363 DEFINE_ARRAY_TYPE (s32, S32);
364 DEFINE_ARRAY_TYPE (u64, U64);
365 DEFINE_ARRAY_TYPE (s64, S64);
366 DEFINE_ARRAY_TYPE (f32, F32);
367 DEFINE_ARRAY_TYPE (f64, F64);
368 DEFINE_ARRAY_TYPE (c32, C32);
369 DEFINE_ARRAY_TYPE (c64, C64);
370
371 #include "libguile/array-handle.x"
372 }
373
374 /*
375 Local Variables:
376 c-file-style: "gnu"
377 End:
378 */
Unnamed repository; edit this file 'description' to name the repository.