-/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
-
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
-
-/*
- 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
-*/
-\f
-
-#include <stdio.h>
-#include <errno.h>
-#include <string.h>
-
-#include "libguile/_scm.h"
-#include "libguile/chars.h"
-#include "libguile/eval.h"
-#include "libguile/fports.h"
-#include "libguile/smob.h"
-#include "libguile/strop.h"
-#include "libguile/feature.h"
-#include "libguile/root.h"
-#include "libguile/strings.h"
-#include "libguile/vectors.h"
-
-#include "libguile/validate.h"
-#include "libguile/unif.h"
-#include "libguile/ramap.h"
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-\f
-/* The set of uniform scm_vector types is:
- * Vector of: Called:
- * unsigned char string
- * char byvect
- * boolean bvect
- * signed long ivect
- * unsigned long uvect
- * float fvect
- * double dvect
- * complex double cvect
- * short svect
- * long long llvect
- */
-
-scm_t_bits scm_tc16_array;
-
-/* return the size of an element in a uniform array or 0 if type not
- found. */
-size_t
-scm_uniform_element_size (SCM obj)
-{
- size_t result;
-
- switch (SCM_TYP7 (obj))
- {
- case scm_tc7_bvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- result = sizeof (long);
- break;
-
- case scm_tc7_byvect:
- result = sizeof (char);
- break;
-
- case scm_tc7_svect:
- result = sizeof (short);
- break;
-
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
- result = sizeof (long long);
- break;
-#endif
-
- case scm_tc7_fvect:
- result = sizeof (float);
- break;
-
- case scm_tc7_dvect:
- result = sizeof (double);
- break;
-
- case scm_tc7_cvect:
- result = 2 * sizeof (double);
- break;
-
- default:
- result = 0;
- }
- return result;
-}
-
-/* Silly function used not to modify the semantics of the silly
- * prototype system in order to be backward compatible.
- */
-static int
-singp (SCM obj)
-{
- if (!SCM_SLOPPY_REALP (obj))
- return 0;
- else
- {
- double x = SCM_REAL_VALUE (obj);
- float fx = x;
- return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x);
- }
-}
-
-SCM
-scm_make_uve (long k, SCM prot)
-#define FUNC_NAME "scm_make_uve"
-{
- SCM v;
- long i, type;
-
- if (SCM_EQ_P (prot, SCM_BOOL_T))
- {
- SCM_NEWCELL (v);
- if (k > 0)
- {
- SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_BITVECTOR_MAX_LENGTH);
- i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
- SCM_SET_BITVECTOR_BASE (v, (char *) scm_must_malloc (i, "vector"));
- SCM_SET_BITVECTOR_LENGTH (v, k);
- }
- else
- {
- SCM_SET_BITVECTOR_BASE (v, 0);
- SCM_SET_BITVECTOR_LENGTH (v, 0);
- }
- return v;
- }
- else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0'))
- {
- i = sizeof (char) * k;
- type = scm_tc7_byvect;
- }
- else if (SCM_CHARP (prot))
- {
- i = sizeof (char) * k;
- return scm_allocate_string (i);
- }
- else if (SCM_INUMP (prot))
- {
- i = sizeof (long) * k;
- if (SCM_INUM (prot) > 0)
- type = scm_tc7_uvect;
- else
- type = scm_tc7_ivect;
- }
- else if (SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot)))
- {
- char s;
-
- s = SCM_SYMBOL_CHARS (prot)[0];
- if (s == 's')
- {
- i = sizeof (short) * k;
- type = scm_tc7_svect;
- }
-#ifdef HAVE_LONG_LONGS
- else if (s == 'l')
- {
- i = sizeof (long long) * k;
- type = scm_tc7_llvect;
- }
-#endif
- else
- {
- return scm_c_make_vector (k, SCM_UNDEFINED);
- }
- }
- else if (!SCM_INEXACTP (prot))
- /* Huge non-unif vectors are NOT supported. */
- /* no special scm_vector */
- return scm_c_make_vector (k, SCM_UNDEFINED);
- else if (singp (prot))
- {
- i = sizeof (float) * k;
- type = scm_tc7_fvect;
- }
- else if (SCM_COMPLEXP (prot))
- {
- i = 2 * sizeof (double) * k;
- type = scm_tc7_cvect;
- }
- else
- {
- i = sizeof (double) * k;
- type = scm_tc7_dvect;
- }
-
- SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH);
-
- SCM_NEWCELL (v);
- SCM_DEFER_INTS;
- SCM_SET_UVECTOR_BASE (v, (char *) scm_must_malloc (i ? i : 1, "vector"));
- SCM_SET_UVECTOR_LENGTH (v, k, type);
- SCM_ALLOW_INTS;
- return v;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
- (SCM v),
- "Return the number of elements in @var{uve}.")
-#define FUNC_NAME s_scm_uniform_vector_length
-{
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- switch SCM_TYP7 (v)
- {
- default:
- badarg1:SCM_WRONG_TYPE_ARG (1, v);
- case scm_tc7_vector:
- case scm_tc7_wvect:
- return SCM_MAKINUM (SCM_VECTOR_LENGTH (v));
- case scm_tc7_string:
- return SCM_MAKINUM (SCM_STRING_LENGTH (v));
- case scm_tc7_bvect:
- return SCM_MAKINUM (SCM_BITVECTOR_LENGTH (v));
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
-#endif
- return SCM_MAKINUM (SCM_UVECTOR_LENGTH (v));
- }
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
- (SCM v, SCM prot),
- "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
- "not. The @var{prototype} argument is used with uniform arrays\n"
- "and is described elsewhere.")
-#define FUNC_NAME s_scm_array_p
-{
- int nprot;
- int enclosed;
- nprot = SCM_UNBNDP (prot);
- enclosed = 0;
- if (SCM_IMP (v))
- return SCM_BOOL_F;
-
- while (SCM_TYP7 (v) == scm_tc7_smob)
- {
- if (!SCM_ARRAYP (v))
- return SCM_BOOL_F;
- if (nprot)
- return SCM_BOOL_T;
- if (enclosed++)
- return SCM_BOOL_F;
- v = SCM_ARRAY_V (v);
- }
- if (nprot)
- return SCM_BOOL(nprot);
- else
- {
- int protp = 0;
-
- switch (SCM_TYP7 (v))
- {
- case scm_tc7_bvect:
- protp = (SCM_EQ_P (prot, SCM_BOOL_T));
- case scm_tc7_string:
- protp = SCM_CHARP(prot) && (SCM_CHAR (prot) != '\0');
- case scm_tc7_byvect:
- protp = SCM_EQ_P (prot, SCM_MAKE_CHAR ('\0'));
- case scm_tc7_uvect:
- protp = SCM_INUMP(prot) && SCM_INUM(prot)>0;
- case scm_tc7_ivect:
- protp = SCM_INUMP(prot) && SCM_INUM(prot)<=0;
-
- case scm_tc7_svect:
- protp = SCM_SYMBOLP (prot)
- && (1 == SCM_SYMBOL_LENGTH (prot))
- && ('s' == SCM_SYMBOL_CHARS (prot)[0]);
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
- protp = SCM_SYMBOLP (prot)
- && (1 == SCM_SYMBOL_LENGTH (prot))
- && ('s' == SCM_SYMBOL_CHARS (prot)[0]);
-#endif
- case scm_tc7_fvect:
- protp = singp (prot);
- case scm_tc7_dvect:
- protp = SCM_REALP(prot);
- case scm_tc7_cvect:
- protp = SCM_COMPLEXP(prot);
- case scm_tc7_vector:
- case scm_tc7_wvect:
- protp = SCM_NULLP(prot);
- default:
- /* no default */
- ;
- }
- return SCM_BOOL(protp);
- }
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
- (SCM ra),
- "Return the number of dimensions of @var{obj}. If @var{obj} is\n"
- "not an array, @code{0} is returned.")
-#define FUNC_NAME s_scm_array_rank
-{
- if (SCM_IMP (ra))
- return SCM_INUM0;
- switch (SCM_TYP7 (ra))
- {
- default:
- return SCM_INUM0;
- case scm_tc7_string:
- case scm_tc7_vector:
- case scm_tc7_wvect:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_cvect:
- case scm_tc7_dvect:
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
-#endif
- case scm_tc7_svect:
- return SCM_MAKINUM (1L);
- case scm_tc7_smob:
- if (SCM_ARRAYP (ra))
- return SCM_MAKINUM (SCM_ARRAY_NDIM (ra));
- return SCM_INUM0;
- }
-}
-#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 res = SCM_EOL;
- size_t k;
- scm_t_array_dim *s;
- if (SCM_IMP (ra))
- return SCM_BOOL_F;
- switch (SCM_TYP7 (ra))
- {
- default:
- return SCM_BOOL_F;
- case scm_tc7_string:
- case scm_tc7_vector:
- case scm_tc7_wvect:
- case scm_tc7_bvect:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_cvect:
- case scm_tc7_dvect:
- case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
-#endif
- return scm_cons (scm_uniform_vector_length (ra), SCM_EOL);
- case scm_tc7_smob:
- if (!SCM_ARRAYP (ra))
- return SCM_BOOL_F;
- k = SCM_ARRAY_NDIM (ra);
- s = SCM_ARRAY_DIMS (ra);
- while (k--)
- res = scm_cons (s[k].lbnd
- ? scm_cons2 (SCM_MAKINUM (s[k].lbnd),
- SCM_MAKINUM (s[k].ubnd),
- SCM_EOL)
- : SCM_MAKINUM (1 + s[k].ubnd),
- res);
- 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
-{
- SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME);
- return SCM_ARRAY_V (ra);
-}
-#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_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME);
- return SCM_MAKINUM (SCM_ARRAY_BASE (ra));
-}
-#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 res = SCM_EOL;
- size_t k;
- scm_t_array_dim *s;
- SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME);
- k = SCM_ARRAY_NDIM (ra);
- s = SCM_ARRAY_DIMS (ra);
- while (k--)
- res = scm_cons (SCM_MAKINUM (s[k].inc), res);
- return res;
-}
-#undef FUNC_NAME
-
-
-static char s_bad_ind[] = "Bad scm_array index";
-
-
-long
-scm_aind (SCM ra, SCM args, const char *what)
-#define FUNC_NAME what
-{
- SCM ind;
- register long j;
- register unsigned long pos = SCM_ARRAY_BASE (ra);
- register unsigned long k = SCM_ARRAY_NDIM (ra);
- scm_t_array_dim *s = SCM_ARRAY_DIMS (ra);
- if (SCM_INUMP (args))
- {
- if (k != 1)
- scm_error_num_args_subr (what);
- return pos + (SCM_INUM (args) - s->lbnd) * (s->inc);
- }
- while (k && !SCM_NULLP (args))
- {
- ind = SCM_CAR (args);
- args = SCM_CDR (args);
- if (!SCM_INUMP (ind))
- scm_misc_error (what, s_bad_ind, SCM_EOL);
- j = SCM_INUM (ind);
- if (j < s->lbnd || j > s->ubnd)
- scm_out_of_range (what, ind);
- pos += (j - s->lbnd) * (s->inc);
- k--;
- s++;
- }
- if (k != 0 || !SCM_NULLP (args))
- scm_error_num_args_subr (what);
-
- return pos;
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_make_ra (int ndim)
-{
- SCM ra;
- SCM_NEWCELL (ra);
- SCM_DEFER_INTS;
- SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_tc16_array,
- scm_must_malloc ((sizeof (scm_t_array) +
- ndim * sizeof (scm_t_array_dim)),
- "array"));
- SCM_ARRAY_V (ra) = scm_nullvect;
- SCM_ALLOW_INTS;
- return ra;
-}
-
-static char s_bad_spec[] = "Bad scm_array dimension";
-/* Increments will still need to be set. */
-
-
-SCM
-scm_shap2ra (SCM args, const char *what)
-{
- scm_t_array_dim *s;
- SCM ra, spec, sp;
- int ndim = scm_ilength (args);
- if (ndim < 0)
- scm_misc_error (what, s_bad_spec, SCM_EOL);
-
- ra = scm_make_ra (ndim);
- SCM_ARRAY_BASE (ra) = 0;
- s = SCM_ARRAY_DIMS (ra);
- for (; !SCM_NULLP (args); s++, args = SCM_CDR (args))
- {
- spec = SCM_CAR (args);
- if (SCM_INUMP (spec))
- {
- if (SCM_INUM (spec) < 0)
- scm_misc_error (what, s_bad_spec, SCM_EOL);
- s->lbnd = 0;
- s->ubnd = SCM_INUM (spec) - 1;
- s->inc = 1;
- }
- else
- {
- if (!SCM_CONSP (spec) || !SCM_INUMP (SCM_CAR (spec)))
- scm_misc_error (what, s_bad_spec, SCM_EOL);
- s->lbnd = SCM_INUM (SCM_CAR (spec));
- sp = SCM_CDR (spec);
- if (!SCM_CONSP (sp)
- || !SCM_INUMP (SCM_CAR (sp))
- || !SCM_NULLP (SCM_CDR (sp)))
- scm_misc_error (what, s_bad_spec, SCM_EOL);
- s->ubnd = SCM_INUM (SCM_CAR (sp));
- s->inc = 1;
- }
- }
- return ra;
-}
-
-SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0,
- (SCM dims, SCM prot, SCM fill),
- "@deffnx primitive 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
-{
- size_t k;
- unsigned long rlen = 1;
- scm_t_array_dim *s;
- SCM ra;
-
- if (SCM_INUMP (dims))
- {
- SCM answer = scm_make_uve (SCM_INUM (dims), prot);
- if (!SCM_UNBNDP (fill))
- scm_array_fill_x (answer, fill);
- else if (SCM_SYMBOLP (prot))
- scm_array_fill_x (answer, SCM_MAKINUM (0));
- else
- scm_array_fill_x (answer, prot);
- return answer;
- }
-
- SCM_ASSERT (SCM_NULLP (dims) || SCM_CONSP (dims),
- dims, SCM_ARG1, FUNC_NAME);
- ra = scm_shap2ra (dims, FUNC_NAME);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
- s = SCM_ARRAY_DIMS (ra);
- k = SCM_ARRAY_NDIM (ra);
-
- while (k--)
- {
- s[k].inc = rlen;
- SCM_ASSERT_RANGE (1, dims, s[k].lbnd <= s[k].ubnd);
- rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
- }
-
- SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot);
-
- if (!SCM_UNBNDP (fill))
- scm_array_fill_x (ra, fill);
- else if (SCM_SYMBOLP (prot))
- scm_array_fill_x (ra, SCM_MAKINUM (0));
- else
- scm_array_fill_x (ra, prot);
-
- if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
- if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
- return SCM_ARRAY_V (ra);
- return ra;
-}
-#undef FUNC_NAME
-
-
-void
-scm_ra_set_contp (SCM ra)
-{
- size_t k = SCM_ARRAY_NDIM (ra);
- if (k)
- {
- long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc;
- while (k--)
- {
- if (inc != SCM_ARRAY_DIMS (ra)[k].inc)
- {
- SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
- return;
- }
- inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd
- - SCM_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 ra;
- SCM inds, indptr;
- SCM imap;
- size_t k, i;
- long old_min, new_min, old_max, new_max;
- scm_t_array_dim *s;
-
- SCM_VALIDATE_REST_ARGUMENT (dims);
- SCM_VALIDATE_ARRAY (1,oldra);
- SCM_VALIDATE_PROC (2,mapfunc);
- ra = scm_shap2ra (dims, FUNC_NAME);
- if (SCM_ARRAYP (oldra))
- {
- SCM_ARRAY_V (ra) = SCM_ARRAY_V (oldra);
- old_min = old_max = SCM_ARRAY_BASE (oldra);
- s = SCM_ARRAY_DIMS (oldra);
- k = SCM_ARRAY_NDIM (oldra);
- 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_ARRAY_V (ra) = oldra;
- old_min = 0;
- old_max = SCM_INUM (scm_uniform_vector_length (oldra)) - 1;
- }
- inds = SCM_EOL;
- s = SCM_ARRAY_DIMS (ra);
- for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
- {
- inds = scm_cons (SCM_MAKINUM (s[k].lbnd), inds);
- if (s[k].ubnd < s[k].lbnd)
- {
- if (1 == SCM_ARRAY_NDIM (ra))
- ra = scm_make_uve (0L, scm_array_prototype (ra));
- else
- SCM_ARRAY_V (ra) = scm_make_uve (0L, scm_array_prototype (ra));
- return ra;
- }
- }
- imap = scm_apply_0 (mapfunc, scm_reverse (inds));
- if (SCM_ARRAYP (oldra))
- i = (size_t) scm_aind (oldra, imap, FUNC_NAME);
- else
- {
- if (SCM_NINUMP (imap))
-
- {
- if (scm_ilength (imap) != 1 || !SCM_INUMP (SCM_CAR (imap)))
- SCM_MISC_ERROR (s_bad_ind, SCM_EOL);
- imap = SCM_CAR (imap);
- }
- i = SCM_INUM (imap);
- }
- SCM_ARRAY_BASE (ra) = new_min = new_max = i;
- indptr = inds;
- k = SCM_ARRAY_NDIM (ra);
- while (k--)
- {
- if (s[k].ubnd > s[k].lbnd)
- {
- SCM_SETCAR (indptr, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1));
- imap = scm_apply_0 (mapfunc, scm_reverse (inds));
- if (SCM_ARRAYP (oldra))
-
- s[k].inc = scm_aind (oldra, imap, FUNC_NAME) - i;
- else
- {
- if (SCM_NINUMP (imap))
- {
- if (scm_ilength (imap) != 1 || !SCM_INUMP (SCM_CAR (imap)))
- SCM_MISC_ERROR (s_bad_ind, SCM_EOL);
- imap = SCM_CAR (imap);
- }
- s[k].inc = (long) SCM_INUM (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);
- }
- if (old_min > new_min || old_max < new_max)
- SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
- if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
- {
- SCM v = SCM_ARRAY_V (ra);
- unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
- if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
- return v;
- if (s->ubnd < s->lbnd)
- return scm_make_uve (0L, scm_array_prototype (ra));
- }
- scm_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, *ve = &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);
- switch (SCM_TYP7 (ra))
- {
- default:
- badarg:SCM_WRONG_TYPE_ARG (1, ra);
- case scm_tc7_bvect:
- case scm_tc7_string:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
-#endif
- if (SCM_NULLP (args) || !SCM_NULLP (SCM_CDR (args)))
- SCM_WRONG_NUM_ARGS ();
- SCM_VALIDATE_INUM (SCM_ARG2, SCM_CAR (args));
- SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args),
- SCM_EQ_P (SCM_INUM0, SCM_CAR (args)));
- return ra;
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
- vargs = scm_vector (args);
- if (SCM_VECTOR_LENGTH (vargs) != SCM_ARRAY_NDIM (ra))
- SCM_WRONG_NUM_ARGS ();
- ve = SCM_VELTS (vargs);
- ndim = 0;
- for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
- {
- SCM_ASSERT (SCM_INUMP (ve[k]), ve[k], (SCM_ARG2 + k),
- FUNC_NAME);
- i = SCM_INUM (ve[k]);
- if (i < 0 || i >= SCM_ARRAY_NDIM (ra))
- scm_out_of_range (FUNC_NAME, ve[k]);
- if (ndim < i)
- ndim = i;
- }
- ndim++;
- res = scm_make_ra (ndim);
- SCM_ARRAY_V (res) = SCM_ARRAY_V (ra);
- SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra);
- for (k = ndim; k--;)
- {
- SCM_ARRAY_DIMS (res)[k].lbnd = 0;
- SCM_ARRAY_DIMS (res)[k].ubnd = -1;
- }
- for (k = SCM_ARRAY_NDIM (ra); k--;)
- {
- i = SCM_INUM (ve[k]);
- s = &(SCM_ARRAY_DIMS (ra)[k]);
- r = &(SCM_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_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_ra_set_contp (res);
- return res;
- }
-}
-#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;
- scm_t_array_dim vdim, *s = &vdim;
- int ndim, j, k, ninr, noutr;
-
- SCM_VALIDATE_REST_ARGUMENT (axes);
- if (SCM_NULLP (axes))
- axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
- ninr = scm_ilength (axes);
- if (ninr < 0)
- SCM_WRONG_NUM_ARGS ();
- ra_inr = scm_make_ra (ninr);
- SCM_ASRTGO (SCM_NIMP (ra), badarg1);
- switch SCM_TYP7 (ra)
- {
- default:
- badarg1:SCM_WRONG_TYPE_ARG (1, ra);
- case scm_tc7_string:
- case scm_tc7_bvect:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_vector:
- case scm_tc7_wvect:
- case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
-#endif
- s->lbnd = 0;
- s->ubnd = SCM_INUM (scm_uniform_vector_length (ra)) - 1;
- s->inc = 1;
- SCM_ARRAY_V (ra_inr) = ra;
- SCM_ARRAY_BASE (ra_inr) = 0;
- ndim = 1;
- break;
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (ra), badarg1);
- s = SCM_ARRAY_DIMS (ra);
- SCM_ARRAY_V (ra_inr) = SCM_ARRAY_V (ra);
- SCM_ARRAY_BASE (ra_inr) = SCM_ARRAY_BASE (ra);
- ndim = SCM_ARRAY_NDIM (ra);
- break;
- }
- noutr = ndim - ninr;
- if (noutr < 0)
- SCM_WRONG_NUM_ARGS ();
- axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKE_CHAR (0));
- res = scm_make_ra (noutr);
- SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
- SCM_ARRAY_V (res) = ra_inr;
- for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
- {
- if (!SCM_INUMP (SCM_CAR (axes)))
- SCM_MISC_ERROR ("bad axis", SCM_EOL);
- j = SCM_INUM (SCM_CAR (axes));
- SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
- SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
- SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
- SCM_STRING_CHARS (axv)[j] = 1;
- }
- for (j = 0, k = 0; k < noutr; k++, j++)
- {
- while (SCM_STRING_CHARS (axv)[j])
- j++;
- SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
- SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
- SCM_ARRAY_DIMS (res)[k].inc = s[j].inc;
- }
- scm_ra_set_contp (ra_inr);
- scm_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 ind = SCM_EOL;
- long pos = 0;
- register size_t k;
- register long j;
- scm_t_array_dim *s;
-
- SCM_VALIDATE_REST_ARGUMENT (args);
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- if (SCM_NIMP (args))
-
- {
- ind = SCM_CAR (args);
- args = SCM_CDR (args);
- SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, FUNC_NAME);
- pos = SCM_INUM (ind);
- }
-tail:
- switch SCM_TYP7 (v)
- {
- default:
- badarg1:SCM_WRONG_TYPE_ARG (1, v);
- wna: SCM_WRONG_NUM_ARGS ();
- case scm_tc7_smob:
- k = SCM_ARRAY_NDIM (v);
- s = SCM_ARRAY_DIMS (v);
- pos = SCM_ARRAY_BASE (v);
- if (!k)
- {
- SCM_ASRTGO (SCM_NULLP (ind), wna);
- ind = SCM_INUM0;
- }
- else
- while (!0)
- {
- j = SCM_INUM (ind);
- if (!(j >= (s->lbnd) && j <= (s->ubnd)))
- {
- SCM_ASRTGO (--k == scm_ilength (args), wna);
- return SCM_BOOL_F;
- }
- pos += (j - s->lbnd) * (s->inc);
- if (!(--k && SCM_NIMP (args)))
- break;
- ind = SCM_CAR (args);
- args = SCM_CDR (args);
- s++;
- if (!SCM_INUMP (ind))
- SCM_MISC_ERROR (s_bad_ind, SCM_EOL);
- }
- SCM_ASRTGO (0 == k, wna);
- v = SCM_ARRAY_V (v);
- goto tail;
- case scm_tc7_bvect:
- case scm_tc7_string:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
-#endif
- case scm_tc7_vector:
- case scm_tc7_wvect:
- {
- unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
- SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna);
- return SCM_BOOL(pos >= 0 && pos < length);
- }
- }
-}
-#undef FUNC_NAME
-
-
-SCM_REGISTER_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref);
-
-
-SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
- (SCM v, SCM args),
- "@deffnx primitive array-ref v . args\n"
- "Return the element at the @code{(index1, index2)} element in\n"
- "@var{array}.")
-#define FUNC_NAME s_scm_uniform_vector_ref
-{
- long pos;
-
- if (SCM_IMP (v))
- {
- SCM_ASRTGO (SCM_NULLP (args), badarg);
- return v;
- }
- else if (SCM_ARRAYP (v))
- {
- pos = scm_aind (v, args, FUNC_NAME);
- v = SCM_ARRAY_V (v);
- }
- else
- {
- unsigned long int length;
- if (SCM_NIMP (args))
- {
- SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME);
- pos = SCM_INUM (SCM_CAR (args));
- SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
- }
- else
- {
- SCM_VALIDATE_INUM (2,args);
- pos = SCM_INUM (args);
- }
- length = SCM_INUM (scm_uniform_vector_length (v));
- SCM_ASRTGO (pos >= 0 && pos < length, outrng);
- }
- switch SCM_TYP7 (v)
- {
- default:
- if (SCM_NULLP (args))
- return v;
- badarg:
- SCM_WRONG_TYPE_ARG (1, v);
- /* not reached */
-
- outrng:
- scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos));
- wna:
- SCM_WRONG_NUM_ARGS ();
- case scm_tc7_smob:
- { /* enclosed */
- int k = SCM_ARRAY_NDIM (v);
- SCM res = scm_make_ra (k);
- SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
- SCM_ARRAY_BASE (res) = pos;
- while (k--)
- {
- SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
- SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
- SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
- }
- return res;
- }
- case scm_tc7_bvect:
- if (SCM_BITVEC_REF (v, pos))
- return SCM_BOOL_T;
- else
- return SCM_BOOL_F;
- case scm_tc7_string:
- return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]);
- case scm_tc7_byvect:
- return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]);
- case scm_tc7_uvect:
- return scm_ulong2num (((unsigned long *) SCM_VELTS (v))[pos]);
- case scm_tc7_ivect:
- return scm_long2num (((signed long *) SCM_VELTS (v))[pos]);
-
- case scm_tc7_svect:
- return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]);
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
- return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]);
-#endif
-
- case scm_tc7_fvect:
- return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]);
- case scm_tc7_dvect:
- return scm_make_real (((double *) SCM_CELL_WORD_1 (v))[pos]);
- case scm_tc7_cvect:
- return scm_make_complex (((double *) SCM_CELL_WORD_1 (v))[2 * pos],
- ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1]);
- case scm_tc7_vector:
- case scm_tc7_wvect:
- return SCM_VELTS (v)[pos];
- }
-}
-#undef FUNC_NAME
-
-/* Internal version of scm_uniform_vector_ref for uves that does no error checking and
- tries to recycle conses. (Make *sure* you want them recycled.) */
-
-SCM
-scm_cvref (SCM v, unsigned long pos, SCM last)
-#define FUNC_NAME "scm_cvref"
-{
- switch SCM_TYP7 (v)
- {
- default:
- SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
- case scm_tc7_bvect:
- if (SCM_BITVEC_REF(v,pos))
- return SCM_BOOL_T;
- else
- return SCM_BOOL_F;
- case scm_tc7_string:
- return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]);
- case scm_tc7_byvect:
- return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]);
- case scm_tc7_uvect:
- return scm_ulong2num(((unsigned long *) SCM_VELTS (v))[pos]);
- case scm_tc7_ivect:
- return scm_long2num(((signed long *) SCM_VELTS (v))[pos]);
- case scm_tc7_svect:
- return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]);
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
- return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]);
-#endif
- case scm_tc7_fvect:
- if (SCM_NIMP (last) && !SCM_EQ_P (last, scm_flo0) && SCM_SLOPPY_REALP (last))
- {
- SCM_REAL_VALUE (last) = ((float *) SCM_CELL_WORD_1 (v))[pos];
- return last;
- }
- return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]);
- case scm_tc7_dvect:
- if (SCM_NIMP (last) && !SCM_EQ_P (last, scm_flo0) && SCM_SLOPPY_REALP (last))
- {
- SCM_REAL_VALUE (last) = ((double *) SCM_CELL_WORD_1 (v))[pos];
- return last;
- }
- return scm_make_real (((double *) SCM_CELL_WORD_1 (v))[pos]);
- case scm_tc7_cvect:
- if (SCM_NIMP (last) && SCM_SLOPPY_COMPLEXP (last))
- {
- SCM_COMPLEX_REAL (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos];
- SCM_COMPLEX_IMAG (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1];
- return last;
- }
- return scm_make_complex (((double *) SCM_CELL_WORD_1 (v))[2 * pos],
- ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1]);
- case scm_tc7_vector:
- case scm_tc7_wvect:
- return SCM_VELTS (v)[pos];
- case scm_tc7_smob:
- { /* enclosed scm_array */
- int k = SCM_ARRAY_NDIM (v);
- SCM res = scm_make_ra (k);
- SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
- SCM_ARRAY_BASE (res) = pos;
- while (k--)
- {
- SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
- SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
- SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
- }
- return res;
- }
- }
-}
-#undef FUNC_NAME
-
-
-SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);
-
-
-/* Note that args may be a list or an immediate object, depending which
- PROC is used (and it's called from C too). */
-SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
- (SCM v, SCM obj, SCM args),
- "@deffnx primitive uniform-array-set1! v obj args\n"
- "Sets 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
-{
- long pos = 0;
-
- SCM_VALIDATE_REST_ARGUMENT (args);
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- if (SCM_ARRAYP (v))
- {
- pos = scm_aind (v, args, FUNC_NAME);
- v = SCM_ARRAY_V (v);
- }
- else
- {
- unsigned long int length;
- if (SCM_NIMP (args))
- {
- SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args,
- SCM_ARG3, FUNC_NAME);
- SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
- pos = SCM_INUM (SCM_CAR (args));
- }
- else
- {
- SCM_VALIDATE_INUM_COPY (3,args,pos);
- }
- length = SCM_INUM (scm_uniform_vector_length (v));
- SCM_ASRTGO (pos >= 0 && pos < length, outrng);
- }
- switch (SCM_TYP7 (v))
- {
- default: badarg1:
- SCM_WRONG_TYPE_ARG (1, v);
- /* not reached */
- outrng:
- scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos));
- wna:
- SCM_WRONG_NUM_ARGS ();
- case scm_tc7_smob: /* enclosed */
- goto badarg1;
- case scm_tc7_bvect:
- if (SCM_FALSEP (obj))
- SCM_BITVEC_CLR(v,pos);
- else if (SCM_EQ_P (obj, SCM_BOOL_T))
- SCM_BITVEC_SET(v,pos);
- else
- badobj:SCM_WRONG_TYPE_ARG (2, obj);
- break;
- case scm_tc7_string:
- SCM_ASRTGO (SCM_CHARP (obj), badobj);
- SCM_STRING_UCHARS (v)[pos] = SCM_CHAR (obj);
- break;
- case scm_tc7_byvect:
- if (SCM_CHARP (obj))
- obj = SCM_MAKINUM ((char) SCM_CHAR (obj));
- SCM_ASRTGO (SCM_INUMP (obj), badobj);
- ((char *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj);
- break;
- case scm_tc7_uvect:
- ((unsigned long *) SCM_UVECTOR_BASE (v))[pos]
- = scm_num2ulong (obj, SCM_ARG2, FUNC_NAME);
- break;
- case scm_tc7_ivect:
- ((long *) SCM_UVECTOR_BASE (v))[pos]
- = scm_num2long (obj, SCM_ARG2, FUNC_NAME);
- break;
- case scm_tc7_svect:
- SCM_ASRTGO (SCM_INUMP (obj), badobj);
- ((short *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj);
- break;
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
- ((long long *) SCM_UVECTOR_BASE (v))[pos]
- = scm_num2long_long (obj, SCM_ARG2, FUNC_NAME);
- break;
-#endif
- case scm_tc7_fvect:
- ((float *) SCM_UVECTOR_BASE (v))[pos]
- = (float) scm_num2dbl (obj, FUNC_NAME);
- break;
- case scm_tc7_dvect:
- ((double *) SCM_UVECTOR_BASE (v))[pos]
- = scm_num2dbl (obj, FUNC_NAME);
- break;
- case scm_tc7_cvect:
- SCM_ASRTGO (SCM_INEXACTP (obj), badobj);
- if (SCM_REALP (obj)) {
- ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_REAL_VALUE (obj);
- ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = 0.0;
- } else {
- ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_COMPLEX_REAL (obj);
- ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = SCM_COMPLEX_IMAG (obj);
- }
- break;
- case scm_tc7_vector:
- case scm_tc7_wvect:
- SCM_VELTS (v)[pos] = obj;
- break;
- }
- 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),
- "@deffnx primitive array-contents array strict\n"
- "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_IMP (ra))
- return SCM_BOOL_F;
- switch SCM_TYP7 (ra)
- {
- default:
- return SCM_BOOL_F;
- case scm_tc7_vector:
- case scm_tc7_wvect:
- case scm_tc7_string:
- case scm_tc7_bvect:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
-#endif
- return ra;
- case scm_tc7_smob:
- {
- size_t k, ndim = SCM_ARRAY_NDIM (ra), len = 1;
- if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra))
- return SCM_BOOL_F;
- for (k = 0; k < ndim; k++)
- len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
- if (!SCM_UNBNDP (strict))
- {
- if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc))
- return SCM_BOOL_F;
- if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
- {
- if (len != SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) ||
- SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
- len % SCM_LONG_BIT)
- return SCM_BOOL_F;
- }
- }
-
- {
- SCM v = SCM_ARRAY_V (ra);
- unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
- if ((len == length) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
- return v;
- }
-
- sra = scm_make_ra (1);
- SCM_ARRAY_DIMS (sra)->lbnd = 0;
- SCM_ARRAY_DIMS (sra)->ubnd = len - 1;
- SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra);
- SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra);
- SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
- return sra;
- }
- }
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_ra2contig (SCM ra, int copy)
-{
- SCM ret;
- long inc = 1;
- size_t k, len = 1;
- for (k = SCM_ARRAY_NDIM (ra); k--;)
- len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
- k = SCM_ARRAY_NDIM (ra);
- if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc)))
- {
- if (scm_tc7_bvect != SCM_TYP7 (SCM_ARRAY_V (ra)))
- return ra;
- if ((len == SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) &&
- 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
- 0 == len % SCM_LONG_BIT))
- return ra;
- }
- ret = scm_make_ra (k);
- SCM_ARRAY_BASE (ret) = 0;
- while (k--)
- {
- SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd;
- SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd;
- SCM_ARRAY_DIMS (ret)[k].inc = inc;
- inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
- }
- SCM_ARRAY_V (ret) = scm_make_uve ((inc - 1), scm_array_prototype (ra));
- if (copy)
- scm_array_copy_x (ra, ret);
- return ret;
-}
-
-
-
-SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
- (SCM ra, SCM port_or_fd, SCM start, SCM end),
- "@deffnx primitive uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
- "Attempts 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 during\n"
- "uniform-array-read! the objects up to that point only 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
-{
- SCM cra = SCM_UNDEFINED, v = ra;
- long sz, vlen, ans;
- long cstart = 0;
- long cend;
- long offset = 0;
- char *base;
-
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_cur_inp;
- else
- SCM_ASSERT (SCM_INUMP (port_or_fd)
- || (SCM_OPINPORTP (port_or_fd)),
- port_or_fd, SCM_ARG2, FUNC_NAME);
- vlen = SCM_INUM (scm_uniform_vector_length (v));
-
-loop:
- switch SCM_TYP7 (v)
- {
- default:
- badarg1:SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
- cra = scm_ra2contig (ra, 0);
- cstart += SCM_ARRAY_BASE (cra);
- vlen = SCM_ARRAY_DIMS (cra)->inc *
- (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
- v = SCM_ARRAY_V (cra);
- goto loop;
- case scm_tc7_string:
- base = SCM_STRING_CHARS (v);
- sz = sizeof (char);
- break;
- case scm_tc7_bvect:
- base = (char *) SCM_BITVECTOR_BASE (v);
- vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
- cstart /= SCM_LONG_BIT;
- sz = sizeof (long);
- break;
- case scm_tc7_byvect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = sizeof (char);
- break;
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = sizeof (long);
- break;
- case scm_tc7_svect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = sizeof (short);
- break;
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = sizeof (long long);
- break;
-#endif
- case scm_tc7_fvect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = sizeof (float);
- break;
- case scm_tc7_dvect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = sizeof (double);
- break;
- case scm_tc7_cvect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = 2 * sizeof (double);
- break;
- }
-
- cend = vlen;
- if (!SCM_UNBNDP (start))
- {
- offset =
- SCM_NUM2LONG (3, start);
-
- if (offset < 0 || offset >= cend)
- scm_out_of_range (FUNC_NAME, start);
-
- if (!SCM_UNBNDP (end))
- {
- long tend =
- SCM_NUM2LONG (4, end);
-
- if (tend <= offset || tend > cend)
- scm_out_of_range (FUNC_NAME, end);
- cend = tend;
- }
- }
-
- if (SCM_NIMP (port_or_fd))
- {
- scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
- int remaining = (cend - offset) * sz;
- char *dest = base + (cstart + offset) * sz;
-
- if (pt->rw_active == SCM_PORT_WRITE)
- scm_flush (port_or_fd);
-
- ans = cend - offset;
- while (remaining > 0)
- {
- if (pt->read_pos < pt->read_end)
- {
- int to_copy = min (pt->read_end - pt->read_pos,
- remaining);
-
- memcpy (dest, pt->read_pos, to_copy);
- pt->read_pos += to_copy;
- remaining -= to_copy;
- dest += to_copy;
- }
- else
- {
- if (scm_fill_input (port_or_fd) == EOF)
- {
- if (remaining % sz != 0)
- {
- SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
- }
- ans -= remaining / sz;
- break;
- }
- }
- }
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
- }
- else /* file descriptor. */
- {
- SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd),
- base + (cstart + offset) * sz,
- (sz * (cend - offset))));
- if (ans == -1)
- SCM_SYSERROR;
- }
- if (SCM_TYP7 (v) == scm_tc7_bvect)
- ans *= SCM_LONG_BIT;
-
- if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra))
- scm_array_copy_x (cra, ra);
-
- return SCM_MAKINUM (ans);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
- (SCM v, SCM port_or_fd, SCM start, SCM end),
- "@deffnx primitive uniform-vector-write uve [port-or-fdes] [start] [end]\n"
- "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
-{
- long sz, vlen, ans;
- long offset = 0;
- long cstart = 0;
- long cend;
- char *base;
-
- port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
-
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_cur_outp;
- else
- SCM_ASSERT (SCM_INUMP (port_or_fd)
- || (SCM_OPOUTPORTP (port_or_fd)),
- port_or_fd, SCM_ARG2, FUNC_NAME);
- vlen = SCM_INUM (scm_uniform_vector_length (v));
-
-loop:
- switch SCM_TYP7 (v)
- {
- default:
- badarg1:SCM_WRONG_TYPE_ARG (1, v);
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
- v = scm_ra2contig (v, 1);
- cstart = SCM_ARRAY_BASE (v);
- vlen = SCM_ARRAY_DIMS (v)->inc
- * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1);
- v = SCM_ARRAY_V (v);
- goto loop;
- case scm_tc7_string:
- base = SCM_STRING_CHARS (v);
- sz = sizeof (char);
- break;
- case scm_tc7_bvect:
- base = (char *) SCM_BITVECTOR_BASE (v);
- vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
- cstart /= SCM_LONG_BIT;
- sz = sizeof (long);
- break;
- case scm_tc7_byvect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = sizeof (char);
- break;
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = sizeof (long);
- break;
- case scm_tc7_svect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = sizeof (short);
- break;
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = sizeof (long long);
- break;
-#endif
- case scm_tc7_fvect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = sizeof (float);
- break;
- case scm_tc7_dvect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = sizeof (double);
- break;
- case scm_tc7_cvect:
- base = (char *) SCM_UVECTOR_BASE (v);
- sz = 2 * sizeof (double);
- break;
- }
-
- cend = vlen;
- if (!SCM_UNBNDP (start))
- {
- offset =
- SCM_NUM2LONG (3, start);
-
- if (offset < 0 || offset >= cend)
- scm_out_of_range (FUNC_NAME, start);
-
- if (!SCM_UNBNDP (end))
- {
- long tend =
- SCM_NUM2LONG (4, end);
-
- if (tend <= offset || tend > cend)
- scm_out_of_range (FUNC_NAME, end);
- cend = tend;
- }
- }
-
- if (SCM_NIMP (port_or_fd))
- {
- char *source = base + (cstart + offset) * sz;
-
- ans = cend - offset;
- scm_lfwrite (source, ans * sz, port_or_fd);
- }
- else /* file descriptor. */
- {
- SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd),
- base + (cstart + offset) * sz,
- (sz * (cend - offset))));
- if (ans == -1)
- SCM_SYSERROR;
- }
- if (SCM_TYP7 (v) == scm_tc7_bvect)
- ans *= SCM_LONG_BIT;
-
- return SCM_MAKINUM (ans);
-}
-#undef FUNC_NAME
-
-
-static char cnt_tab[16] =
-{0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
-
-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_VALIDATE_BOOL (1, b);
- SCM_ASSERT (SCM_BITVECTOR_P (bitvector), bitvector, 2, FUNC_NAME);
- if (SCM_BITVECTOR_LENGTH (bitvector) == 0) {
- return SCM_INUM0;
- } else {
- unsigned long int count = 0;
- unsigned long int i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_LONG_BIT;
- unsigned long int w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
- if (SCM_FALSEP (b)) {
- w = ~w;
- };
- w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT);
- while (1) {
- while (w) {
- count += cnt_tab[w & 0x0f];
- w >>= 4;
- }
- if (i == 0) {
- return SCM_MAKINUM (count);
- } else {
- --i;
- w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
- if (SCM_FALSEP (b)) {
- w = ~w;
- }
- }
- }
- }
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
- (SCM item, SCM v, SCM k),
- "Return the minimum index of an occurrence of @var{bool} in\n"
- "@var{bv} which is at least @var{k}. If no @var{bool} occurs\n"
- "within the specified range @code{#f} is returned.")
-#define FUNC_NAME s_scm_bit_position
-{
- long i, lenw, xbits, pos;
- register unsigned long w;
-
- SCM_VALIDATE_BOOL (1, item);
- SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME);
- SCM_VALIDATE_INUM_COPY (3,k,pos);
- SCM_ASSERT_RANGE (3, k, (pos <= SCM_BITVECTOR_LENGTH (v)) && (pos >= 0));
-
- if (pos == SCM_BITVECTOR_LENGTH (v))
- return SCM_BOOL_F;
-
- lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
- i = pos / SCM_LONG_BIT;
- w = SCM_UNPACK (SCM_VELTS (v)[i]);
- if (SCM_FALSEP (item))
- w = ~w;
- xbits = (pos % SCM_LONG_BIT);
- pos -= xbits;
- w = ((w >> xbits) << xbits);
- xbits = SCM_LONG_BIT - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT;
- while (!0)
- {
- if (w && (i == lenw))
- w = ((w << xbits) >> xbits);
- if (w)
- while (w)
- switch (w & 0x0f)
- {
- default:
- return SCM_MAKINUM (pos);
- case 2:
- case 6:
- case 10:
- case 14:
- return SCM_MAKINUM (pos + 1);
- case 4:
- case 12:
- return SCM_MAKINUM (pos + 2);
- case 8:
- return SCM_MAKINUM (pos + 3);
- case 0:
- pos += 4;
- w >>= 4;
- }
- if (++i > lenw)
- break;
- pos += SCM_LONG_BIT;
- w = SCM_UNPACK (SCM_VELTS (v)[i]);
- if (SCM_FALSEP (item))
- w = ~w;
- }
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
- (SCM v, SCM kv, SCM obj),
- "If uve is a bit-vector @var{bv} and uve must be of the same\n"
- "length. If @var{bool} is @code{#t}, uve is OR'ed into\n"
- "@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is\n"
- "AND'ed into @var{bv}.\n\n"
- "If uve is a unsigned integer vector all the elements of uve\n"
- "must be between 0 and the @code{length} of @var{bv}. The bits\n"
- "of @var{bv} corresponding to the indexes in uve are set to\n"
- "@var{bool}. The return value is unspecified.")
-#define FUNC_NAME s_scm_bit_set_star_x
-{
- register long i, k, vlen;
- SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
- SCM_ASRTGO (SCM_NIMP (kv), badarg2);
- switch SCM_TYP7 (kv)
- {
- default:
- badarg2:SCM_WRONG_TYPE_ARG (2, kv);
- case scm_tc7_uvect:
- vlen = SCM_BITVECTOR_LENGTH (v);
- if (SCM_FALSEP (obj))
- for (i = SCM_UVECTOR_LENGTH (kv); i;)
- {
- k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
- if (k >= vlen)
- scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
- SCM_BITVEC_CLR(v,k);
- }
- else if (SCM_EQ_P (obj, SCM_BOOL_T))
- for (i = SCM_UVECTOR_LENGTH (kv); i;)
- {
- k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
- if (k >= vlen)
- scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
- SCM_BITVEC_SET(v,k);
- }
- else
- badarg3:SCM_WRONG_TYPE_ARG (3, obj);
- break;
- case scm_tc7_bvect:
- SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
- if (SCM_FALSEP (obj))
- for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
- SCM_BITVECTOR_BASE (v) [k] &= ~SCM_BITVECTOR_BASE (kv) [k];
- else if (SCM_EQ_P (obj, SCM_BOOL_T))
- for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
- SCM_BITVECTOR_BASE (v) [k] |= SCM_BITVECTOR_BASE (kv) [k];
- else
- goto badarg3;
- break;
- }
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
- (SCM v, SCM kv, SCM obj),
- "Return\n"
- "@lisp\n"
- "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n"
- "@end lisp\n"
- "@var{bv} is not modified.")
-#define FUNC_NAME s_scm_bit_count_star
-{
- register long i, vlen, count = 0;
- register unsigned long k;
- int fObj = 0;
-
- SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
- SCM_ASRTGO (SCM_NIMP (kv), badarg2);
- switch SCM_TYP7 (kv)
- {
- default:
- badarg2:
- SCM_WRONG_TYPE_ARG (2, kv);
- case scm_tc7_uvect:
- vlen = SCM_BITVECTOR_LENGTH (v);
- if (SCM_FALSEP (obj))
- for (i = SCM_UVECTOR_LENGTH (kv); i;)
- {
- k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
- if (k >= vlen)
- scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
- if (!SCM_BITVEC_REF(v,k))
- count++;
- }
- else if (SCM_EQ_P (obj, SCM_BOOL_T))
- for (i = SCM_UVECTOR_LENGTH (kv); i;)
- {
- k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
- if (k >= vlen)
- scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
- if (SCM_BITVEC_REF (v,k))
- count++;
- }
- else
- badarg3:SCM_WRONG_TYPE_ARG (3, obj);
- break;
- case scm_tc7_bvect:
- SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
- if (0 == SCM_BITVECTOR_LENGTH (v))
- return SCM_INUM0;
- SCM_ASRTGO (SCM_BOOLP (obj), badarg3);
- fObj = SCM_EQ_P (obj, SCM_BOOL_T);
- i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT;
- k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK (SCM_VELTS (v)[i]) : ~ SCM_UNPACK (SCM_VELTS (v)[i]));
- k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT);
- while (1)
- {
- for (; k; k >>= 4)
- count += cnt_tab[k & 0x0f];
- if (0 == i--)
- return SCM_MAKINUM (count);
-
- /* urg. repetitive (see above.) */
- k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK(SCM_VELTS (v)[i]) : ~SCM_UNPACK (SCM_VELTS (v)[i]));
- }
- }
- return SCM_MAKINUM (count);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
- (SCM v),
- "Modifies @var{bv} by replacing each element with its negation.")
-#define FUNC_NAME s_scm_bit_invert_x
-{
- long int k;
-
- SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
-
- k = SCM_BITVECTOR_LENGTH (v);
- for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
- SCM_BITVECTOR_BASE (v) [k] = ~SCM_BITVECTOR_BASE (v) [k];
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_istr2bve (char *str, long len)
-{
- SCM v = scm_make_uve (len, SCM_BOOL_T);
- long *data = (long *) SCM_VELTS (v);
- register unsigned long mask;
- register long k;
- register long j;
- for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++)
- {
- data[k] = 0L;
- j = len - k * SCM_LONG_BIT;
- if (j > SCM_LONG_BIT)
- j = SCM_LONG_BIT;
- for (mask = 1L; j--; mask <<= 1)
- switch (*str++)
- {
- case '0':
- break;
- case '1':
- data[k] |= mask;
- break;
- default:
- return SCM_BOOL_F;
- }
- }
- return v;
-}
-
-
-
-static SCM
-ra2l (SCM ra,unsigned long base,unsigned long k)
-{
- register SCM res = SCM_EOL;
- register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
- register size_t i;
- if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
- return SCM_EOL;
- i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
- if (k < SCM_ARRAY_NDIM (ra) - 1)
- {
- do
- {
- i -= inc;
- res = scm_cons (ra2l (ra, i, k + 1), res);
- }
- while (i != base);
- }
- else
- do
- {
- i -= inc;
- res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), SCM_MAKINUM (i)), res);
- }
- while (i != base);
- return res;
-}
-
-
-SCM_DEFINE (scm_t_arrayo_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_t_arrayo_list
-{
- SCM res = SCM_EOL;
- register long k;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- switch SCM_TYP7 (v)
- {
- default:
- badarg1:SCM_WRONG_TYPE_ARG (1, v);
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
- return ra2l (v, SCM_ARRAY_BASE (v), 0);
- case scm_tc7_vector:
- case scm_tc7_wvect:
- return scm_vector_to_list (v);
- case scm_tc7_string:
- return scm_string_to_list (v);
- case scm_tc7_bvect:
- {
- long *data = (long *) SCM_VELTS (v);
- register unsigned long mask;
- for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
- for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1)
- res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res);
- for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
- res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res);
- return res;
- }
- case scm_tc7_byvect:
- {
- signed char *data = (signed char *) SCM_VELTS (v);
- unsigned long k = SCM_UVECTOR_LENGTH (v);
- while (k != 0)
- res = scm_cons (SCM_MAKINUM (data[--k]), res);
- return res;
- }
- case scm_tc7_uvect:
- {
- long *data = (long *)SCM_VELTS(v);
- for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(scm_ulong2num(data[k]), res);
- return res;
- }
- case scm_tc7_ivect:
- {
- long *data = (long *)SCM_VELTS(v);
- for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(scm_long2num(data[k]), res);
- return res;
- }
- case scm_tc7_svect:
- {
- short *data = (short *)SCM_VELTS(v);
- for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(scm_short2num (data[k]), res);
- return res;
- }
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
- {
- long long *data = (long long *)SCM_VELTS(v);
- for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(scm_long_long2num(data[k]), res);
- return res;
- }
-#endif
- case scm_tc7_fvect:
- {
- float *data = (float *) SCM_VELTS (v);
- for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (scm_make_real (data[k]), res);
- return res;
- }
- case scm_tc7_dvect:
- {
- double *data = (double *) SCM_VELTS (v);
- for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (scm_make_real (data[k]), res);
- return res;
- }
- case scm_tc7_cvect:
- {
- double (*data)[2] = (double (*)[2]) SCM_VELTS (v);
- for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (scm_make_complex (data[k][0], data[k][1]), res);
- return res;
- }
- }
-}
-#undef FUNC_NAME
-
-
-static int l2ra(SCM lst, SCM ra, unsigned long base, unsigned long k);
-
-SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
- (SCM ndim, SCM prot, SCM lst),
- "@deffnx procedure list->uniform-vector prot lst\n"
- "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.")
-#define FUNC_NAME s_scm_list_to_uniform_array
-{
- SCM shp = SCM_EOL;
- SCM row = lst;
- SCM ra;
- unsigned long k;
- long n;
- SCM_VALIDATE_INUM_COPY (1,ndim,k);
- while (k--)
- {
- n = scm_ilength (row);
- SCM_ASSERT (n >= 0, lst, SCM_ARG3, FUNC_NAME);
- shp = scm_cons (SCM_MAKINUM (n), shp);
- if (SCM_NIMP (row))
- row = SCM_CAR (row);
- }
- ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot,
- SCM_UNDEFINED);
- if (SCM_NULLP (shp))
- {
- SCM_ASRTGO (1 == scm_ilength (lst), badlst);
- scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL);
- return ra;
- }
- if (!SCM_ARRAYP (ra))
- {
- unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra));
- for (k = 0; k < length; k++, lst = SCM_CDR (lst))
- scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k));
- return ra;
- }
- if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0))
- return ra;
- else
- badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S", SCM_LIST1 (lst));
-}
-#undef FUNC_NAME
-
-static int
-l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k)
-{
- register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
- register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
- int ok = 1;
- if (n <= 0)
- return (SCM_NULLP (lst));
- if (k < SCM_ARRAY_NDIM (ra) - 1)
- {
- while (n--)
- {
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return 0;
- ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1);
- base += inc;
- lst = SCM_CDR (lst);
- }
- if (SCM_NNULLP (lst))
- return 0;
- }
- else
- {
- while (n--)
- {
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return 0;
- scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base));
- base += inc;
- lst = SCM_CDR (lst);
- }
- if (SCM_NNULLP (lst))
- return 0;
- }
- return ok;
-}
-
-
-static void
-rapr1 (SCM ra,unsigned long j,unsigned long k,SCM port,scm_print_state *pstate)
-{
- long inc = 1;
- long n = (SCM_TYP7 (ra) == scm_tc7_smob
- ? 0
- : SCM_INUM (scm_uniform_vector_length (ra)));
- int enclosed = 0;
-tail:
- switch SCM_TYP7 (ra)
- {
- case scm_tc7_smob:
- if (enclosed++)
- {
- SCM_ARRAY_BASE (ra) = j;
- if (n-- > 0)
- scm_iprin1 (ra, port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- SCM_ARRAY_BASE (ra) = j;
- scm_iprin1 (ra, port, pstate);
- }
- break;
- }
- if (k + 1 < SCM_ARRAY_NDIM (ra))
- {
- long i;
- inc = SCM_ARRAY_DIMS (ra)[k].inc;
- for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
- {
- scm_putc ('(', port);
- rapr1 (ra, j, k + 1, port, pstate);
- scm_puts (") ", port);
- j += inc;
- }
- if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
- { /* could be zero size. */
- scm_putc ('(', port);
- rapr1 (ra, j, k + 1, port, pstate);
- scm_putc (')', port);
- }
- break;
- }
- if (SCM_ARRAY_NDIM (ra) > 0)
- { /* Could be zero-dimensional */
- inc = SCM_ARRAY_DIMS (ra)[k].inc;
- n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
- }
- else
- n = 1;
- ra = SCM_ARRAY_V (ra);
- goto tail;
- default:
- /* scm_tc7_bvect and scm_tc7_llvect only? */
- if (n-- > 0)
- scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
- }
- break;
- case scm_tc7_string:
- if (n-- > 0)
- scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate);
- if (SCM_WRITINGP (pstate))
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate);
- }
- else
- for (j += inc; n-- > 0; j += inc)
- scm_putc (SCM_STRING_CHARS (ra)[j], port);
- break;
- case scm_tc7_byvect:
- if (n-- > 0)
- scm_intprint (((char *) SCM_CELL_WORD_1 (ra))[j], 10, port);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- scm_intprint (((char *)SCM_CELL_WORD_1 (ra))[j], 10, port);
- }
- break;
-
- case scm_tc7_uvect:
- {
- char str[11];
-
- if (n-- > 0)
- {
- /* intprint can't handle >= 2^31. */
- sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
- scm_puts (str, port);
- }
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
- scm_puts (str, port);
- }
- }
- case scm_tc7_ivect:
- if (n-- > 0)
- scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
- }
- break;
-
- case scm_tc7_svect:
- if (n-- > 0)
- scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
- }
- break;
-
- case scm_tc7_fvect:
- if (n-- > 0)
- {
- SCM z = scm_make_real (1.0);
- SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
- scm_print_real (z, port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
- scm_print_real (z, port, pstate);
- }
- }
- break;
- case scm_tc7_dvect:
- if (n-- > 0)
- {
- SCM z = scm_make_real (1.0 / 3.0);
- SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
- scm_print_real (z, port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
- scm_print_real (z, port, pstate);
- }
- }
- break;
- case scm_tc7_cvect:
- if (n-- > 0)
- {
- SCM cz = scm_make_complex (0.0, 1.0), z = scm_make_real (1.0 / 3.0);
- SCM_REAL_VALUE (z) =
- SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
- SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
- scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
- port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_putc (' ', port);
- SCM_REAL_VALUE (z)
- = SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
- SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
- scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
- port, pstate);
- }
- }
- break;
- }
-}
-
-
-
-int
-scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
-{
- SCM v = exp;
- unsigned long base = 0;
- scm_putc ('#', port);
-tail:
- switch SCM_TYP7 (v)
- {
- case scm_tc7_smob:
- {
- long ndim = SCM_ARRAY_NDIM (v);
- base = SCM_ARRAY_BASE (v);
- v = SCM_ARRAY_V (v);
- if (SCM_ARRAYP (v))
-
- {
- scm_puts ("<enclosed-array ", port);
- rapr1 (exp, base, 0, port, pstate);
- scm_putc ('>', port);
- return 1;
- }
- else
- {
- scm_intprint (ndim, 10, port);
- goto tail;
- }
- }
- case scm_tc7_bvect:
- if (SCM_EQ_P (exp, v))
- { /* a uve, not an scm_array */
- register long i, j, w;
- scm_putc ('*', port);
- for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++)
- {
- scm_t_bits w = SCM_UNPACK (SCM_VELTS (exp)[i]);
- for (j = SCM_LONG_BIT; j; j--)
- {
- scm_putc (w & 1 ? '1' : '0', port);
- w >>= 1;
- }
- }
- j = SCM_BITVECTOR_LENGTH (exp) % SCM_LONG_BIT;
- if (j)
- {
- w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_LONG_BIT]);
- for (; j; j--)
- {
- scm_putc (w & 1 ? '1' : '0', port);
- w >>= 1;
- }
- }
- return 1;
- }
- else
- scm_putc ('b', port);
- break;
- case scm_tc7_string:
- scm_putc ('a', port);
- break;
- case scm_tc7_byvect:
- scm_putc ('y', port);
- break;
- case scm_tc7_uvect:
- scm_putc ('u', port);
- break;
- case scm_tc7_ivect:
- scm_putc ('e', port);
- break;
- case scm_tc7_svect:
- scm_putc ('h', port);
- break;
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
- scm_putc ('l', port);
- break;
-#endif
- case scm_tc7_fvect:
- scm_putc ('s', port);
- break;
- case scm_tc7_dvect:
- scm_putc ('i', port);
- break;
- case scm_tc7_cvect:
- scm_putc ('c', port);
- break;
- }
- scm_putc ('(', port);
- rapr1 (exp, base, 0, port, pstate);
- scm_putc (')', port);
- return 1;
-}
-
-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
-{
- int enclosed = 0;
- SCM_ASRTGO (SCM_NIMP (ra), badarg);
-loop:
- switch SCM_TYP7 (ra)
- {
- default:
- badarg:SCM_WRONG_TYPE_ARG (1, ra);
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
- if (enclosed++)
- return SCM_UNSPECIFIED;
- ra = SCM_ARRAY_V (ra);
- goto loop;
- case scm_tc7_vector:
- case scm_tc7_wvect:
- return SCM_EOL;
- case scm_tc7_bvect:
- return SCM_BOOL_T;
- case scm_tc7_string:
- return SCM_MAKE_CHAR ('a');
- case scm_tc7_byvect:
- return SCM_MAKE_CHAR ('\0');
- case scm_tc7_uvect:
- return SCM_MAKINUM (1L);
- case scm_tc7_ivect:
- return SCM_MAKINUM (-1L);
- case scm_tc7_svect:
- return scm_str2symbol ("s");
-#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
- return scm_str2symbol ("l");
-#endif
- case scm_tc7_fvect:
- return scm_make_real (1.0);
- case scm_tc7_dvect:
- return scm_make_real (1.0 / 3.0);
- case scm_tc7_cvect:
- return scm_make_complex (0.0, 1.0);
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-array_mark (SCM ptr)
-{
- return SCM_ARRAY_V (ptr);
-}
-
-
-static size_t
-array_free (SCM ptr)
-{
- scm_must_free (SCM_ARRAY_MEM (ptr));
- return sizeof (scm_t_array) +
- SCM_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim);
-}
-
-void
-scm_init_unif ()
-{
- scm_tc16_array = scm_make_smob_type ("array", 0);
- scm_set_smob_mark (scm_tc16_array, array_mark);
- scm_set_smob_free (scm_tc16_array, array_free);
- scm_set_smob_print (scm_tc16_array, scm_raprin1);
- scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p);
- scm_add_feature ("array");
-#ifndef SCM_MAGIC_SNARFER
-#include "libguile/unif.x"
-#endif
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006 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 2.1 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
+*/
+\f
+
+#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/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
+
+\f
+/* 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 },
+ { 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
+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
+ 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
+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
+ 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_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 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
+
+
+#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_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_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_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:
+*/
HCoop / bpt / guile.git / blobdiff