mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
8110061e64
* NEWS: Add entry. * doc/ref/api-data.texi (Bit Vectors): Update. * libguile/array-handle.h (bitvector_set_x, scm_array_get_handle): Adapt to bitvector changes. * libguile/bitvectors.h: * libguile/bitvectors.c (scm_c_bitvector_set_bit_x) (scm_c_bitvector_clear_bit_x): New functions. * libguile/deprecated.h: * libguile/deprecated.c (scm_bitvector_set_x): Deprecate. * module/ice-9/sandbox.scm (mutable-bitvector-bindings): Replace bitvector-set! with bitvector-set-bit! / bitvector-clear-bit!. * module/system/vm/disassembler.scm (static-opcode-set): Use bitvector-set-bit!. * module/system/vm/frame.scm (compute-defs-by-slot, available-bindings): Use bitvector-set-bit!. * test-suite/tests/bitvectors.test: Update.
395 lines
12 KiB
C
395 lines
12 KiB
C
/* 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
|
||
<https://www.gnu.org/licenses/>. */
|
||
|
||
|
||
|
||
|
||
#ifdef HAVE_CONFIG_H
|
||
# include <config.h>
|
||
#endif
|
||
|
||
#include <string.h>
|
||
|
||
#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"
|
||
}
|