/* Copyright 1995-1998,2000-2006,2009,2011,2013-2014,2018 Free Software Foundation, Inc. This file is part of Guile. Guile is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. Guile is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with Guile. If not, see . */ #ifdef HAVE_CONFIG_H # include #endif #include #include "arrays.h" #include "boolean.h" #include "bitvectors.h" #include "bytevectors.h" #include "list.h" #include "numbers.h" #include "pairs.h" #include "strings.h" #include "symbols.h" #include "vectors.h" #include "array-handle.h" SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1]; /* Bytevectors as generalized vectors & arrays. */ #define DEFINE_BYTEVECTOR_ACCESSORS(type, tag, infix) \ static SCM \ bytevector_##tag##_ref (SCM bv, size_t pos) \ { \ SCM idx = scm_from_size_t (pos * sizeof (type)); \ return scm_bytevector_##infix##_ref (bv, idx); \ } \ static void \ bytevector_##tag##_set (SCM bv, size_t pos, SCM val) \ { \ SCM idx = scm_from_size_t (pos * sizeof (type)); \ scm_bytevector_##infix##_set_x (bv, idx, val); \ } DEFINE_BYTEVECTOR_ACCESSORS (uint8_t, u8, u8); DEFINE_BYTEVECTOR_ACCESSORS (int8_t, s8, s8); DEFINE_BYTEVECTOR_ACCESSORS (uint16_t, u16, u16_native); DEFINE_BYTEVECTOR_ACCESSORS (int16_t, s16, s16_native); DEFINE_BYTEVECTOR_ACCESSORS (uint32_t, u32, u32_native); DEFINE_BYTEVECTOR_ACCESSORS (int32_t, s32, s32_native); DEFINE_BYTEVECTOR_ACCESSORS (uint64_t, u64, u64_native); DEFINE_BYTEVECTOR_ACCESSORS (int64_t, s64, s64_native); DEFINE_BYTEVECTOR_ACCESSORS (float, f32, ieee_single_native); DEFINE_BYTEVECTOR_ACCESSORS (double, f64, ieee_double_native); /* Since these functions are only called by Guile's C code, we can abort instead of throwing if there is an error. */ static SCM bytevector_c32_ref (SCM bv, size_t pos) { char *c_bv; float real, imag; if (!SCM_BYTEVECTOR_P (bv)) abort (); c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); pos *= 2 * sizeof (float); if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv)) abort (); memcpy (&real, &c_bv[pos], sizeof (float)); memcpy (&imag, &c_bv[pos + sizeof (float)], sizeof (float)); return scm_c_make_rectangular (real, imag); } static SCM bytevector_c64_ref (SCM bv, size_t pos) { char *c_bv; double real, imag; if (!SCM_BYTEVECTOR_P (bv)) abort (); c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); pos *= 2 * sizeof (double); if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv)) abort (); memcpy (&real, &c_bv[pos], sizeof (double)); memcpy (&imag, &c_bv[pos + sizeof (double)], sizeof (double)); return scm_c_make_rectangular (real, imag); } static void bytevector_c32_set (SCM bv, size_t pos, SCM val) { char *c_bv; float real, imag; if (!SCM_BYTEVECTOR_P (bv)) abort (); c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); pos *= 2 * sizeof (float); if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv)) abort (); real = scm_c_real_part (val); imag = scm_c_imag_part (val); memcpy (&c_bv[pos], &real, sizeof (float)); memcpy (&c_bv[pos + sizeof (float)], &imag, sizeof (float)); } static void bytevector_c64_set (SCM bv, size_t pos, SCM val) { char *c_bv; double real, imag; if (!SCM_BYTEVECTOR_P (bv)) abort (); c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); pos *= 2 * sizeof (double); if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv)) abort (); real = scm_c_real_part (val); imag = scm_c_imag_part (val); memcpy (&c_bv[pos], &real, sizeof (double)); memcpy (&c_bv[pos + sizeof (double)], &imag, sizeof (double)); } static void initialize_vector_handle (scm_t_array_handle *h, size_t len, scm_t_array_element_type element_type, scm_t_vector_ref vref, scm_t_vector_set vset, const void *elements, int mutable_p) { h->base = 0; h->ndims = 1; h->dims = &h->dim0; h->dim0.lbnd = 0; h->dim0.ubnd = (ssize_t) (len - 1U); h->dim0.inc = 1; h->element_type = element_type; /* elements != writable_elements is used to check mutability later on. Ignore it if the array is empty. */ h->elements = len==0 ? NULL : elements; h->writable_elements = mutable_p ? ((void *) h->elements) : NULL; h->vector = h->array; h->vref = vref; h->vset = vset; } static SCM bitvector_ref (SCM bv, size_t idx) { return scm_from_bool (scm_c_bitvector_bit_is_set (bv, idx)); } static void bitvector_set_x (SCM bv, size_t idx, SCM val) { if (scm_is_true (val)) scm_c_bitvector_set_bit_x (bv, idx); else scm_c_bitvector_clear_bit_x (bv, idx); } void scm_array_get_handle (SCM array, scm_t_array_handle *h) { if (!SCM_HEAP_OBJECT_P (array)) scm_wrong_type_arg_msg (NULL, 0, array, "array"); h->array = array; switch (SCM_TYP7 (array)) { case scm_tc7_string: initialize_vector_handle (h, scm_c_string_length (array), SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_c_string_ref, scm_c_string_set_x, NULL, scm_i_string_is_mutable (array)); break; case scm_tc7_vector: initialize_vector_handle (h, scm_c_vector_length (array), SCM_ARRAY_ELEMENT_TYPE_SCM, scm_c_vector_ref, scm_c_vector_set_x, SCM_I_VECTOR_WELTS (array), SCM_I_IS_MUTABLE_VECTOR (array)); break; case scm_tc7_bitvector: initialize_vector_handle (h, scm_c_bitvector_length (array), SCM_ARRAY_ELEMENT_TYPE_BIT, bitvector_ref, bitvector_set_x, scm_i_bitvector_bits (array), scm_i_is_mutable_bitvector (array)); break; case scm_tc7_bytevector: { size_t length; scm_t_array_element_type element_type; scm_t_vector_ref vref; scm_t_vector_set vset; element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (array); length = SCM_BYTEVECTOR_TYPED_LENGTH (array); switch (element_type) { #define ACCESSOR_CASE(tag, TAG) \ case SCM_ARRAY_ELEMENT_TYPE_##TAG: \ vref = bytevector_##tag##_ref; \ vset = bytevector_##tag##_set; \ break case SCM_ARRAY_ELEMENT_TYPE_VU8: ACCESSOR_CASE(u8, U8); ACCESSOR_CASE(s8, S8); ACCESSOR_CASE(u16, U16); ACCESSOR_CASE(s16, S16); ACCESSOR_CASE(u32, U32); ACCESSOR_CASE(s32, S32); ACCESSOR_CASE(u64, U64); ACCESSOR_CASE(s64, S64); ACCESSOR_CASE(f32, F32); ACCESSOR_CASE(f64, F64); ACCESSOR_CASE(c32, C32); ACCESSOR_CASE(c64, C64); case SCM_ARRAY_ELEMENT_TYPE_SCM: case SCM_ARRAY_ELEMENT_TYPE_BIT: case SCM_ARRAY_ELEMENT_TYPE_CHAR: default: abort (); #undef ACCESSOR_CASE } initialize_vector_handle (h, length, element_type, vref, vset, SCM_BYTEVECTOR_CONTENTS (array), SCM_MUTABLE_BYTEVECTOR_P (array)); } break; case scm_tc7_array: scm_array_get_handle (SCM_I_ARRAY_V (array), h); h->array = array; h->base = SCM_I_ARRAY_BASE (array); h->ndims = SCM_I_ARRAY_NDIM (array); h->dims = SCM_I_ARRAY_DIMS (array); break; default: scm_wrong_type_arg_msg (NULL, 0, array, "array"); } } ssize_t scm_array_handle_pos (scm_t_array_handle *h, SCM indices) { scm_t_array_dim *s = scm_array_handle_dims (h); ssize_t pos = 0, i; size_t k = scm_array_handle_rank (h); while (k > 0 && scm_is_pair (indices)) { i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd); pos += (i - s->lbnd) * s->inc; k--; s++; indices = SCM_CDR (indices); } if (k > 0 || !scm_is_null (indices)) scm_misc_error (NULL, "wrong number of indices, expecting ~a", scm_list_1 (scm_from_size_t (scm_array_handle_rank (h)))); return pos; } static void check_array_index_bounds (scm_t_array_dim *dim, ssize_t idx) { if (idx < dim->lbnd || idx > dim->ubnd) scm_error (scm_out_of_range_key, NULL, "Value out of range ~S to ~S: ~S", scm_list_3 (scm_from_ssize_t (dim->lbnd), scm_from_ssize_t (dim->ubnd), scm_from_ssize_t (idx)), scm_list_1 (scm_from_ssize_t (idx))); } ssize_t scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0) { scm_t_array_dim *dim = scm_array_handle_dims (h); if (scm_array_handle_rank (h) != 1) scm_misc_error (NULL, "wrong number of indices, expecting ~A", scm_list_1 (scm_from_size_t (scm_array_handle_rank (h)))); check_array_index_bounds (&dim[0], idx0); return (idx0 - dim[0].lbnd) * dim[0].inc; } ssize_t scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1) { scm_t_array_dim *dim = scm_array_handle_dims (h); if (scm_array_handle_rank (h) != 2) scm_misc_error (NULL, "wrong number of indices, expecting ~A", scm_list_1 (scm_from_size_t (scm_array_handle_rank (h)))); check_array_index_bounds (&dim[0], idx0); check_array_index_bounds (&dim[1], idx1); return ((idx0 - dim[0].lbnd) * dim[0].inc + (idx1 - dim[1].lbnd) * dim[1].inc); } SCM scm_array_handle_element_type (scm_t_array_handle *h) { if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST) abort (); /* guile programming error */ return scm_i_array_element_types[h->element_type]; } void scm_array_handle_release (scm_t_array_handle *h) { /* Nothing to do here until arrays need to be reserved for real. */ } const SCM * scm_array_handle_elements (scm_t_array_handle *h) { if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); return ((const SCM *) h->elements) + h->base; } SCM * scm_array_handle_writable_elements (scm_t_array_handle *h) { if (h->writable_elements != h->elements) scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable array"); return (SCM *) scm_array_handle_elements (h); } void scm_init_array_handle (void) { #define DEFINE_ARRAY_TYPE(tag, TAG) \ scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_utf8_symbol (#tag) scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T; DEFINE_ARRAY_TYPE (a, CHAR); DEFINE_ARRAY_TYPE (b, BIT); DEFINE_ARRAY_TYPE (vu8, VU8); DEFINE_ARRAY_TYPE (u8, U8); DEFINE_ARRAY_TYPE (s8, S8); DEFINE_ARRAY_TYPE (u16, U16); DEFINE_ARRAY_TYPE (s16, S16); DEFINE_ARRAY_TYPE (u32, U32); DEFINE_ARRAY_TYPE (s32, S32); DEFINE_ARRAY_TYPE (u64, U64); DEFINE_ARRAY_TYPE (s64, S64); DEFINE_ARRAY_TYPE (f32, F32); DEFINE_ARRAY_TYPE (f64, F64); DEFINE_ARRAY_TYPE (c32, C32); DEFINE_ARRAY_TYPE (c64, C64); #include "array-handle.x" }