diff options
Diffstat (limited to 'libguile/unif.c')
-rw-r--r-- | libguile/unif.c | 3034 |
1 files changed, 0 insertions, 3034 deletions
diff --git a/libguile/unif.c b/libguile/unif.c deleted file mode 100644 index 84b532347..000000000 --- a/libguile/unif.c +++ /dev/null @@ -1,3034 +0,0 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc. - * - * This library 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. - * - * This library 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 this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - - -/* - This file has code for arrays in lots of variants (double, integer, - unsigned etc. ). It suffers from hugely repetitive code because - there is similar (but different) code for every variant included. (urg.) - - --hwn -*/ - - -#ifdef HAVE_CONFIG_H -# include <config.h> -#endif - -#include <stdio.h> -#include <errno.h> -#include <string.h> - -#include "libguile/_scm.h" -#include "libguile/__scm.h" -#include "libguile/eq.h" -#include "libguile/chars.h" -#include "libguile/eval.h" -#include "libguile/fports.h" -#include "libguile/smob.h" -#include "libguile/feature.h" -#include "libguile/root.h" -#include "libguile/strings.h" -#include "libguile/srfi-13.h" -#include "libguile/srfi-4.h" -#include "libguile/vectors.h" -#include "libguile/bytevectors.h" -#include "libguile/list.h" -#include "libguile/deprecation.h" -#include "libguile/dynwind.h" - -#include "libguile/validate.h" -#include "libguile/unif.h" -#include "libguile/ramap.h" -#include "libguile/print.h" -#include "libguile/read.h" - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - -#ifdef HAVE_IO_H -#include <io.h> -#endif - - -/* The set of uniform scm_vector types is: - * Vector of: Called: Replaced by: - * unsigned char string - * char byvect s8 or u8, depending on signedness of 'char' - * boolean bvect - * signed long ivect s32 - * unsigned long uvect u32 - * float fvect f32 - * double dvect d32 - * complex double cvect c64 - * short svect s16 - * long long llvect s64 - */ - -scm_t_bits scm_i_tc16_array; -scm_t_bits scm_i_tc16_enclosed_array; - -#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ - (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS)) -#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ - (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS)) - -typedef SCM creator_proc (SCM len, SCM fill); - -struct { - char *type_name; - SCM type; - creator_proc *creator; -} type_creator_table[] = { - { "a", SCM_UNSPECIFIED, scm_make_string }, - { "b", SCM_UNSPECIFIED, scm_make_bitvector }, - { "u8", SCM_UNSPECIFIED, scm_make_u8vector }, - { "s8", SCM_UNSPECIFIED, scm_make_s8vector }, - { "u16", SCM_UNSPECIFIED, scm_make_u16vector }, - { "s16", SCM_UNSPECIFIED, scm_make_s16vector }, - { "u32", SCM_UNSPECIFIED, scm_make_u32vector }, - { "s32", SCM_UNSPECIFIED, scm_make_s32vector }, - { "u64", SCM_UNSPECIFIED, scm_make_u64vector }, - { "s64", SCM_UNSPECIFIED, scm_make_s64vector }, - { "f32", SCM_UNSPECIFIED, scm_make_f32vector }, - { "f64", SCM_UNSPECIFIED, scm_make_f64vector }, - { "c32", SCM_UNSPECIFIED, scm_make_c32vector }, - { "c64", SCM_UNSPECIFIED, scm_make_c64vector }, - { "vu8", SCM_UNSPECIFIED, scm_make_bytevector }, - { NULL } -}; - -static void -init_type_creator_table () -{ - int i; - for (i = 0; type_creator_table[i].type_name; i++) - { - SCM sym = scm_from_locale_symbol (type_creator_table[i].type_name); - type_creator_table[i].type = scm_permanent_object (sym); - } -} - -static creator_proc * -type_to_creator (SCM type) -{ - int i; - - if (scm_is_eq (type, SCM_BOOL_T)) - return scm_make_vector; - for (i = 0; type_creator_table[i].type_name; i++) - if (scm_is_eq (type, type_creator_table[i].type)) - return type_creator_table[i].creator; - - scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (type)); -} - -static SCM -make_typed_vector (SCM type, size_t len) -{ - creator_proc *creator = type_to_creator (type); - return creator (scm_from_size_t (len), SCM_UNDEFINED); -} - -#if SCM_ENABLE_DEPRECATED - -SCM_SYMBOL (scm_sym_s, "s"); -SCM_SYMBOL (scm_sym_l, "l"); - -static int -singp (SCM obj) -{ - if (!SCM_REALP (obj)) - return 0; - else - { - double x = SCM_REAL_VALUE (obj); - float fx = x; - return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x); - } -} - -SCM_API int scm_i_inump (SCM obj); -SCM_API scm_t_signed_bits scm_i_inum (SCM obj); - -static SCM -prototype_to_type (SCM proto) -{ - const char *type_name; - - if (scm_is_eq (proto, SCM_BOOL_T)) - type_name = "b"; - else if (scm_is_eq (proto, SCM_MAKE_CHAR (0))) - type_name = "s8"; - else if (SCM_CHARP (proto)) - type_name = "a"; - else if (scm_i_inump (proto)) - { - if (scm_i_inum (proto) > 0) - type_name = "u32"; - else - type_name = "s32"; - } - else if (scm_is_eq (proto, scm_sym_s)) - type_name = "s16"; - else if (scm_is_eq (proto, scm_sym_l)) - type_name = "s64"; - else if (SCM_REALP (proto) - || scm_is_true (scm_eqv_p (proto, - scm_divide (scm_from_int (1), - scm_from_int (3))))) - { - if (singp (proto)) - type_name = "f32"; - else - type_name = "f64"; - } - else if (SCM_COMPLEXP (proto)) - type_name = "c64"; - else if (scm_is_null (proto)) - type_name = NULL; - else - type_name = NULL; - - if (type_name) - return scm_from_locale_symbol (type_name); - else - return SCM_BOOL_T; -} - -static SCM -scm_i_get_old_prototype (SCM uvec) -{ - if (scm_is_bitvector (uvec)) - return SCM_BOOL_T; - else if (scm_is_string (uvec)) - return SCM_MAKE_CHAR ('a'); - else if (scm_is_true (scm_s8vector_p (uvec))) - return SCM_MAKE_CHAR ('\0'); - else if (scm_is_true (scm_s16vector_p (uvec))) - return scm_sym_s; - else if (scm_is_true (scm_u32vector_p (uvec))) - return scm_from_int (1); - else if (scm_is_true (scm_s32vector_p (uvec))) - return scm_from_int (-1); - else if (scm_is_true (scm_s64vector_p (uvec))) - return scm_sym_l; - else if (scm_is_true (scm_f32vector_p (uvec))) - return scm_from_double (1.0); - else if (scm_is_true (scm_f64vector_p (uvec))) - return scm_divide (scm_from_int (1), scm_from_int (3)); - else if (scm_is_true (scm_c64vector_p (uvec))) - return scm_c_make_rectangular (0, 1); - else if (scm_is_vector (uvec)) - return SCM_EOL; - else - scm_misc_error (NULL, "~a has no prototype", scm_list_1 (uvec)); -} - -SCM -scm_make_uve (long k, SCM prot) -#define FUNC_NAME "scm_make_uve" -{ - scm_c_issue_deprecation_warning - ("`scm_make_uve' is deprecated, see the manual for alternatives."); - - return make_typed_vector (prototype_to_type (prot), k); -} -#undef FUNC_NAME - -#endif - -int -scm_is_array (SCM obj) -{ - return (SCM_I_ENCLOSED_ARRAYP (obj) - || SCM_I_ARRAYP (obj) - || scm_is_generalized_vector (obj)); -} - -int -scm_is_typed_array (SCM obj, SCM type) -{ - if (SCM_I_ENCLOSED_ARRAYP (obj)) - { - /* Enclosed arrays are arrays but are not of any type. - */ - return 0; - } - - /* Get storage vector. - */ - if (SCM_I_ARRAYP (obj)) - obj = SCM_I_ARRAY_V (obj); - - /* It must be a generalized vector (which includes vectors, strings, etc). - */ - if (!scm_is_generalized_vector (obj)) - return 0; - - return scm_is_eq (type, scm_i_generalized_vector_type (obj)); -} - -static SCM -enclosed_ref (scm_t_array_handle *h, ssize_t pos) -{ - return scm_i_cvref (SCM_I_ARRAY_V (h->array), pos + h->base, 1); -} - -static SCM -vector_ref (scm_t_array_handle *h, ssize_t pos) -{ - return ((const SCM *)h->elements)[pos]; -} - -static SCM -string_ref (scm_t_array_handle *h, ssize_t pos) -{ - pos += h->base; - if (SCM_I_ARRAYP (h->array)) - return scm_c_string_ref (SCM_I_ARRAY_V (h->array), pos); - else - return scm_c_string_ref (h->array, pos); -} - -static SCM -bitvector_ref (scm_t_array_handle *h, ssize_t pos) -{ - pos += scm_array_handle_bit_elements_offset (h); - return - scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32))); -} - -static SCM -bytevector_ref (scm_t_array_handle *h, ssize_t pos) -{ - return scm_from_uint8 (((scm_t_uint8 *) h->elements)[pos]); -} - -static SCM -memoize_ref (scm_t_array_handle *h, ssize_t pos) -{ - SCM v = h->array; - - if (SCM_I_ENCLOSED_ARRAYP (v)) - { - h->ref = enclosed_ref; - return enclosed_ref (h, pos); - } - - if (SCM_I_ARRAYP (v)) - v = SCM_I_ARRAY_V (v); - - if (scm_is_vector (v)) - { - h->elements = scm_array_handle_elements (h); - h->ref = vector_ref; - } - else if (scm_is_uniform_vector (v)) - { - h->elements = scm_array_handle_uniform_elements (h); - h->ref = scm_i_uniform_vector_ref_proc (v); - } - else if (scm_is_string (v)) - { - h->ref = string_ref; - } - else if (scm_is_bitvector (v)) - { - h->elements = scm_array_handle_bit_elements (h); - h->ref = bitvector_ref; - } - else if (scm_is_bytevector (v)) - { - h->elements = scm_array_handle_uniform_elements (h); - h->ref = bytevector_ref; - } - else - scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array)); - - return h->ref (h, pos); -} - -static void -enclosed_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array"); -} - -static void -vector_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - ((SCM *)h->writable_elements)[pos] = val; -} - -static void -string_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - pos += h->base; - if (SCM_I_ARRAYP (h->array)) - scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val); - else - scm_c_string_set_x (h->array, pos, val); -} - -static void -bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - scm_t_uint32 mask; - pos += scm_array_handle_bit_elements_offset (h); - mask = 1l << (pos % 32); - if (scm_to_bool (val)) - ((scm_t_uint32 *)h->writable_elements)[pos/32] |= mask; - else - ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask; -} - -static void -bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - scm_t_uint8 c_value; - scm_t_uint8 *elements; - - c_value = scm_to_uint8 (val); - elements = (scm_t_uint8 *) h->elements; - elements[pos] = (scm_t_uint8) c_value; -} - -static void -memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - SCM v = h->array; - - if (SCM_I_ENCLOSED_ARRAYP (v)) - { - h->set = enclosed_set; - enclosed_set (h, pos, val); - return; - } - - if (SCM_I_ARRAYP (v)) - v = SCM_I_ARRAY_V (v); - - if (scm_is_vector (v)) - { - h->writable_elements = scm_array_handle_writable_elements (h); - h->set = vector_set; - } - else if (scm_is_uniform_vector (v)) - { - h->writable_elements = scm_array_handle_uniform_writable_elements (h); - h->set = scm_i_uniform_vector_set_proc (v); - } - else if (scm_is_string (v)) - { - h->set = string_set; - } - else if (scm_is_bitvector (v)) - { - h->writable_elements = scm_array_handle_bit_writable_elements (h); - h->set = bitvector_set; - } - else if (scm_is_bytevector (v)) - { - h->elements = scm_array_handle_uniform_writable_elements (h); - h->set = bytevector_set; - } - else - scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array)); - - h->set (h, pos, val); -} - -void -scm_array_get_handle (SCM array, scm_t_array_handle *h) -{ - h->array = array; - h->ref = memoize_ref; - h->set = memoize_set; - - if (SCM_I_ARRAYP (array) || SCM_I_ENCLOSED_ARRAYP (array)) - { - h->dims = SCM_I_ARRAY_DIMS (array); - h->base = SCM_I_ARRAY_BASE (array); - } - else if (scm_is_generalized_vector (array)) - { - h->dim0.lbnd = 0; - h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1; - h->dim0.inc = 1; - h->dims = &h->dim0; - h->base = 0; - } - else - scm_wrong_type_arg_msg (NULL, 0, array, "array"); -} - -void -scm_array_handle_release (scm_t_array_handle *h) -{ - /* Nothing to do here until arrays need to be reserved for real. - */ -} - -size_t -scm_array_handle_rank (scm_t_array_handle *h) -{ - if (SCM_I_ARRAYP (h->array) || SCM_I_ENCLOSED_ARRAYP (h->array)) - return SCM_I_ARRAY_NDIM (h->array); - else - return 1; -} - -scm_t_array_dim * -scm_array_handle_dims (scm_t_array_handle *h) -{ - return h->dims; -} - -const SCM * -scm_array_handle_elements (scm_t_array_handle *h) -{ - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (SCM_I_IS_VECTOR (vec)) - return SCM_I_VECTOR_ELTS (vec) + h->base; - scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); -} - -SCM * -scm_array_handle_writable_elements (scm_t_array_handle *h) -{ - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (SCM_I_IS_VECTOR (vec)) - return SCM_I_VECTOR_WELTS (vec) + h->base; - scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); -} - -#if SCM_ENABLE_DEPRECATED - -SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, - (SCM obj, SCM prot), - "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" - "not.") -#define FUNC_NAME s_scm_array_p -{ - if (!SCM_UNBNDP (prot)) - { - scm_c_issue_deprecation_warning - ("Using prototypes with `array?' is deprecated." - " Use `typed-array?' instead."); - - return scm_typed_array_p (obj, prototype_to_type (prot)); - } - else - return scm_from_bool (scm_is_array (obj)); -} -#undef FUNC_NAME - -#else /* !SCM_ENABLE_DEPRECATED */ - -/* We keep the old 2-argument C prototype for a while although the old - PROT argument is always ignored now. C code should probably use - scm_is_array or scm_is_typed_array anyway. -*/ - -static SCM scm_i_array_p (SCM obj); - -SCM_DEFINE (scm_i_array_p, "array?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" - "not.") -#define FUNC_NAME s_scm_i_array_p -{ - return scm_from_bool (scm_is_array (obj)); -} -#undef FUNC_NAME - -SCM -scm_array_p (SCM obj, SCM prot) -{ - return scm_from_bool (scm_is_array (obj)); -} - -#endif /* !SCM_ENABLE_DEPRECATED */ - - -SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0, - (SCM obj, SCM type), - "Return @code{#t} if the @var{obj} is an array of type\n" - "@var{type}, and @code{#f} if not.") -#define FUNC_NAME s_scm_typed_array_p -{ - return scm_from_bool (scm_is_typed_array (obj, type)); -} -#undef FUNC_NAME - -size_t -scm_c_array_rank (SCM array) -{ - scm_t_array_handle handle; - size_t res; - - scm_array_get_handle (array, &handle); - res = scm_array_handle_rank (&handle); - scm_array_handle_release (&handle); - return res; -} - -SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, - (SCM array), - "Return the number of dimensions of the array @var{array.}\n") -#define FUNC_NAME s_scm_array_rank -{ - return scm_from_size_t (scm_c_array_rank (array)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, - (SCM ra), - "@code{array-dimensions} is similar to @code{array-shape} but replaces\n" - "elements with a @code{0} minimum with one greater than the maximum. So:\n" - "@lisp\n" - "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n" - "@end lisp") -#define FUNC_NAME s_scm_array_dimensions -{ - scm_t_array_handle handle; - scm_t_array_dim *s; - SCM res = SCM_EOL; - size_t k; - - scm_array_get_handle (ra, &handle); - s = scm_array_handle_dims (&handle); - k = scm_array_handle_rank (&handle); - - while (k--) - res = scm_cons (s[k].lbnd - ? scm_cons2 (scm_from_ssize_t (s[k].lbnd), - scm_from_ssize_t (s[k].ubnd), - SCM_EOL) - : scm_from_ssize_t (1 + s[k].ubnd), - res); - - scm_array_handle_release (&handle); - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, - (SCM ra), - "Return the root vector of a shared array.") -#define FUNC_NAME s_scm_shared_array_root -{ - if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra)) - return SCM_I_ARRAY_V (ra); - else if (scm_is_generalized_vector (ra)) - return ra; - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, - (SCM ra), - "Return the root vector index of the first element in the array.") -#define FUNC_NAME s_scm_shared_array_offset -{ - scm_t_array_handle handle; - SCM res; - - scm_array_get_handle (ra, &handle); - res = scm_from_size_t (handle.base); - scm_array_handle_release (&handle); - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, - (SCM ra), - "For each dimension, return the distance between elements in the root vector.") -#define FUNC_NAME s_scm_shared_array_increments -{ - scm_t_array_handle handle; - SCM res = SCM_EOL; - size_t k; - scm_t_array_dim *s; - - scm_array_get_handle (ra, &handle); - k = scm_array_handle_rank (&handle); - s = scm_array_handle_dims (&handle); - while (k--) - res = scm_cons (scm_from_ssize_t (s[k].inc), res); - scm_array_handle_release (&handle); - return res; -} -#undef FUNC_NAME - -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; -} - -SCM -scm_i_make_ra (int ndim, int enclosed) -{ - scm_t_bits tag = enclosed? scm_i_tc16_enclosed_array : scm_i_tc16_array; - SCM ra; - SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + tag, - scm_gc_malloc ((sizeof (scm_i_t_array) + - ndim * sizeof (scm_t_array_dim)), - "array")); - SCM_I_ARRAY_V (ra) = SCM_BOOL_F; - return ra; -} - -static char s_bad_spec[] = "Bad scm_array dimension"; - - -/* Increments will still need to be set. */ - -static SCM -scm_i_shap2ra (SCM args) -{ - scm_t_array_dim *s; - SCM ra, spec, sp; - int ndim = scm_ilength (args); - if (ndim < 0) - scm_misc_error (NULL, s_bad_spec, SCM_EOL); - - ra = scm_i_make_ra (ndim, 0); - SCM_I_ARRAY_BASE (ra) = 0; - s = SCM_I_ARRAY_DIMS (ra); - for (; !scm_is_null (args); s++, args = SCM_CDR (args)) - { - spec = SCM_CAR (args); - if (scm_is_integer (spec)) - { - if (scm_to_long (spec) < 0) - scm_misc_error (NULL, s_bad_spec, SCM_EOL); - s->lbnd = 0; - s->ubnd = scm_to_long (spec) - 1; - s->inc = 1; - } - else - { - if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec))) - scm_misc_error (NULL, s_bad_spec, SCM_EOL); - s->lbnd = scm_to_long (SCM_CAR (spec)); - sp = SCM_CDR (spec); - if (!scm_is_pair (sp) - || !scm_is_integer (SCM_CAR (sp)) - || !scm_is_null (SCM_CDR (sp))) - scm_misc_error (NULL, s_bad_spec, SCM_EOL); - s->ubnd = scm_to_long (SCM_CAR (sp)); - s->inc = 1; - } - } - return ra; -} - -SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1, - (SCM type, SCM fill, SCM bounds), - "Create and return an array of type @var{type}.") -#define FUNC_NAME s_scm_make_typed_array -{ - size_t k, rlen = 1; - scm_t_array_dim *s; - creator_proc *creator; - SCM ra; - - creator = type_to_creator (type); - ra = scm_i_shap2ra (bounds); - SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); - s = SCM_I_ARRAY_DIMS (ra); - k = SCM_I_ARRAY_NDIM (ra); - - while (k--) - { - s[k].inc = rlen; - SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); - rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; - } - - if (scm_is_eq (fill, SCM_UNSPECIFIED)) - fill = SCM_UNDEFINED; - - SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), fill); - - if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) - if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) - return SCM_I_ARRAY_V (ra); - return ra; -} -#undef FUNC_NAME - -SCM -scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, - size_t byte_len) -#define FUNC_NAME "scm_from_contiguous_typed_array" -{ - size_t k, rlen = 1; - scm_t_array_dim *s; - creator_proc *creator; - SCM ra; - scm_t_array_handle h; - void *base; - size_t sz; - - creator = type_to_creator (type); - ra = scm_i_shap2ra (bounds); - SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); - s = SCM_I_ARRAY_DIMS (ra); - k = SCM_I_ARRAY_NDIM (ra); - - while (k--) - { - s[k].inc = rlen; - SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); - rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; - } - SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), SCM_UNDEFINED); - - - scm_array_get_handle (ra, &h); - base = scm_array_handle_uniform_writable_elements (&h); - sz = scm_array_handle_uniform_element_size (&h); - scm_array_handle_release (&h); - - if (byte_len % sz) - SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL); - if (byte_len / sz != rlen) - SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL); - - memcpy (base, bytes, byte_len); - - if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) - if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) - return SCM_I_ARRAY_V (ra); - return ra; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1, - (SCM fill, SCM bounds), - "Create and return an array.") -#define FUNC_NAME s_scm_make_array -{ - return scm_make_typed_array (SCM_BOOL_T, fill, bounds); -} -#undef FUNC_NAME - -#if SCM_ENABLE_DEPRECATED - -SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0, - (SCM dims, SCM prot, SCM fill), - "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n" - "Create and return a uniform array or vector of type\n" - "corresponding to @var{prototype} with dimensions @var{dims} or\n" - "length @var{length}. If @var{fill} is supplied, it's used to\n" - "fill the array, otherwise @var{prototype} is used.") -#define FUNC_NAME s_scm_dimensions_to_uniform_array -{ - scm_c_issue_deprecation_warning - ("`dimensions->uniform-array' is deprecated. " - "Use `make-typed-array' instead."); - - if (scm_is_integer (dims)) - dims = scm_list_1 (dims); - - if (SCM_UNBNDP (fill)) - { - /* Using #\nul as the prototype yields a s8 array, but numeric - arrays can't store characters, so we have to special case this. - */ - if (scm_is_eq (prot, SCM_MAKE_CHAR (0))) - fill = scm_from_int (0); - else - fill = prot; - } - - return scm_make_typed_array (prototype_to_type (prot), fill, dims); -} -#undef FUNC_NAME - -#endif - -static void -scm_i_ra_set_contp (SCM ra) -{ - size_t k = SCM_I_ARRAY_NDIM (ra); - if (k) - { - long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc; - while (k--) - { - if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc) - { - SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra); - return; - } - inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd - - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1); - } - } - SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); -} - - -SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, - (SCM oldra, SCM mapfunc, SCM dims), - "@code{make-shared-array} can be used to create shared subarrays of other\n" - "arrays. The @var{mapper} is a function that translates coordinates in\n" - "the new array into coordinates in the old array. A @var{mapper} must be\n" - "linear, and its range must stay within the bounds of the old array, but\n" - "it can be otherwise arbitrary. A simple example:\n" - "@lisp\n" - "(define fred (make-array #f 8 8))\n" - "(define freds-diagonal\n" - " (make-shared-array fred (lambda (i) (list i i)) 8))\n" - "(array-set! freds-diagonal 'foo 3)\n" - "(array-ref fred 3 3) @result{} foo\n" - "(define freds-center\n" - " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n" - "(array-ref freds-center 0 0) @result{} foo\n" - "@end lisp") -#define FUNC_NAME s_scm_make_shared_array -{ - scm_t_array_handle old_handle; - SCM ra; - SCM inds, indptr; - SCM imap; - size_t k; - ssize_t i; - long old_base, old_min, new_min, old_max, new_max; - scm_t_array_dim *s; - - SCM_VALIDATE_REST_ARGUMENT (dims); - SCM_VALIDATE_PROC (2, mapfunc); - ra = scm_i_shap2ra (dims); - - scm_array_get_handle (oldra, &old_handle); - - if (SCM_I_ARRAYP (oldra)) - { - SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra); - old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra); - s = scm_array_handle_dims (&old_handle); - k = scm_array_handle_rank (&old_handle); - while (k--) - { - if (s[k].inc > 0) - old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; - else - old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; - } - } - else - { - SCM_I_ARRAY_V (ra) = oldra; - old_base = old_min = 0; - old_max = scm_c_generalized_vector_length (oldra) - 1; - } - - inds = SCM_EOL; - s = SCM_I_ARRAY_DIMS (ra); - for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) - { - inds = scm_cons (scm_from_long (s[k].lbnd), inds); - if (s[k].ubnd < s[k].lbnd) - { - if (1 == SCM_I_ARRAY_NDIM (ra)) - ra = make_typed_vector (scm_array_type (ra), 0); - else - SCM_I_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0); - scm_array_handle_release (&old_handle); - return ra; - } - } - - imap = scm_apply_0 (mapfunc, scm_reverse (inds)); - i = scm_array_handle_pos (&old_handle, imap); - SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base; - indptr = inds; - k = SCM_I_ARRAY_NDIM (ra); - while (k--) - { - if (s[k].ubnd > s[k].lbnd) - { - SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1))); - imap = scm_apply_0 (mapfunc, scm_reverse (inds)); - s[k].inc = scm_array_handle_pos (&old_handle, imap) - i; - i += s[k].inc; - if (s[k].inc > 0) - new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; - else - new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; - } - else - s[k].inc = new_max - new_min + 1; /* contiguous by default */ - indptr = SCM_CDR (indptr); - } - - scm_array_handle_release (&old_handle); - - if (old_min > new_min || old_max < new_max) - SCM_MISC_ERROR ("mapping out of range", SCM_EOL); - if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) - { - SCM v = SCM_I_ARRAY_V (ra); - size_t length = scm_c_generalized_vector_length (v); - if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) - return v; - if (s->ubnd < s->lbnd) - return make_typed_vector (scm_array_type (ra), 0); - } - scm_i_ra_set_contp (ra); - return ra; -} -#undef FUNC_NAME - - -/* args are RA . DIMS */ -SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, - (SCM ra, SCM args), - "Return an array sharing contents with @var{array}, but with\n" - "dimensions arranged in a different order. There must be one\n" - "@var{dim} argument for each dimension of @var{array}.\n" - "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n" - "and the rank of the array to be returned. Each integer in that\n" - "range must appear at least once in the argument list.\n" - "\n" - "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n" - "dimensions in the array to be returned, their positions in the\n" - "argument list to dimensions of @var{array}. Several @var{dim}s\n" - "may have the same value, in which case the returned array will\n" - "have smaller rank than @var{array}.\n" - "\n" - "@lisp\n" - "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n" - "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n" - "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n" - " #2((a 4) (b 5) (c 6))\n" - "@end lisp") -#define FUNC_NAME s_scm_transpose_array -{ - SCM res, vargs; - scm_t_array_dim *s, *r; - int ndim, i, k; - - SCM_VALIDATE_REST_ARGUMENT (args); - SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); - - if (scm_is_generalized_vector (ra)) - { - /* Make sure that we are called with a single zero as - arguments. - */ - if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) - SCM_WRONG_NUM_ARGS (); - SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i); - SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0); - return ra; - } - - if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra)) - { - vargs = scm_vector (args); - if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra)) - SCM_WRONG_NUM_ARGS (); - ndim = 0; - for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) - { - i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k), - 0, SCM_I_ARRAY_NDIM(ra)); - if (ndim < i) - ndim = i; - } - ndim++; - res = scm_i_make_ra (ndim, 0); - SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra); - SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra); - for (k = ndim; k--;) - { - SCM_I_ARRAY_DIMS (res)[k].lbnd = 0; - SCM_I_ARRAY_DIMS (res)[k].ubnd = -1; - } - for (k = SCM_I_ARRAY_NDIM (ra); k--;) - { - i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k)); - s = &(SCM_I_ARRAY_DIMS (ra)[k]); - r = &(SCM_I_ARRAY_DIMS (res)[i]); - if (r->ubnd < r->lbnd) - { - r->lbnd = s->lbnd; - r->ubnd = s->ubnd; - r->inc = s->inc; - ndim--; - } - else - { - if (r->ubnd > s->ubnd) - r->ubnd = s->ubnd; - if (r->lbnd < s->lbnd) - { - SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc; - r->lbnd = s->lbnd; - } - r->inc += s->inc; - } - } - if (ndim > 0) - SCM_MISC_ERROR ("bad argument list", SCM_EOL); - scm_i_ra_set_contp (res); - return res; - } - - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); -} -#undef FUNC_NAME - -/* args are RA . AXES */ -SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, - (SCM ra, SCM axes), - "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n" - "the rank of @var{array}. @var{enclose-array} returns an array\n" - "resembling an array of shared arrays. The dimensions of each shared\n" - "array are the same as the @var{dim}th dimensions of the original array,\n" - "the dimensions of the outer array are the same as those of the original\n" - "array that did not match a @var{dim}.\n\n" - "An enclosed array is not a general Scheme array. Its elements may not\n" - "be set using @code{array-set!}. Two references to the same element of\n" - "an enclosed array will be @code{equal?} but will not in general be\n" - "@code{eq?}. The value returned by @var{array-prototype} when given an\n" - "enclosed array is unspecified.\n\n" - "examples:\n" - "@lisp\n" - "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n" - " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n" - "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n" - " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n" - "@end lisp") -#define FUNC_NAME s_scm_enclose_array -{ - SCM axv, res, ra_inr; - const char *c_axv; - scm_t_array_dim vdim, *s = &vdim; - int ndim, j, k, ninr, noutr; - - SCM_VALIDATE_REST_ARGUMENT (axes); - if (scm_is_null (axes)) - axes = scm_cons ((SCM_I_ARRAYP (ra) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); - ninr = scm_ilength (axes); - if (ninr < 0) - SCM_WRONG_NUM_ARGS (); - ra_inr = scm_i_make_ra (ninr, 0); - - if (scm_is_generalized_vector (ra)) - { - s->lbnd = 0; - s->ubnd = scm_c_generalized_vector_length (ra) - 1; - s->inc = 1; - SCM_I_ARRAY_V (ra_inr) = ra; - SCM_I_ARRAY_BASE (ra_inr) = 0; - ndim = 1; - } - else if (SCM_I_ARRAYP (ra)) - { - s = SCM_I_ARRAY_DIMS (ra); - SCM_I_ARRAY_V (ra_inr) = SCM_I_ARRAY_V (ra); - SCM_I_ARRAY_BASE (ra_inr) = SCM_I_ARRAY_BASE (ra); - ndim = SCM_I_ARRAY_NDIM (ra); - } - else - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); - - noutr = ndim - ninr; - if (noutr < 0) - SCM_WRONG_NUM_ARGS (); - axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0)); - res = scm_i_make_ra (noutr, 1); - SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra_inr); - SCM_I_ARRAY_V (res) = ra_inr; - for (k = 0; k < ninr; k++, axes = SCM_CDR (axes)) - { - if (!scm_is_integer (SCM_CAR (axes))) - SCM_MISC_ERROR ("bad axis", SCM_EOL); - j = scm_to_int (SCM_CAR (axes)); - SCM_I_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd; - SCM_I_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd; - SCM_I_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc; - scm_c_string_set_x (axv, j, SCM_MAKE_CHAR (1)); - } - c_axv = scm_i_string_chars (axv); - for (j = 0, k = 0; k < noutr; k++, j++) - { - while (c_axv[j]) - j++; - SCM_I_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd; - SCM_I_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd; - SCM_I_ARRAY_DIMS (res)[k].inc = s[j].inc; - } - scm_remember_upto_here_1 (axv); - scm_i_ra_set_contp (ra_inr); - scm_i_ra_set_contp (res); - return res; -} -#undef FUNC_NAME - - - -SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, - (SCM v, SCM args), - "Return @code{#t} if its arguments would be acceptable to\n" - "@code{array-ref}.") -#define FUNC_NAME s_scm_array_in_bounds_p -{ - SCM res = SCM_BOOL_T; - - SCM_VALIDATE_REST_ARGUMENT (args); - - if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v)) - { - size_t k, ndim = SCM_I_ARRAY_NDIM (v); - scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v); - - for (k = 0; k < ndim; k++) - { - long ind; - - if (!scm_is_pair (args)) - SCM_WRONG_NUM_ARGS (); - ind = scm_to_long (SCM_CAR (args)); - args = SCM_CDR (args); - - if (ind < s[k].lbnd || ind > s[k].ubnd) - { - res = SCM_BOOL_F; - /* We do not stop the checking after finding a violation - since we want to validate the type-correctness and - number of arguments in any case. - */ - } - } - } - else if (scm_is_generalized_vector (v)) - { - /* Since real arrays have been covered above, all generalized - vectors are guaranteed to be zero-origin here. - */ - - long ind; - - if (!scm_is_pair (args)) - SCM_WRONG_NUM_ARGS (); - ind = scm_to_long (SCM_CAR (args)); - args = SCM_CDR (args); - res = scm_from_bool (ind >= 0 - && ind < scm_c_generalized_vector_length (v)); - } - else - scm_wrong_type_arg_msg (NULL, 0, v, "array"); - - if (!scm_is_null (args)) - SCM_WRONG_NUM_ARGS (); - - return res; -} -#undef FUNC_NAME - -SCM -scm_i_cvref (SCM v, size_t pos, int enclosed) -{ - if (enclosed) - { - int k = SCM_I_ARRAY_NDIM (v); - SCM res = scm_i_make_ra (k, 0); - SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (v); - SCM_I_ARRAY_BASE (res) = pos; - while (k--) - { - SCM_I_ARRAY_DIMS (res)[k].ubnd = SCM_I_ARRAY_DIMS (v)[k].ubnd; - SCM_I_ARRAY_DIMS (res)[k].lbnd = SCM_I_ARRAY_DIMS (v)[k].lbnd; - SCM_I_ARRAY_DIMS (res)[k].inc = SCM_I_ARRAY_DIMS (v)[k].inc; - } - return res; - } - else - return scm_c_generalized_vector_ref (v, pos); -} - -SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, - (SCM v, SCM args), - "Return the element at the @code{(index1, index2)} element in\n" - "@var{array}.") -#define FUNC_NAME s_scm_array_ref -{ - scm_t_array_handle handle; - SCM res; - - scm_array_get_handle (v, &handle); - res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args)); - scm_array_handle_release (&handle); - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, - (SCM v, SCM obj, SCM args), - "Set the element at the @code{(index1, index2)} element in @var{array} to\n" - "@var{new-value}. The value returned by array-set! is unspecified.") -#define FUNC_NAME s_scm_array_set_x -{ - scm_t_array_handle handle; - - scm_array_get_handle (v, &handle); - scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj); - scm_array_handle_release (&handle); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -/* attempts to unroll an array into a one-dimensional array. - returns the unrolled array or #f if it can't be done. */ - /* if strict is not SCM_UNDEFINED, return #f if returned array - wouldn't have contiguous elements. */ -SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, - (SCM ra, SCM strict), - "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n" - "without changing their order (last subscript changing fastest), then\n" - "@code{array-contents} returns that shared array, otherwise it returns\n" - "@code{#f}. All arrays made by @var{make-array} and\n" - "@var{make-uniform-array} may be unrolled, some arrays made by\n" - "@var{make-shared-array} may not be.\n\n" - "If the optional argument @var{strict} is provided, a shared array will\n" - "be returned only if its elements are stored internally contiguous in\n" - "memory.") -#define FUNC_NAME s_scm_array_contents -{ - SCM sra; - - if (scm_is_generalized_vector (ra)) - return ra; - - if (SCM_I_ARRAYP (ra)) - { - size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1; - if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra)) - return SCM_BOOL_F; - for (k = 0; k < ndim; k++) - len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; - if (!SCM_UNBNDP (strict)) - { - if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc)) - return SCM_BOOL_F; - if (scm_is_bitvector (SCM_I_ARRAY_V (ra))) - { - if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) || - SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT || - len % SCM_LONG_BIT) - return SCM_BOOL_F; - } - } - - { - SCM v = SCM_I_ARRAY_V (ra); - size_t length = scm_c_generalized_vector_length (v); - if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc) - return v; - } - - sra = scm_i_make_ra (1, 0); - SCM_I_ARRAY_DIMS (sra)->lbnd = 0; - SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1; - SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra); - SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra); - SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1); - return sra; - } - else if (SCM_I_ENCLOSED_ARRAYP (ra)) - scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array"); - else - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); -} -#undef FUNC_NAME - - -SCM -scm_ra2contig (SCM ra, int copy) -{ - SCM ret; - long inc = 1; - size_t k, len = 1; - for (k = SCM_I_ARRAY_NDIM (ra); k--;) - len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; - k = SCM_I_ARRAY_NDIM (ra); - if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc))) - { - if (!scm_is_bitvector (SCM_I_ARRAY_V (ra))) - return ra; - if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) && - 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT && - 0 == len % SCM_LONG_BIT)) - return ra; - } - ret = scm_i_make_ra (k, 0); - SCM_I_ARRAY_BASE (ret) = 0; - while (k--) - { - SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd; - SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd; - SCM_I_ARRAY_DIMS (ret)[k].inc = inc; - inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; - } - SCM_I_ARRAY_V (ret) = make_typed_vector (scm_array_type (ra), inc); - if (copy) - scm_array_copy_x (ra, ret); - return ret; -} - - - -SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, - (SCM ura, SCM port_or_fd, SCM start, SCM end), - "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n" - "Attempt to read all elements of @var{ura}, in lexicographic order, as\n" - "binary objects from @var{port-or-fdes}.\n" - "If an end of file is encountered,\n" - "the objects up to that point are put into @var{ura}\n" - "(starting at the beginning) and the remainder of the array is\n" - "unchanged.\n\n" - "The optional arguments @var{start} and @var{end} allow\n" - "a specified region of a vector (or linearized array) to be read,\n" - "leaving the remainder of the vector unchanged.\n\n" - "@code{uniform-array-read!} returns the number of objects read.\n" - "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n" - "returned by @code{(current-input-port)}.") -#define FUNC_NAME s_scm_uniform_array_read_x -{ - if (SCM_UNBNDP (port_or_fd)) - port_or_fd = scm_current_input_port (); - - if (scm_is_uniform_vector (ura)) - { - return scm_uniform_vector_read_x (ura, port_or_fd, start, end); - } - else if (SCM_I_ARRAYP (ura)) - { - size_t base, vlen, cstart, cend; - SCM cra, ans; - - cra = scm_ra2contig (ura, 0); - base = SCM_I_ARRAY_BASE (cra); - vlen = SCM_I_ARRAY_DIMS (cra)->inc * - (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1); - - cstart = 0; - cend = vlen; - if (!SCM_UNBNDP (start)) - { - cstart = scm_to_unsigned_integer (start, 0, vlen); - if (!SCM_UNBNDP (end)) - cend = scm_to_unsigned_integer (end, cstart, vlen); - } - - ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd, - scm_from_size_t (base + cstart), - scm_from_size_t (base + cend)); - - if (!scm_is_eq (cra, ura)) - scm_array_copy_x (cra, ura); - return ans; - } - else if (SCM_I_ENCLOSED_ARRAYP (ura)) - scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array"); - else - scm_wrong_type_arg_msg (NULL, 0, ura, "array"); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, - (SCM ura, SCM port_or_fd, SCM start, SCM end), - "Writes all elements of @var{ura} as binary objects to\n" - "@var{port-or-fdes}.\n\n" - "The optional arguments @var{start}\n" - "and @var{end} allow\n" - "a specified region of a vector (or linearized array) to be written.\n\n" - "The number of objects actually written is returned.\n" - "@var{port-or-fdes} may be\n" - "omitted, in which case it defaults to the value returned by\n" - "@code{(current-output-port)}.") -#define FUNC_NAME s_scm_uniform_array_write -{ - if (SCM_UNBNDP (port_or_fd)) - port_or_fd = scm_current_output_port (); - - if (scm_is_uniform_vector (ura)) - { - return scm_uniform_vector_write (ura, port_or_fd, start, end); - } - else if (SCM_I_ARRAYP (ura)) - { - size_t base, vlen, cstart, cend; - SCM cra, ans; - - cra = scm_ra2contig (ura, 1); - base = SCM_I_ARRAY_BASE (cra); - vlen = SCM_I_ARRAY_DIMS (cra)->inc * - (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1); - - cstart = 0; - cend = vlen; - if (!SCM_UNBNDP (start)) - { - cstart = scm_to_unsigned_integer (start, 0, vlen); - if (!SCM_UNBNDP (end)) - cend = scm_to_unsigned_integer (end, cstart, vlen); - } - - ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd, - scm_from_size_t (base + cstart), - scm_from_size_t (base + cend)); - - return ans; - } - else if (SCM_I_ENCLOSED_ARRAYP (ura)) - scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array"); - else - scm_wrong_type_arg_msg (NULL, 0, ura, "array"); -} -#undef FUNC_NAME - - -/** Bit vectors */ - -static scm_t_bits scm_tc16_bitvector; - -#define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj)) -#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj)) -#define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj)) - -static size_t -bitvector_free (SCM vec) -{ - scm_gc_free (BITVECTOR_BITS (vec), - sizeof (scm_t_uint32) * ((BITVECTOR_LENGTH (vec)+31)/32), - "bitvector"); - return 0; -} - -static int -bitvector_print (SCM vec, SCM port, scm_print_state *pstate) -{ - size_t bit_len = BITVECTOR_LENGTH (vec); - size_t word_len = (bit_len+31)/32; - scm_t_uint32 *bits = BITVECTOR_BITS (vec); - size_t i, j; - - scm_puts ("#*", port); - for (i = 0; i < word_len; i++, bit_len -= 32) - { - scm_t_uint32 mask = 1; - for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1) - scm_putc ((bits[i] & mask)? '1' : '0', port); - } - - return 1; -} - -static SCM -bitvector_equalp (SCM vec1, SCM vec2) -{ - size_t bit_len = BITVECTOR_LENGTH (vec1); - size_t word_len = (bit_len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - bit_len); - scm_t_uint32 *bits1 = BITVECTOR_BITS (vec1); - scm_t_uint32 *bits2 = BITVECTOR_BITS (vec2); - - /* compare lengths */ - if (BITVECTOR_LENGTH (vec2) != bit_len) - return SCM_BOOL_F; - /* avoid underflow in word_len-1 below. */ - if (bit_len == 0) - return SCM_BOOL_T; - /* compare full words */ - if (memcmp (bits1, bits2, sizeof (scm_t_uint32) * (word_len-1))) - return SCM_BOOL_F; - /* compare partial last words */ - if ((bits1[word_len-1] & last_mask) != (bits2[word_len-1] & last_mask)) - return SCM_BOOL_F; - return SCM_BOOL_T; -} - -int -scm_is_bitvector (SCM vec) -{ - return IS_BITVECTOR (vec); -} - -SCM_DEFINE (scm_bitvector_p, "bitvector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} when @var{obj} is a bitvector, else\n" - "return @code{#f}.") -#define FUNC_NAME s_scm_bitvector_p -{ - return scm_from_bool (scm_is_bitvector (obj)); -} -#undef FUNC_NAME - -SCM -scm_c_make_bitvector (size_t len, SCM fill) -{ - size_t word_len = (len + 31) / 32; - scm_t_uint32 *bits; - SCM res; - - bits = scm_gc_malloc (sizeof (scm_t_uint32) * word_len, - "bitvector"); - SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len); - - if (!SCM_UNBNDP (fill)) - scm_bitvector_fill_x (res, fill); - - return res; -} - -SCM_DEFINE (scm_make_bitvector, "make-bitvector", 1, 1, 0, - (SCM len, SCM fill), - "Create a new bitvector of length @var{len} and\n" - "optionally initialize all elements to @var{fill}.") -#define FUNC_NAME s_scm_make_bitvector -{ - return scm_c_make_bitvector (scm_to_size_t (len), fill); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1, - (SCM bits), - "Create a new bitvector with the arguments as elements.") -#define FUNC_NAME s_scm_bitvector -{ - return scm_list_to_bitvector (bits); -} -#undef FUNC_NAME - -size_t -scm_c_bitvector_length (SCM vec) -{ - scm_assert_smob_type (scm_tc16_bitvector, vec); - return BITVECTOR_LENGTH (vec); -} - -SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0, - (SCM vec), - "Return the length of the bitvector @var{vec}.") -#define FUNC_NAME s_scm_bitvector_length -{ - return scm_from_size_t (scm_c_bitvector_length (vec)); -} -#undef FUNC_NAME - -const scm_t_uint32 * -scm_array_handle_bit_elements (scm_t_array_handle *h) -{ - return scm_array_handle_bit_writable_elements (h); -} - -scm_t_uint32 * -scm_array_handle_bit_writable_elements (scm_t_array_handle *h) -{ - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (IS_BITVECTOR (vec)) - return BITVECTOR_BITS (vec) + h->base/32; - scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array"); -} - -size_t -scm_array_handle_bit_elements_offset (scm_t_array_handle *h) -{ - return h->base % 32; -} - -const scm_t_uint32 * -scm_bitvector_elements (SCM vec, - scm_t_array_handle *h, - size_t *offp, - size_t *lenp, - ssize_t *incp) -{ - return scm_bitvector_writable_elements (vec, h, offp, lenp, incp); -} - - -scm_t_uint32 * -scm_bitvector_writable_elements (SCM vec, - scm_t_array_handle *h, - size_t *offp, - size_t *lenp, - ssize_t *incp) -{ - scm_generalized_vector_get_handle (vec, h); - if (offp) - { - scm_t_array_dim *dim = scm_array_handle_dims (h); - *offp = scm_array_handle_bit_elements_offset (h); - *lenp = dim->ubnd - dim->lbnd + 1; - *incp = dim->inc; - } - return scm_array_handle_bit_writable_elements (h); -} - -SCM -scm_c_bitvector_ref (SCM vec, size_t idx) -{ - scm_t_array_handle handle; - const scm_t_uint32 *bits; - - if (IS_BITVECTOR (vec)) - { - if (idx >= BITVECTOR_LENGTH (vec)) - scm_out_of_range (NULL, scm_from_size_t (idx)); - bits = BITVECTOR_BITS(vec); - return scm_from_bool (bits[idx/32] & (1L << (idx%32))); - } - else - { - SCM res; - size_t len, off; - ssize_t inc; - - bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc); - if (idx >= len) - scm_out_of_range (NULL, scm_from_size_t (idx)); - idx = idx*inc + off; - res = scm_from_bool (bits[idx/32] & (1L << (idx%32))); - scm_array_handle_release (&handle); - return res; - } -} - -SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0, - (SCM vec, SCM idx), - "Return the element at index @var{idx} of the bitvector\n" - "@var{vec}.") -#define FUNC_NAME s_scm_bitvector_ref -{ - return scm_c_bitvector_ref (vec, scm_to_size_t (idx)); -} -#undef FUNC_NAME - -void -scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val) -{ - scm_t_array_handle handle; - scm_t_uint32 *bits, mask; - - if (IS_BITVECTOR (vec)) - { - if (idx >= BITVECTOR_LENGTH (vec)) - scm_out_of_range (NULL, scm_from_size_t (idx)); - bits = BITVECTOR_BITS(vec); - } - else - { - size_t len, off; - ssize_t inc; - - bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc); - if (idx >= len) - scm_out_of_range (NULL, scm_from_size_t (idx)); - idx = idx*inc + off; - } - - mask = 1L << (idx%32); - if (scm_is_true (val)) - bits[idx/32] |= mask; - else - bits[idx/32] &= ~mask; - - if (!IS_BITVECTOR (vec)) - scm_array_handle_release (&handle); -} - -SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0, - (SCM vec, SCM idx, SCM val), - "Set the element at index @var{idx} of the bitvector\n" - "@var{vec} when @var{val} is true, else clear it.") -#define FUNC_NAME s_scm_bitvector_set_x -{ - scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0, - (SCM vec, SCM val), - "Set all elements of the bitvector\n" - "@var{vec} when @var{val} is true, else clear them.") -#define FUNC_NAME s_scm_bitvector_fill_x -{ - scm_t_array_handle handle; - size_t off, len; - ssize_t inc; - scm_t_uint32 *bits; - - bits = scm_bitvector_writable_elements (vec, &handle, - &off, &len, &inc); - - if (off == 0 && inc == 1 && len > 0) - { - /* the usual case - */ - size_t word_len = (len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len); - - if (scm_is_true (val)) - { - memset (bits, 0xFF, sizeof(scm_t_uint32)*(word_len-1)); - bits[word_len-1] |= last_mask; - } - else - { - memset (bits, 0x00, sizeof(scm_t_uint32)*(word_len-1)); - bits[word_len-1] &= ~last_mask; - } - } - else - { - size_t i; - for (i = 0; i < len; i++) - scm_array_handle_set (&handle, i*inc, val); - } - - scm_array_handle_release (&handle); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_list_to_bitvector, "list->bitvector", 1, 0, 0, - (SCM list), - "Return a new bitvector initialized with the elements\n" - "of @var{list}.") -#define FUNC_NAME s_scm_list_to_bitvector -{ - size_t bit_len = scm_to_size_t (scm_length (list)); - SCM vec = scm_c_make_bitvector (bit_len, SCM_UNDEFINED); - size_t word_len = (bit_len+31)/32; - scm_t_array_handle handle; - scm_t_uint32 *bits = scm_bitvector_writable_elements (vec, &handle, - NULL, NULL, NULL); - size_t i, j; - - for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= 32) - { - scm_t_uint32 mask = 1; - bits[i] = 0; - for (j = 0; j < 32 && j < bit_len; - j++, mask <<= 1, list = SCM_CDR (list)) - if (scm_is_true (SCM_CAR (list))) - bits[i] |= mask; - } - - scm_array_handle_release (&handle); - - return vec; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0, - (SCM vec), - "Return a new list initialized with the elements\n" - "of the bitvector @var{vec}.") -#define FUNC_NAME s_scm_bitvector_to_list -{ - scm_t_array_handle handle; - size_t off, len; - ssize_t inc; - scm_t_uint32 *bits; - SCM res = SCM_EOL; - - bits = scm_bitvector_writable_elements (vec, &handle, - &off, &len, &inc); - - if (off == 0 && inc == 1) - { - /* the usual case - */ - size_t word_len = (len + 31) / 32; - size_t i, j; - - for (i = 0; i < word_len; i++, len -= 32) - { - scm_t_uint32 mask = 1; - for (j = 0; j < 32 && j < len; j++, mask <<= 1) - res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res); - } - } - else - { - size_t i; - for (i = 0; i < len; i++) - res = scm_cons (scm_array_handle_ref (&handle, i*inc), res); - } - - scm_array_handle_release (&handle); - - return scm_reverse_x (res, SCM_EOL); -} -#undef FUNC_NAME - -/* From mmix-arith.w by Knuth. - - Here's a fun way to count the number of bits in a tetrabyte. - - [This classical trick is called the ``Gillies--Miller method for - sideways addition'' in {\sl The Preparation of Programs for an - Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second - edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of - the tricks used here were suggested by Balbir Singh, Peter - Rossmanith, and Stefan Schwoon.] -*/ - -static size_t -count_ones (scm_t_uint32 x) -{ - x=x-((x>>1)&0x55555555); - x=(x&0x33333333)+((x>>2)&0x33333333); - x=(x+(x>>4))&0x0f0f0f0f; - x=x+(x>>8); - return (x+(x>>16)) & 0xff; -} - -SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, - (SCM b, SCM bitvector), - "Return the number of occurrences of the boolean @var{b} in\n" - "@var{bitvector}.") -#define FUNC_NAME s_scm_bit_count -{ - scm_t_array_handle handle; - size_t off, len; - ssize_t inc; - scm_t_uint32 *bits; - int bit = scm_to_bool (b); - size_t count = 0; - - bits = scm_bitvector_writable_elements (bitvector, &handle, - &off, &len, &inc); - - if (off == 0 && inc == 1 && len > 0) - { - /* the usual case - */ - size_t word_len = (len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len); - size_t i; - - for (i = 0; i < word_len-1; i++) - count += count_ones (bits[i]); - count += count_ones (bits[i] & last_mask); - } - else - { - size_t i; - for (i = 0; i < len; i++) - if (scm_is_true (scm_array_handle_ref (&handle, i*inc))) - count++; - } - - scm_array_handle_release (&handle); - - return scm_from_size_t (bit? count : len-count); -} -#undef FUNC_NAME - -/* returns 32 for x == 0. -*/ -static size_t -find_first_one (scm_t_uint32 x) -{ - size_t pos = 0; - /* do a binary search in x. */ - if ((x & 0xFFFF) == 0) - x >>= 16, pos += 16; - if ((x & 0xFF) == 0) - x >>= 8, pos += 8; - if ((x & 0xF) == 0) - x >>= 4, pos += 4; - if ((x & 0x3) == 0) - x >>= 2, pos += 2; - if ((x & 0x1) == 0) - pos += 1; - return pos; -} - -SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, - (SCM item, SCM v, SCM k), - "Return the index of the first occurrance of @var{item} in bit\n" - "vector @var{v}, starting from @var{k}. If there is no\n" - "@var{item} entry between @var{k} and the end of\n" - "@var{bitvector}, then return @code{#f}. For example,\n" - "\n" - "@example\n" - "(bit-position #t #*000101 0) @result{} 3\n" - "(bit-position #f #*0001111 3) @result{} #f\n" - "@end example") -#define FUNC_NAME s_scm_bit_position -{ - scm_t_array_handle handle; - size_t off, len, first_bit; - ssize_t inc; - const scm_t_uint32 *bits; - int bit = scm_to_bool (item); - SCM res = SCM_BOOL_F; - - bits = scm_bitvector_elements (v, &handle, &off, &len, &inc); - first_bit = scm_to_unsigned_integer (k, 0, len); - - if (off == 0 && inc == 1 && len > 0) - { - size_t i, word_len = (len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len); - size_t first_word = first_bit / 32; - scm_t_uint32 first_mask = - ((scm_t_uint32)-1) << (first_bit - 32*first_word); - scm_t_uint32 w; - - for (i = first_word; i < word_len; i++) - { - w = (bit? bits[i] : ~bits[i]); - if (i == first_word) - w &= first_mask; - if (i == word_len-1) - w &= last_mask; - if (w) - { - res = scm_from_size_t (32*i + find_first_one (w)); - break; - } - } - } - else - { - size_t i; - for (i = first_bit; i < len; i++) - { - SCM elt = scm_array_handle_ref (&handle, i*inc); - if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt))) - { - res = scm_from_size_t (i); - break; - } - } - } - - scm_array_handle_release (&handle); - - return res; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, - (SCM v, SCM kv, SCM obj), - "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n" - "selecting the entries to change. The return value is\n" - "unspecified.\n" - "\n" - "If @var{kv} is a bit vector, then those entries where it has\n" - "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n" - "@var{kv} and @var{v} must be the same length. When @var{obj}\n" - "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n" - "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n" - "\n" - "@example\n" - "(define bv #*01000010)\n" - "(bit-set*! bv #*10010001 #t)\n" - "bv\n" - "@result{} #*11010011\n" - "@end example\n" - "\n" - "If @var{kv} is a u32vector, then its elements are\n" - "indices into @var{v} which are set to @var{obj}.\n" - "\n" - "@example\n" - "(define bv #*01000010)\n" - "(bit-set*! bv #u32(5 2 7) #t)\n" - "bv\n" - "@result{} #*01100111\n" - "@end example") -#define FUNC_NAME s_scm_bit_set_star_x -{ - scm_t_array_handle v_handle; - size_t v_off, v_len; - ssize_t v_inc; - scm_t_uint32 *v_bits; - int bit; - - /* Validate that OBJ is a boolean so this is done even if we don't - need BIT. - */ - bit = scm_to_bool (obj); - - v_bits = scm_bitvector_writable_elements (v, &v_handle, - &v_off, &v_len, &v_inc); - - if (scm_is_bitvector (kv)) - { - scm_t_array_handle kv_handle; - size_t kv_off, kv_len; - ssize_t kv_inc; - const scm_t_uint32 *kv_bits; - - kv_bits = scm_bitvector_elements (v, &kv_handle, - &kv_off, &kv_len, &kv_inc); - - if (v_len != kv_len) - scm_misc_error (NULL, - "bit vectors must have equal length", - SCM_EOL); - - if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0) - { - size_t word_len = (kv_len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len); - size_t i; - - if (bit == 0) - { - for (i = 0; i < word_len-1; i++) - v_bits[i] &= ~kv_bits[i]; - v_bits[i] &= ~(kv_bits[i] & last_mask); - } - else - { - for (i = 0; i < word_len-1; i++) - v_bits[i] |= kv_bits[i]; - v_bits[i] |= kv_bits[i] & last_mask; - } - } - else - { - size_t i; - for (i = 0; i < kv_len; i++) - if (scm_is_true (scm_array_handle_ref (&kv_handle, i*kv_inc))) - scm_array_handle_set (&v_handle, i*v_inc, obj); - } - - scm_array_handle_release (&kv_handle); - - } - else if (scm_is_true (scm_u32vector_p (kv))) - { - scm_t_array_handle kv_handle; - size_t i, kv_len; - ssize_t kv_inc; - const scm_t_uint32 *kv_elts; - - kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc); - for (i = 0; i < kv_len; i++, kv_elts += kv_inc) - scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj); - - scm_array_handle_release (&kv_handle); - } - else - scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector"); - - scm_array_handle_release (&v_handle); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, - (SCM v, SCM kv, SCM obj), - "Return a count of how many entries in bit vector @var{v} are\n" - "equal to @var{obj}, with @var{kv} selecting the entries to\n" - "consider.\n" - "\n" - "If @var{kv} is a bit vector, then those entries where it has\n" - "@code{#t} are the ones in @var{v} which are considered.\n" - "@var{kv} and @var{v} must be the same length.\n" - "\n" - "If @var{kv} is a u32vector, then it contains\n" - "the indexes in @var{v} to consider.\n" - "\n" - "For example,\n" - "\n" - "@example\n" - "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n" - "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n" - "@end example") -#define FUNC_NAME s_scm_bit_count_star -{ - scm_t_array_handle v_handle; - size_t v_off, v_len; - ssize_t v_inc; - const scm_t_uint32 *v_bits; - size_t count = 0; - int bit; - - /* Validate that OBJ is a boolean so this is done even if we don't - need BIT. - */ - bit = scm_to_bool (obj); - - v_bits = scm_bitvector_elements (v, &v_handle, - &v_off, &v_len, &v_inc); - - if (scm_is_bitvector (kv)) - { - scm_t_array_handle kv_handle; - size_t kv_off, kv_len; - ssize_t kv_inc; - const scm_t_uint32 *kv_bits; - - kv_bits = scm_bitvector_elements (v, &kv_handle, - &kv_off, &kv_len, &kv_inc); - - if (v_len != kv_len) - scm_misc_error (NULL, - "bit vectors must have equal length", - SCM_EOL); - - if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0) - { - size_t i, word_len = (kv_len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len); - scm_t_uint32 xor_mask = bit? 0 : ((scm_t_uint32)-1); - - for (i = 0; i < word_len-1; i++) - count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i]); - count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i] & last_mask); - } - else - { - size_t i; - for (i = 0; i < kv_len; i++) - if (scm_is_true (scm_array_handle_ref (&kv_handle, i))) - { - SCM elt = scm_array_handle_ref (&v_handle, i*v_inc); - if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt))) - count++; - } - } - - scm_array_handle_release (&kv_handle); - - } - else if (scm_is_true (scm_u32vector_p (kv))) - { - scm_t_array_handle kv_handle; - size_t i, kv_len; - ssize_t kv_inc; - const scm_t_uint32 *kv_elts; - - kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc); - for (i = 0; i < kv_len; i++, kv_elts += kv_inc) - { - SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc); - if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt))) - count++; - } - - scm_array_handle_release (&kv_handle); - } - else - scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector"); - - scm_array_handle_release (&v_handle); - - return scm_from_size_t (count); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, - (SCM v), - "Modify the bit vector @var{v} by replacing each element with\n" - "its negation.") -#define FUNC_NAME s_scm_bit_invert_x -{ - scm_t_array_handle handle; - size_t off, len; - ssize_t inc; - scm_t_uint32 *bits; - - bits = scm_bitvector_writable_elements (v, &handle, &off, &len, &inc); - - if (off == 0 && inc == 1 && len > 0) - { - size_t word_len = (len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len); - size_t i; - - for (i = 0; i < word_len-1; i++) - bits[i] = ~bits[i]; - bits[i] = bits[i] ^ last_mask; - } - else - { - size_t i; - for (i = 0; i < len; i++) - scm_array_handle_set (&handle, i*inc, - scm_not (scm_array_handle_ref (&handle, i*inc))); - } - - scm_array_handle_release (&handle); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM -scm_istr2bve (SCM str) -{ - scm_t_array_handle handle; - size_t len = scm_i_string_length (str); - SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED); - SCM res = vec; - - scm_t_uint32 mask; - size_t k, j; - const char *c_str; - scm_t_uint32 *data; - - data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL); - c_str = scm_i_string_chars (str); - - for (k = 0; k < (len + 31) / 32; k++) - { - data[k] = 0L; - j = len - k * 32; - if (j > 32) - j = 32; - for (mask = 1L; j--; mask <<= 1) - switch (*c_str++) - { - case '0': - break; - case '1': - data[k] |= mask; - break; - default: - res = SCM_BOOL_F; - goto exit; - } - } - - exit: - scm_array_handle_release (&handle); - scm_remember_upto_here_1 (str); - return res; -} - - - -static SCM -ra2l (SCM ra, unsigned long base, unsigned long k) -{ - SCM res = SCM_EOL; - long inc; - size_t i; - int enclosed = SCM_I_ENCLOSED_ARRAYP (ra); - - if (k == SCM_I_ARRAY_NDIM (ra)) - return scm_i_cvref (SCM_I_ARRAY_V (ra), base, enclosed); - - inc = SCM_I_ARRAY_DIMS (ra)[k].inc; - if (SCM_I_ARRAY_DIMS (ra)[k].ubnd < SCM_I_ARRAY_DIMS (ra)[k].lbnd) - return SCM_EOL; - i = base + (1 + SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * inc; - do - { - i -= inc; - res = scm_cons (ra2l (ra, i, k + 1), res); - } - while (i != base); - return res; -} - - -SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, - (SCM v), - "Return a list consisting of all the elements, in order, of\n" - "@var{array}.") -#define FUNC_NAME s_scm_array_to_list -{ - if (scm_is_generalized_vector (v)) - return scm_generalized_vector_to_list (v); - else if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v)) - return ra2l (v, SCM_I_ARRAY_BASE (v), 0); - - scm_wrong_type_arg_msg (NULL, 0, v, "array"); -} -#undef FUNC_NAME - - -static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k); - -SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, - (SCM type, SCM shape, SCM lst), - "Return an array of the type @var{type}\n" - "with elements the same as those of @var{lst}.\n" - "\n" - "The argument @var{shape} determines the number of dimensions\n" - "of the array and their shape. It is either an exact integer,\n" - "giving the\n" - "number of dimensions directly, or a list whose length\n" - "specifies the number of dimensions and each element specified\n" - "the lower and optionally the upper bound of the corresponding\n" - "dimension.\n" - "When the element is list of two elements, these elements\n" - "give the lower and upper bounds. When it is an exact\n" - "integer, it gives only the lower bound.") -#define FUNC_NAME s_scm_list_to_typed_array -{ - SCM row; - SCM ra; - scm_t_array_handle handle; - - row = lst; - if (scm_is_integer (shape)) - { - size_t k = scm_to_size_t (shape); - shape = SCM_EOL; - while (k-- > 0) - { - shape = scm_cons (scm_length (row), shape); - if (k > 0 && !scm_is_null (row)) - row = scm_car (row); - } - } - else - { - SCM shape_spec = shape; - shape = SCM_EOL; - while (1) - { - SCM spec = scm_car (shape_spec); - if (scm_is_pair (spec)) - shape = scm_cons (spec, shape); - else - shape = scm_cons (scm_list_2 (spec, - scm_sum (scm_sum (spec, - scm_length (row)), - scm_from_int (-1))), - shape); - shape_spec = scm_cdr (shape_spec); - if (scm_is_pair (shape_spec)) - { - if (!scm_is_null (row)) - row = scm_car (row); - } - else - break; - } - } - - ra = scm_make_typed_array (type, SCM_UNSPECIFIED, - scm_reverse_x (shape, SCM_EOL)); - - scm_array_get_handle (ra, &handle); - l2ra (lst, &handle, 0, 0); - scm_array_handle_release (&handle); - - return ra; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0, - (SCM ndim, SCM lst), - "Return an array with elements the same as those of @var{lst}.") -#define FUNC_NAME s_scm_list_to_array -{ - return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst); -} -#undef FUNC_NAME - -static void -l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k) -{ - if (k == scm_array_handle_rank (handle)) - scm_array_handle_set (handle, pos, lst); - else - { - scm_t_array_dim *dim = scm_array_handle_dims (handle) + k; - ssize_t inc = dim->inc; - size_t len = 1 + dim->ubnd - dim->lbnd, n; - char *errmsg = NULL; - - n = len; - while (n > 0 && scm_is_pair (lst)) - { - l2ra (SCM_CAR (lst), handle, pos, k + 1); - pos += inc; - lst = SCM_CDR (lst); - n -= 1; - } - if (n != 0) - errmsg = "too few elements for array dimension ~a, need ~a"; - if (!scm_is_null (lst)) - errmsg = "too many elements for array dimension ~a, want ~a"; - if (errmsg) - scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k), - scm_from_size_t (len))); - } -} - -#if SCM_ENABLE_DEPRECATED - -SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, - (SCM ndim, SCM prot, SCM lst), - "Return a uniform array of the type indicated by prototype\n" - "@var{prot} with elements the same as those of @var{lst}.\n" - "Elements must be of the appropriate type, no coercions are\n" - "done.\n" - "\n" - "The argument @var{ndim} determines the number of dimensions\n" - "of the array. It is either an exact integer, giving the\n" - "number directly, or a list of exact integers, whose length\n" - "specifies the number of dimensions and each element is the\n" - "lower index bound of its dimension.") -#define FUNC_NAME s_scm_list_to_uniform_array -{ - return scm_list_to_typed_array (prototype_to_type (prot), ndim, lst); -} -#undef FUNC_NAME - -#endif - -/* Print dimension DIM of ARRAY. - */ - -static int -scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed, - SCM port, scm_print_state *pstate) -{ - scm_t_array_dim *dim_spec = SCM_I_ARRAY_DIMS (array) + dim; - long idx; - - scm_putc ('(', port); - - for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++) - { - if (dim < SCM_I_ARRAY_NDIM(array)-1) - scm_i_print_array_dimension (array, dim+1, base, enclosed, - port, pstate); - else - scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array), base, enclosed), - port, pstate); - if (idx < dim_spec->ubnd) - scm_putc (' ', port); - base += dim_spec->inc; - } - - scm_putc (')', port); - return 1; -} - -/* Print an array. (Only for strict arrays, not for generalized vectors.) -*/ - -static int -scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) -{ - long ndim = SCM_I_ARRAY_NDIM (array); - scm_t_array_dim *dim_specs = SCM_I_ARRAY_DIMS (array); - SCM v = SCM_I_ARRAY_V (array); - unsigned long base = SCM_I_ARRAY_BASE (array); - long i; - int print_lbnds = 0, zero_size = 0, print_lens = 0; - - scm_putc ('#', port); - if (ndim != 1 || dim_specs[0].lbnd != 0) - scm_intprint (ndim, 10, port); - if (scm_is_uniform_vector (v)) - scm_puts (scm_i_uniform_vector_tag (v), port); - else if (scm_is_bitvector (v)) - scm_puts ("b", port); - else if (scm_is_string (v)) - scm_puts ("a", port); - else if (!scm_is_vector (v)) - scm_puts ("?", port); - - for (i = 0; i < ndim; i++) - { - if (dim_specs[i].lbnd != 0) - print_lbnds = 1; - if (dim_specs[i].ubnd - dim_specs[i].lbnd + 1 == 0) - zero_size = 1; - else if (zero_size) - print_lens = 1; - } - - if (print_lbnds || print_lens) - for (i = 0; i < ndim; i++) - { - if (print_lbnds) - { - scm_putc ('@', port); - scm_intprint (dim_specs[i].lbnd, 10, port); - } - if (print_lens) - { - scm_putc (':', port); - scm_intprint (dim_specs[i].ubnd - dim_specs[i].lbnd + 1, - 10, port); - } - } - - if (ndim == 0) - { - /* Rank zero arrays, which are really just scalars, are printed - specially. The consequent way would be to print them as - - #0 OBJ - - where OBJ is the printed representation of the scalar, but we - print them instead as - - #0(OBJ) - - to make them look less strange. - - Just printing them as - - OBJ - - would be correct in a way as well, but zero rank arrays are - not really the same as Scheme values since they are boxed and - can be modified with array-set!, say. - */ - scm_putc ('(', port); - scm_iprin1 (scm_i_cvref (v, base, 0), port, pstate); - scm_putc (')', port); - return 1; - } - else - return scm_i_print_array_dimension (array, 0, base, 0, port, pstate); -} - -static int -scm_i_print_enclosed_array (SCM array, SCM port, scm_print_state *pstate) -{ - size_t base; - - scm_putc ('#', port); - base = SCM_I_ARRAY_BASE (array); - scm_puts ("<enclosed-array ", port); - scm_i_print_array_dimension (array, 0, base, 1, port, pstate); - scm_putc ('>', port); - return 1; -} - -/* Read an array. This function can also read vectors and uniform - vectors. Also, the conflict between '#f' and '#f32' and '#f64' is - handled here. - - C is the first character read after the '#'. -*/ - -static SCM -tag_to_type (const char *tag, SCM port) -{ -#if SCM_ENABLE_DEPRECATED - { - /* Recognize the old syntax. - */ - const char *instead; - switch (tag[0]) - { - case 'u': - instead = "u32"; - break; - case 'e': - instead = "s32"; - break; - case 's': - instead = "f32"; - break; - case 'i': - instead = "f64"; - break; - case 'y': - instead = "s8"; - break; - case 'h': - instead = "s16"; - break; - case 'l': - instead = "s64"; - break; - case 'c': - instead = "c64"; - break; - default: - instead = NULL; - break; - } - - if (instead && tag[1] == '\0') - { - scm_c_issue_deprecation_warning_fmt - ("The tag '%c' is deprecated for uniform vectors. " - "Use '%s' instead.", tag[0], instead); - return scm_from_locale_symbol (instead); - } - } -#endif - - if (*tag == '\0') - return SCM_BOOL_T; - else - return scm_from_locale_symbol (tag); -} - -static int -read_decimal_integer (SCM port, int c, ssize_t *resp) -{ - ssize_t sign = 1; - ssize_t res = 0; - int got_it = 0; - - if (c == '-') - { - sign = -1; - c = scm_getc (port); - } - - while ('0' <= c && c <= '9') - { - res = 10*res + c-'0'; - got_it = 1; - c = scm_getc (port); - } - - if (got_it) - *resp = sign * res; - return c; -} - -SCM -scm_i_read_array (SCM port, int c) -{ - ssize_t rank; - int got_rank; - char tag[80]; - int tag_len; - - SCM shape = SCM_BOOL_F, elements; - - /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but - the array code can not deal with zero-length dimensions yet, and - we want to allow zero-length vectors, of course. - */ - if (c == '(') - { - scm_ungetc (c, port); - return scm_vector (scm_read (port)); - } - - /* Disambiguate between '#f' and uniform floating point vectors. - */ - if (c == 'f') - { - c = scm_getc (port); - if (c != '3' && c != '6') - { - if (c != EOF) - scm_ungetc (c, port); - return SCM_BOOL_F; - } - rank = 1; - got_rank = 1; - tag[0] = 'f'; - tag_len = 1; - goto continue_reading_tag; - } - - /* Read rank. - */ - rank = 1; - c = read_decimal_integer (port, c, &rank); - if (rank < 0) - scm_i_input_error (NULL, port, "array rank must be non-negative", - SCM_EOL); - - /* Read tag. - */ - tag_len = 0; - continue_reading_tag: - while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80) - { - tag[tag_len++] = c; - c = scm_getc (port); - } - tag[tag_len] = '\0'; - - /* Read shape. - */ - if (c == '@' || c == ':') - { - shape = SCM_EOL; - - do - { - ssize_t lbnd = 0, len = 0; - SCM s; - - if (c == '@') - { - c = scm_getc (port); - c = read_decimal_integer (port, c, &lbnd); - } - - s = scm_from_ssize_t (lbnd); - - if (c == ':') - { - c = scm_getc (port); - c = read_decimal_integer (port, c, &len); - if (len < 0) - scm_i_input_error (NULL, port, - "array length must be non-negative", - SCM_EOL); - - s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1)); - } - - shape = scm_cons (s, shape); - } while (c == '@' || c == ':'); - - shape = scm_reverse_x (shape, SCM_EOL); - } - - /* Read nested lists of elements. - */ - if (c != '(') - scm_i_input_error (NULL, port, - "missing '(' in vector or array literal", - SCM_EOL); - scm_ungetc (c, port); - elements = scm_read (port); - - if (scm_is_false (shape)) - shape = scm_from_ssize_t (rank); - else if (scm_ilength (shape) != rank) - scm_i_input_error - (NULL, port, - "the number of shape specifications must match the array rank", - SCM_EOL); - - /* Handle special print syntax of rank zero arrays; see - scm_i_print_array for a rationale. - */ - if (rank == 0) - { - if (!scm_is_pair (elements)) - scm_i_input_error (NULL, port, - "too few elements in array literal, need 1", - SCM_EOL); - if (!scm_is_null (SCM_CDR (elements))) - scm_i_input_error (NULL, port, - "too many elements in array literal, want 1", - SCM_EOL); - elements = SCM_CAR (elements); - } - - /* Construct array. - */ - return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements); -} - -SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0, - (SCM ra), - "") -#define FUNC_NAME s_scm_array_type -{ - if (SCM_I_ARRAYP (ra)) - return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra)); - else if (scm_is_generalized_vector (ra)) - return scm_i_generalized_vector_type (ra); - else if (SCM_I_ENCLOSED_ARRAYP (ra)) - scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array"); - else - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); -} -#undef FUNC_NAME - -#if SCM_ENABLE_DEPRECATED - -SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0, - (SCM ra), - "Return an object that would produce an array of the same type\n" - "as @var{array}, if used as the @var{prototype} for\n" - "@code{make-uniform-array}.") -#define FUNC_NAME s_scm_array_prototype -{ - if (SCM_I_ARRAYP (ra)) - return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra)); - else if (scm_is_generalized_vector (ra)) - return scm_i_get_old_prototype (ra); - else if (SCM_I_ENCLOSED_ARRAYP (ra)) - return SCM_UNSPECIFIED; - else - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); -} -#undef FUNC_NAME - -#endif - -static SCM -array_mark (SCM ptr) -{ - return SCM_I_ARRAY_V (ptr); -} - -static size_t -array_free (SCM ptr) -{ - scm_gc_free (SCM_I_ARRAY_MEM (ptr), - (sizeof (scm_i_t_array) - + SCM_I_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)), - "array"); - return 0; -} - -#if SCM_ENABLE_DEPRECATED - -SCM -scm_make_ra (int ndim) -{ - scm_c_issue_deprecation_warning - ("scm_make_ra is deprecated. Use scm_make_array or similar instead."); - return scm_i_make_ra (ndim, 0); -} - -SCM -scm_shap2ra (SCM args, const char *what) -{ - scm_c_issue_deprecation_warning - ("scm_shap2ra is deprecated. Use scm_make_array or similar instead."); - return scm_i_shap2ra (args); -} - -SCM -scm_cvref (SCM v, unsigned long pos, SCM last) -{ - scm_c_issue_deprecation_warning - ("scm_cvref is deprecated. Use scm_c_generalized_vector_ref instead."); - return scm_c_generalized_vector_ref (v, pos); -} - -void -scm_ra_set_contp (SCM ra) -{ - scm_c_issue_deprecation_warning - ("scm_ra_set_contp is deprecated. There should be no need for it."); - scm_i_ra_set_contp (ra); -} - -long -scm_aind (SCM ra, SCM args, const char *what) -{ - scm_t_array_handle handle; - ssize_t pos; - - scm_c_issue_deprecation_warning - ("scm_aind is deprecated. Use scm_array_handle_pos instead."); - - if (scm_is_integer (args)) - args = scm_list_1 (args); - - scm_array_get_handle (ra, &handle); - pos = scm_array_handle_pos (&handle, args) + SCM_I_ARRAY_BASE (ra); - scm_array_handle_release (&handle); - return pos; -} - -int -scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) -{ - scm_c_issue_deprecation_warning - ("scm_raprin1 is deprecated. Use scm_display or scm_write instead."); - - scm_iprin1 (exp, port, pstate); - return 1; -} - -#endif - -void -scm_init_unif () -{ - scm_i_tc16_array = scm_make_smob_type ("array", 0); - scm_set_smob_mark (scm_i_tc16_array, array_mark); - scm_set_smob_free (scm_i_tc16_array, array_free); - scm_set_smob_print (scm_i_tc16_array, scm_i_print_array); - scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p); - - scm_i_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0); - scm_set_smob_mark (scm_i_tc16_enclosed_array, array_mark); - scm_set_smob_free (scm_i_tc16_enclosed_array, array_free); - scm_set_smob_print (scm_i_tc16_enclosed_array, scm_i_print_enclosed_array); - scm_set_smob_equalp (scm_i_tc16_enclosed_array, scm_array_equal_p); - - scm_add_feature ("array"); - - scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0); - scm_set_smob_free (scm_tc16_bitvector, bitvector_free); - scm_set_smob_print (scm_tc16_bitvector, bitvector_print); - scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp); - - init_type_creator_table (); - -#include "libguile/unif.x" - -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ |