1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
2 * 2006, 2009, 2011, 2013, 2014 Free Software Foundation, Inc.
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.
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.
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
27 #include "libguile/_scm.h"
28 #include "libguile/__scm.h"
30 #include "libguile/array-handle.h"
33 SCM scm_i_array_element_types
[SCM_ARRAY_ELEMENT_TYPE_LAST
+ 1];
36 /* Bytevectors as generalized vectors & arrays. */
38 #define DEFINE_BYTEVECTOR_ACCESSORS(type, tag, infix) \
40 bytevector_##tag##_ref (SCM bv, size_t pos) \
42 SCM idx = scm_from_size_t (pos * sizeof (type)); \
43 return scm_bytevector_##infix##_ref (bv, idx); \
46 bytevector_##tag##_set (SCM bv, size_t pos, SCM val) \
48 SCM idx = scm_from_size_t (pos * sizeof (type)); \
49 scm_bytevector_##infix##_set_x (bv, idx, val); \
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
);
63 /* Since these functions are only called by Guile's C code, we can abort
64 instead of throwing if there is an error. */
66 bytevector_c32_ref (SCM bv
, size_t pos
)
71 if (!SCM_BYTEVECTOR_P (bv
))
73 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
74 pos
*= 2 * sizeof (float);
75 if (pos
+ 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv
))
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
);
84 bytevector_c64_ref (SCM bv
, size_t pos
)
89 if (!SCM_BYTEVECTOR_P (bv
))
91 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
92 pos
*= 2 * sizeof (double);
93 if (pos
+ 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv
))
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
);
102 bytevector_c32_set (SCM bv
, size_t pos
, SCM val
)
107 if (!SCM_BYTEVECTOR_P (bv
))
109 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
110 pos
*= 2 * sizeof (float);
111 if (pos
+ 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv
))
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));
121 bytevector_c64_set (SCM bv
, size_t pos
, SCM val
)
126 if (!SCM_BYTEVECTOR_P (bv
))
128 c_bv
= (char *) SCM_BYTEVECTOR_CONTENTS (bv
);
129 pos
*= 2 * sizeof (double);
130 if (pos
+ 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv
))
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));
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
)
149 h
->dim0
.ubnd
= (ssize_t
) (len
- 1U);
151 h
->element_type
= element_type
;
152 h
->elements
= h
->writable_elements
= writable_elements
;
153 h
->vector
= h
->array
;
159 scm_array_get_handle (SCM array
, scm_t_array_handle
*h
)
161 if (!SCM_HEAP_OBJECT_P (array
))
162 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
166 switch (SCM_TYP7 (array
))
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
,
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
));
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
));
186 case scm_tc7_bytevector
:
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
;
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
;
198 switch (element_type
)
200 #define ACCESSOR_CASE(tag, TAG) \
201 case SCM_ARRAY_ELEMENT_TYPE_##TAG: \
202 vref = bytevector_##tag##_ref; \
203 vset = bytevector_##tag##_set; \
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
);
220 case SCM_ARRAY_ELEMENT_TYPE_SCM
:
221 case SCM_ARRAY_ELEMENT_TYPE_BIT
:
222 case SCM_ARRAY_ELEMENT_TYPE_CHAR
:
229 initialize_vector_handle (h
, length
, element_type
, vref
, vset
,
230 SCM_BYTEVECTOR_CONTENTS (array
));
234 scm_array_get_handle (SCM_I_ARRAY_V (array
), h
);
236 h
->base
= SCM_I_ARRAY_BASE (array
);
237 h
->ndims
= SCM_I_ARRAY_NDIM (array
);
238 h
->dims
= SCM_I_ARRAY_DIMS (array
);
241 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
246 scm_array_handle_pos (scm_t_array_handle
*h
, SCM indices
)
248 scm_t_array_dim
*s
= scm_array_handle_dims (h
);
250 size_t k
= scm_array_handle_rank (h
);
252 while (k
> 0 && scm_is_pair (indices
))
254 i
= scm_to_signed_integer (SCM_CAR (indices
), s
->lbnd
, s
->ubnd
);
255 pos
+= (i
- s
->lbnd
) * s
->inc
;
258 indices
= SCM_CDR (indices
);
260 if (k
> 0 || !scm_is_null (indices
))
261 scm_misc_error (NULL
, "wrong number of indices, expecting ~a",
262 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h
))));
267 check_array_index_bounds (scm_t_array_dim
*dim
, ssize_t idx
)
269 if (idx
< dim
->lbnd
|| idx
> dim
->ubnd
)
270 scm_error (scm_out_of_range_key
, NULL
, "Value out of range ~S to ~S: ~S",
271 scm_list_3 (scm_from_ssize_t (dim
->lbnd
),
272 scm_from_ssize_t (dim
->ubnd
),
273 scm_from_ssize_t (idx
)),
274 scm_list_1 (scm_from_ssize_t (idx
)));
278 scm_array_handle_pos_1 (scm_t_array_handle
*h
, ssize_t idx0
)
280 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
282 if (scm_array_handle_rank (h
) != 1)
283 scm_misc_error (NULL
, "wrong number of indices, expecting ~A",
284 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h
))));
286 check_array_index_bounds (&dim
[0], idx0
);
288 return (idx0
- dim
[0].lbnd
) * dim
[0].inc
;
292 scm_array_handle_pos_2 (scm_t_array_handle
*h
, ssize_t idx0
, ssize_t idx1
)
294 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
296 if (scm_array_handle_rank (h
) != 2)
297 scm_misc_error (NULL
, "wrong number of indices, expecting ~A",
298 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h
))));
300 check_array_index_bounds (&dim
[0], idx0
);
301 check_array_index_bounds (&dim
[1], idx1
);
303 return ((idx0
- dim
[0].lbnd
) * dim
[0].inc
304 + (idx1
- dim
[1].lbnd
) * dim
[1].inc
);
308 scm_array_handle_element_type (scm_t_array_handle
*h
)
310 if (h
->element_type
< 0 || h
->element_type
> SCM_ARRAY_ELEMENT_TYPE_LAST
)
311 abort (); /* guile programming error */
312 return scm_i_array_element_types
[h
->element_type
];
316 scm_array_handle_release (scm_t_array_handle
*h
)
318 /* Nothing to do here until arrays need to be reserved for real.
323 scm_array_handle_elements (scm_t_array_handle
*h
)
325 if (h
->element_type
!= SCM_ARRAY_ELEMENT_TYPE_SCM
)
326 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
327 return ((const SCM
*)h
->elements
) + h
->base
;
331 scm_array_handle_writable_elements (scm_t_array_handle
*h
)
333 if (h
->element_type
!= SCM_ARRAY_ELEMENT_TYPE_SCM
)
334 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
335 return ((SCM
*)h
->elements
) + h
->base
;
339 scm_init_array_handle (void)
341 #define DEFINE_ARRAY_TYPE(tag, TAG) \
342 scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_utf8_symbol (#tag)
344 scm_i_array_element_types
[SCM_ARRAY_ELEMENT_TYPE_SCM
] = SCM_BOOL_T
;
345 DEFINE_ARRAY_TYPE (a
, CHAR
);
346 DEFINE_ARRAY_TYPE (b
, BIT
);
347 DEFINE_ARRAY_TYPE (vu8
, VU8
);
348 DEFINE_ARRAY_TYPE (u8
, U8
);
349 DEFINE_ARRAY_TYPE (s8
, S8
);
350 DEFINE_ARRAY_TYPE (u16
, U16
);
351 DEFINE_ARRAY_TYPE (s16
, S16
);
352 DEFINE_ARRAY_TYPE (u32
, U32
);
353 DEFINE_ARRAY_TYPE (s32
, S32
);
354 DEFINE_ARRAY_TYPE (u64
, U64
);
355 DEFINE_ARRAY_TYPE (s64
, S64
);
356 DEFINE_ARRAY_TYPE (f32
, F32
);
357 DEFINE_ARRAY_TYPE (f64
, F64
);
358 DEFINE_ARRAY_TYPE (c32
, C32
);
359 DEFINE_ARRAY_TYPE (c64
, C64
);
361 #include "libguile/array-handle.x"