/* Copyright (C) 1995,1996,1997,1998 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 */ #include #include "_scm.h" #include "chars.h" #include "eval.h" #include "fports.h" #include "smob.h" #include "strop.h" #include "feature.h" #include "scm_validate.h" #include "unif.h" #include "ramap.h" #ifdef HAVE_UNISTD_H #include #endif /* 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 */ long scm_tc16_array; /* return the size of an element in a uniform array or 0 if type not found. */ scm_sizet scm_uniform_element_size (SCM obj) { scm_sizet 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 #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: result = sizeof (float); break; #endif case scm_tc7_dvect: result = sizeof (double); break; case scm_tc7_cvect: result = 2 * sizeof (double); break; #endif default: result = 0; } return result; } #ifdef SCM_FLOATS #ifdef SCM_SINGLES SCM scm_makflo (float x) { SCM z; if (x == 0.0) return scm_flo0; SCM_NEWCELL (z); SCM_DEFER_INTS; SCM_SETCAR (z, scm_tc_flo); SCM_FLO (z) = x; SCM_ALLOW_INTS; return z; } #endif #endif SCM scm_make_uve (long k, SCM prot) { SCM v; long i, type; if (SCM_BOOL_T == prot) { i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); type = scm_tc7_bvect; } else if (SCM_ICHRP (prot) && (prot == SCM_MAKICHR ('\0'))) { i = sizeof (char) * k; type = scm_tc7_byvect; } else if (SCM_ICHRP (prot)) { i = sizeof (char) * k; type = scm_tc7_string; } 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_LENGTH (prot))) { char s; s = SCM_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_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED); } } else #ifdef SCM_FLOATS if (SCM_IMP (prot) || !SCM_INEXP (prot)) #endif /* Huge non-unif vectors are NOT supported. */ /* no special scm_vector */ return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED); #ifdef SCM_FLOATS #ifdef SCM_SINGLES else if (SCM_SINGP (prot)) { i = sizeof (float) * k; type = scm_tc7_fvect; } #endif else if (SCM_CPLXP (prot)) { i = 2 * sizeof (double) * k; type = scm_tc7_cvect; } else { i = sizeof (double) * k; type = scm_tc7_dvect; } #endif SCM_NEWCELL (v); SCM_DEFER_INTS; SCM_SETCHARS (v, (char *) scm_must_malloc (i ? i : 1, "vector")); SCM_SETLENGTH (v, (k < SCM_LENGTH_MAX ? k : SCM_LENGTH_MAX), type); SCM_ALLOW_INTS; return v; } SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, (SCM v), "Returns 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_WTA(1,v); 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_vector: case scm_tc7_wvect: case scm_tc7_svect: #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: #endif return SCM_MAKINUM (SCM_LENGTH (v)); } } #undef FUNC_NAME SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, (SCM v, SCM prot), "Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not.\n\n" "The @var{prototype} argument is used with uniform arrays and is described\n" "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; loop: switch (SCM_TYP7 (v)) { case 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); goto loop; case scm_tc7_bvect: return nprot || SCM_BOOL(SCM_BOOL_T==prot); case scm_tc7_string: return nprot || SCM_BOOL(SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'))); case scm_tc7_byvect: return nprot || SCM_BOOL(prot == SCM_MAKICHR('\0')); case scm_tc7_uvect: return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)>0); case scm_tc7_ivect: return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)<=0); case scm_tc7_svect: return ( nprot || (SCM_SYMBOLP (prot) && (1 == SCM_LENGTH (prot)) && ('s' == SCM_CHARS (prot)[0]))); #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: return ( nprot || (SCM_SYMBOLP (prot) && (1 == SCM_LENGTH (prot)) && ('s' == SCM_CHARS (prot)[0]))); #endif # ifdef SCM_FLOATS # ifdef SCM_SINGLES case scm_tc7_fvect: return nprot || SCM_BOOL(SCM_SINGP(prot)); # endif case scm_tc7_dvect: return nprot || SCM_BOOL(SCM_REALP(prot)); case scm_tc7_cvect: return nprot || SCM_BOOL(SCM_CPLXP(prot)); # endif case scm_tc7_vector: case scm_tc7_wvect: return nprot || SCM_BOOL(SCM_NULLP(prot)); default:; } return SCM_BOOL_F; } #undef FUNC_NAME SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, (SCM ra), "Returns the number of dimensions of @var{obj}. If @var{obj} is not an\n" "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" "@example\n" "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n" "@end example") #define FUNC_NAME s_scm_array_dimensions { SCM res = SCM_EOL; scm_sizet k; scm_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_MAKINUM (SCM_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 static char s_bad_ind[] = "Bad scm_array index"; long scm_aind (SCM ra, SCM args, const char *what) { SCM ind; register long j; register scm_sizet pos = SCM_ARRAY_BASE (ra); register scm_sizet k = SCM_ARRAY_NDIM (ra); scm_array_dim *s = SCM_ARRAY_DIMS (ra); if (SCM_INUMP (args)) { SCM_ASSERT (1 == k, scm_makfrom0str (what), SCM_WNA, NULL); return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); } while (k && SCM_NIMP (args)) { ind = SCM_CAR (args); args = SCM_CDR (args); SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, what); j = SCM_INUM (ind); SCM_ASSERT (j >= (s->lbnd) && j <= (s->ubnd), ind, SCM_OUTOFRANGE, what); pos += (j - s->lbnd) * (s->inc); k--; s++; } SCM_ASSERT (0 == k && SCM_NULLP (args), scm_makfrom0str (what), SCM_WNA, NULL); return pos; } SCM scm_make_ra (int ndim) { SCM ra; SCM_NEWCELL (ra); SCM_DEFER_INTS; SCM_NEWSMOB(ra, ((long) ndim << 17) + scm_tc16_array, scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_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_array_dim *s; SCM ra, spec, sp; int ndim = scm_ilength (args); SCM_ASSERT (0 <= ndim, args, s_bad_spec, what); ra = scm_make_ra (ndim); SCM_ARRAY_BASE (ra) = 0; s = SCM_ARRAY_DIMS (ra); for (; SCM_NIMP (args); s++, args = SCM_CDR (args)) { spec = SCM_CAR (args); if (SCM_IMP (spec)) { SCM_ASSERT (SCM_INUMP (spec) && SCM_INUM (spec) >= 0, spec, s_bad_spec, what); s->lbnd = 0; s->ubnd = SCM_INUM (spec) - 1; s->inc = 1; } else { SCM_ASSERT (SCM_CONSP (spec) && SCM_INUMP (SCM_CAR (spec)), spec, s_bad_spec, what); s->lbnd = SCM_INUM (SCM_CAR (spec)); sp = SCM_CDR (spec); SCM_ASSERT (SCM_CONSP (sp) && SCM_INUMP (SCM_CAR (sp)) && SCM_NULLP (SCM_CDR (sp)), spec, s_bad_spec, what); 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" "Creates and returns a uniform array or vector of type corresponding to\n" "@var{prototype} with dimensions @var{dims} or length @var{length}. If\n" "@var{fill} is supplied, it's used to fill the array, otherwise \n" "@var{prototype} is used.") #define FUNC_NAME s_scm_dimensions_to_uniform_array { scm_sizet k, vlen = 1; long rlen = 1; scm_array_dim *s; SCM ra; if (SCM_INUMP (dims)) { if (SCM_INUM (dims) < SCM_LENGTH_MAX) { 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; } else dims = scm_cons (dims, SCM_EOL); } SCM_ASSERT (SCM_NULLP (dims) || SCM_CONSP (dims), dims, SCM_ARG1, FUNC_NAME); ra = scm_shap2ra (dims, FUNC_NAME); SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS); s = SCM_ARRAY_DIMS (ra); k = SCM_ARRAY_NDIM (ra); while (k--) { s[k].inc = (rlen > 0 ? rlen : 0); rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; vlen *= (s[k].ubnd - s[k].lbnd + 1); } if (rlen < SCM_LENGTH_MAX) SCM_ARRAY_V (ra) = scm_make_uve ((rlen > 0 ? rlen : 0L), prot); else { scm_sizet bit; switch (SCM_TYP7 (scm_make_uve (0L, prot))) { default: bit = SCM_LONG_BIT; break; case scm_tc7_bvect: bit = 1; break; case scm_tc7_string: bit = SCM_CHAR_BIT; break; case scm_tc7_fvect: bit = sizeof (float) * SCM_CHAR_BIT / sizeof (char); break; case scm_tc7_dvect: bit = sizeof (double) * SCM_CHAR_BIT / sizeof (char); break; case scm_tc7_cvect: bit = 2 * sizeof (double) * SCM_CHAR_BIT / sizeof (char); break; } SCM_ARRAY_BASE (ra) = (SCM_LONG_BIT + bit - 1) / bit; rlen += SCM_ARRAY_BASE (ra); SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot); *((long *) SCM_VELTS (SCM_ARRAY_V (ra))) = rlen; } 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) { scm_sizet 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_SETAND_CAR (ra, ~SCM_ARRAY_CONTIGUOUS); return; } inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1); } } SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS); } 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" "@example\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 example") #define FUNC_NAME s_scm_make_shared_array { SCM ra; SCM inds, indptr; SCM imap; scm_sizet i, k; long old_min, new_min, old_max, new_max; scm_array_dim *s; 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 = (long) SCM_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 (mapfunc, scm_reverse (inds), SCM_EOL); if (SCM_ARRAYP (oldra)) i = (scm_sizet) scm_aind (oldra, imap, FUNC_NAME); else { if (SCM_NINUMP (imap)) { SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), imap, s_bad_ind, FUNC_NAME); 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 (mapfunc, scm_reverse (inds), SCM_EOL); if (SCM_ARRAYP (oldra)) s[k].inc = scm_aind (oldra, imap, FUNC_NAME) - i; else { if (SCM_NINUMP (imap)) { SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), imap, s_bad_ind, FUNC_NAME); 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); } SCM_ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED, "mapping out of range", FUNC_NAME); if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) { if (1 == s->inc && 0 == s->lbnd && SCM_LENGTH (SCM_ARRAY_V (ra)) == 1 + s->ubnd) return SCM_ARRAY_V (ra); 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", 0, 0, 1, (SCM args), "Returns an array sharing contents with @var{array}, but with dimensions\n" "arranged in a different order. There must be one @var{dim} argument for\n" "each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should\n" "be integers between 0 and the rank of the array to be returned. Each\n" "integer in that range must appear at least once in the argument list.\n\n" "The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions\n" "in the array to be returned, their positions in the argument list to\n" "dimensions of @var{array}. Several @var{dim}s may have the same value,\n" "in which case the returned array will have smaller rank than\n" "@var{array}.\n\n" "examples:\n" "@example\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 example") #define FUNC_NAME s_scm_transpose_array { SCM ra, res, vargs, *ve = &vargs; scm_array_dim *s, *r; int ndim, i, k; SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); ra = SCM_CAR (args); SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); args = SCM_CDR (args); switch (SCM_TYP7 (ra)) { default: badarg:SCM_WTA (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 SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)), scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2, FUNC_NAME); SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_OUTOFRANGE, FUNC_NAME); return ra; case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (ra), badarg); vargs = scm_vector (args); SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); 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]); SCM_ASSERT (i >= 0 && i < SCM_ARRAY_NDIM (ra), ve[k], SCM_OUTOFRANGE, FUNC_NAME); 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; } } SCM_ASSERT (ndim <= 0, args, "bad argument list", FUNC_NAME); scm_ra_set_contp (res); return res; } } #undef FUNC_NAME /* args are RA . AXES */ SCM_DEFINE (scm_enclose_array, "enclose-array", 0, 0, 1, (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" "@example\n" "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n" " #\n\n" "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n" " #\n" "@end example") #define FUNC_NAME s_scm_enclose_array { SCM axv, ra, res, ra_inr; scm_array_dim vdim, *s = &vdim; int ndim, j, k, ninr, noutr; SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); ra = SCM_CAR (axes); axes = SCM_CDR (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); ra_inr = scm_make_ra (ninr); SCM_ASRTGO (SCM_NIMP (ra), badarg1); switch SCM_TYP7 (ra) { default: badarg1:SCM_WTA (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_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; axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0)); SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); 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)) { SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", FUNC_NAME); 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_CHARS (axv)[j] = 1; } for (j = 0, k = 0; k < noutr; k++, j++) { while (SCM_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?", 0, 0, 1, (SCM args), "Returns @code{#t} if its arguments would be acceptable to array-ref.") #define FUNC_NAME s_scm_array_in_bounds_p { SCM v, ind = SCM_EOL; long pos = 0; register scm_sizet k; register long j; scm_array_dim *s; SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); v = SCM_CAR (args); args = SCM_CDR (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_WTA (1,v); wna: scm_wrong_num_args (scm_makfrom0str (FUNC_NAME)); 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++; SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, FUNC_NAME); } 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: SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna); return SCM_BOOL(pos >= 0 && pos < SCM_LENGTH (v)); } } #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), "Returns the element at the @code{(index1, index2)} element in @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 { 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); } SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); } switch SCM_TYP7 (v) { default: if (SCM_NULLP (args)) return v; badarg: SCM_WTA (1,v); abort (); outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); wna: scm_wrong_num_args (SCM_FUNC_NAME); 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_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT))) return SCM_BOOL_T; else return SCM_BOOL_F; case scm_tc7_string: return SCM_MAKICHR (SCM_UCHARS (v)[pos]); case scm_tc7_byvect: return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); # ifdef SCM_INUMS_ONLY case scm_tc7_uvect: case scm_tc7_ivect: return SCM_MAKINUM (SCM_VELTS (v)[pos]); # else case scm_tc7_uvect: return scm_ulong2num(SCM_VELTS(v)[pos]); case scm_tc7_ivect: return scm_long2num(SCM_VELTS(v)[pos]); # endif case scm_tc7_svect: return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]); #endif #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: return scm_makflo (((float *) SCM_CDR (v))[pos]); #endif case scm_tc7_dvect: return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); case scm_tc7_cvect: return scm_makdbl (((double *) SCM_CDR (v))[2 * pos], ((double *) SCM_CDR (v))[2 * pos + 1]); #endif 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, scm_sizet pos, SCM last) { switch SCM_TYP7 (v) { default: scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref"); case scm_tc7_bvect: if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT))) return SCM_BOOL_T; else return SCM_BOOL_F; case scm_tc7_string: return SCM_MAKICHR (SCM_UCHARS (v)[pos]); case scm_tc7_byvect: return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); # ifdef SCM_INUMS_ONLY case scm_tc7_uvect: case scm_tc7_ivect: return SCM_MAKINUM (SCM_VELTS (v)[pos]); # else case scm_tc7_uvect: return scm_ulong2num(SCM_VELTS(v)[pos]); case scm_tc7_ivect: return scm_long2num(SCM_VELTS(v)[pos]); # endif case scm_tc7_svect: return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]); #endif #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CAR (last))) { SCM_FLO (last) = ((float *) SCM_CDR (v))[pos]; return last; } return scm_makflo (((float *) SCM_CDR (v))[pos]); #endif case scm_tc7_dvect: #ifdef SCM_SINGLES if (SCM_NIMP (last) && scm_tc_dblr == SCM_CAR (last)) #else if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last))) #endif { SCM_REAL (last) = ((double *) SCM_CDR (v))[pos]; return last; } return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); case scm_tc7_cvect: if (SCM_NIMP (last) && scm_tc_dblc == SCM_CAR (last)) { SCM_REAL (last) = ((double *) SCM_CDR (v))[2 * pos]; SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1]; return last; } return scm_makdbl (((double *) SCM_CDR (v))[2 * pos], ((double *) SCM_CDR (v))[2 * pos + 1]); #endif 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; } } } 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), "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_ASRTGO (SCM_NIMP (v), badarg1); if (SCM_ARRAYP (v)) { pos = scm_aind (v, args, FUNC_NAME); v = SCM_ARRAY_V (v); } else { 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); } SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); } switch (SCM_TYP7 (v)) { default: badarg1: SCM_WTA (1,v); abort (); outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); wna: scm_wrong_num_args (SCM_FUNC_NAME); case scm_tc7_smob: /* enclosed */ goto badarg1; case scm_tc7_bvect: if (SCM_BOOL_F == obj) SCM_VELTS (v)[pos / SCM_LONG_BIT] &= ~(1L << (pos % SCM_LONG_BIT)); else if (SCM_BOOL_T == obj) SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT)); else badobj:SCM_WTA (2,obj); break; case scm_tc7_string: SCM_ASRTGO (SCM_ICHRP (obj), badobj); SCM_UCHARS (v)[pos] = SCM_ICHR (obj); break; case scm_tc7_byvect: if (SCM_ICHRP (obj)) obj = SCM_MAKINUM ((char) SCM_ICHR (obj)); SCM_ASRTGO (SCM_INUMP (obj), badobj); ((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj); break; # ifdef SCM_INUMS_ONLY case scm_tc7_uvect: SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj); /* fall through */ case scm_tc7_ivect: SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); break; # else case scm_tc7_uvect: SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME); break; case scm_tc7_ivect: SCM_VELTS(v)[pos] = scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME); break; # endif case scm_tc7_svect: SCM_ASRTGO (SCM_INUMP (obj), badobj); ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj); break; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, FUNC_NAME); break; #endif #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: ((float *) SCM_CDR (v))[pos] = (float)scm_num2dbl(obj, FUNC_NAME); break; break; #endif case scm_tc7_dvect: ((double *) SCM_CDR (v))[pos] = scm_num2dbl(obj, FUNC_NAME); break; break; case scm_tc7_cvect: SCM_ASRTGO (SCM_INEXP (obj), badobj); ((double *) SCM_CDR (v))[2 * pos] = SCM_REALPART (obj); ((double *) SCM_CDR (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0; break; #endif 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: { scm_sizet 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_LENGTH (SCM_ARRAY_V (ra)) || SCM_ARRAY_BASE (ra) % SCM_LONG_BIT || len % SCM_LONG_BIT) return SCM_BOOL_F; } } if ((len == SCM_LENGTH (SCM_ARRAY_V (ra))) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc) return SCM_ARRAY_V (ra); 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; scm_sizet 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 (ra)) return ra; if ((len == SCM_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; 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_LENGTH (v); loop: switch SCM_TYP7 (v) { default: badarg1:SCM_WTA (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: case scm_tc7_byvect: sz = sizeof (char); break; case scm_tc7_bvect: vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; cstart /= SCM_LONG_BIT; case scm_tc7_uvect: case scm_tc7_ivect: sz = sizeof (long); break; case scm_tc7_svect: sz = sizeof (short); break; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: sz = sizeof (long_long); break; #endif #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: sz = sizeof (float); break; #endif case scm_tc7_dvect: sz = sizeof (double); break; case scm_tc7_cvect: sz = 2 * sizeof (double); break; #endif } 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_port *pt = SCM_PTAB_ENTRY (port_or_fd); int remaining = (cend - offset) * sz; char *dest = SCM_CHARS (v) + (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), SCM_CHARS (v) + (cstart + offset) * sz, (scm_sizet) (sz * (cend - offset)))); if (ans == -1) SCM_SYSERROR; } if (SCM_TYP7 (v) == scm_tc7_bvect) ans *= SCM_LONG_BIT; if (v != ra && 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; 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_LENGTH (v); loop: switch SCM_TYP7 (v) { default: badarg1:SCM_WTA (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: case scm_tc7_byvect: sz = sizeof (char); break; case scm_tc7_bvect: vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; cstart /= SCM_LONG_BIT; case scm_tc7_uvect: case scm_tc7_ivect: sz = sizeof (long); break; case scm_tc7_svect: sz = sizeof (short); break; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: sz = sizeof (long_long); break; #endif #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: sz = sizeof (float); break; #endif case scm_tc7_dvect: sz = sizeof (double); break; case scm_tc7_cvect: sz = 2 * sizeof (double); break; #endif } 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 = SCM_CHARS (v) + (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), SCM_CHARS (v) + (cstart + offset) * sz, (scm_sizet) (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 item, SCM seq), "Returns the number occurrences of @var{bool} in @var{bv}.") #define FUNC_NAME s_scm_bit_count { long i; register unsigned long cnt = 0, w; SCM_VALIDATE_INUM (2,seq); switch SCM_TYP7 (seq) { default: SCM_WTA (2,seq); case scm_tc7_bvect: if (0 == SCM_LENGTH (seq)) return SCM_INUM0; i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT; w = SCM_VELTS (seq)[i]; if (SCM_FALSEP (item)) w = ~w; w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT); while (!0) { for (; w; w >>= 4) cnt += cnt_tab[w & 0x0f]; if (0 == i--) return SCM_MAKINUM (cnt); w = SCM_VELTS (seq)[i]; if (SCM_FALSEP (item)) w = ~w; } } } #undef FUNC_NAME SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, (SCM item, SCM v, SCM k), "Returns the minimum index of an occurrence of @var{bool} in @var{bv}\n" "which is at least @var{k}. If no @var{bool} occurs within the specified\n" "range @code{#f} is returned.") #define FUNC_NAME s_scm_bit_position { long i, lenw, xbits, pos; register unsigned long w; SCM_VALIDATE_NIM (2,v); SCM_VALIDATE_INUM_COPY (3,k,pos); SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0), k, SCM_OUTOFRANGE, FUNC_NAME); if (pos == SCM_LENGTH (v)) return SCM_BOOL_F; switch SCM_TYP7 (v) { default: SCM_WTA (2,v); case scm_tc7_bvect: if (0 == SCM_LENGTH (v)) return SCM_MAKINUM (-1L); lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */ i = pos / SCM_LONG_BIT; w = 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_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_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 length. If\n" "@var{bool} is @code{#t}, uve is OR'ed into @var{bv}; If @var{bool} is @code{#f}, the\n" "inversion of uve is AND'ed into @var{bv}.\n\n" "If uve is a unsigned integer vector all the elements of uve must be\n" "between 0 and the @code{LENGTH} of @var{bv}. The bits of @var{bv}\n" "corresponding to the indexes in uve are set to @var{bool}.\n\n" "The return value is unspecified.") #define FUNC_NAME s_scm_bit_set_star_x { register long i, k, vlen; SCM_ASRTGO (SCM_NIMP (v), badarg1); SCM_ASRTGO (SCM_NIMP (kv), badarg2); switch SCM_TYP7 (kv) { default: badarg2:SCM_WTA (2,kv); case scm_tc7_uvect: switch SCM_TYP7 (v) { default: badarg1:SCM_WTA (1,v); case scm_tc7_bvect: vlen = SCM_LENGTH (v); if (SCM_BOOL_F == obj) for (i = SCM_LENGTH (kv); i;) { k = SCM_VELTS (kv)[--i]; SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT)); } else if (SCM_BOOL_T == obj) for (i = SCM_LENGTH (kv); i;) { k = SCM_VELTS (kv)[--i]; SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT)); } else badarg3:SCM_WTA (3,obj); } break; case scm_tc7_bvect: SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); if (SCM_BOOL_F == obj) for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) SCM_VELTS (v)[k] &= ~(SCM_VELTS (kv)[k]); else if (SCM_BOOL_T == obj) for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) SCM_VELTS (v)[k] |= SCM_VELTS (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), "Returns\n" "@example\n" "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n" "@end example\n" "@var{bv} is not modified.") #define FUNC_NAME s_scm_bit_count_star { register long i, vlen, count = 0; register unsigned long k; SCM_ASRTGO (SCM_NIMP (v), badarg1); SCM_ASRTGO (SCM_NIMP (kv), badarg2); switch SCM_TYP7 (kv) { default: badarg2:SCM_WTA (2,kv); case scm_tc7_uvect: switch SCM_TYP7 (v) { default: badarg1:SCM_WTA (1,v); case scm_tc7_bvect: vlen = SCM_LENGTH (v); if (SCM_BOOL_F == obj) for (i = SCM_LENGTH (kv); i;) { k = SCM_VELTS (kv)[--i]; SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))) count++; } else if (SCM_BOOL_T == obj) for (i = SCM_LENGTH (kv); i;) { k = SCM_VELTS (kv)[--i]; SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))) count++; } else badarg3:SCM_WTA (3,obj); } break; case scm_tc7_bvect: SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); if (0 == SCM_LENGTH (v)) return SCM_INUM0; SCM_ASRTGO (SCM_BOOL_T == obj || SCM_BOOL_F == obj, badarg3); obj = (SCM_BOOL_T == obj); i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]); k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT); while (!0) { for (; k; k >>= 4) count += cnt_tab[k & 0x0f]; if (0 == i--) return SCM_MAKINUM (count); k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~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 { register long k; SCM_ASRTGO (SCM_NIMP (v), badarg1); k = SCM_LENGTH (v); switch SCM_TYP7 (v) { case scm_tc7_bvect: for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k]; break; default: badarg1:SCM_WTA (1,v); } 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,scm_sizet base,scm_sizet k) { register SCM res = SCM_EOL; register long inc = SCM_ARRAY_DIMS (ra)[k].inc; register scm_sizet 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_array_to_list, "array->list", 1, 0, 0, (SCM v), "Returns a list consisting of all the elements, in order, of @var{array}.") #define FUNC_NAME s_scm_array_to_list { SCM res = SCM_EOL; register long k; SCM_ASRTGO (SCM_NIMP (v), badarg1); switch SCM_TYP7 (v) { default: badarg1:SCM_WTA (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_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_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1) res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); return res; } # ifdef SCM_INUMS_ONLY case scm_tc7_uvect: case scm_tc7_ivect: { long *data = (long *) SCM_VELTS (v); for (k = SCM_LENGTH (v) - 1; k >= 0; k--) res = scm_cons (SCM_MAKINUM (data[k]), res); return res; } # else case scm_tc7_uvect: { long *data = (long *)SCM_VELTS(v); for (k = SCM_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_LENGTH(v) - 1; k >= 0; k--) res = scm_cons(scm_long2num(data[k]), res); return res; } # endif case scm_tc7_svect: { short *data; data = (short *)SCM_VELTS(v); for (k = SCM_LENGTH(v) - 1; k >= 0; k--) res = scm_cons(SCM_MAKINUM (data[k]), res); return res; } #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: { long_long *data; data = (long_long *)SCM_VELTS(v); for (k = SCM_LENGTH(v) - 1; k >= 0; k--) res = scm_cons(scm_long_long2num(data[k]), res); return res; } #endif #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: { float *data = (float *) SCM_VELTS (v); for (k = SCM_LENGTH (v) - 1; k >= 0; k--) res = scm_cons (scm_makflo (data[k]), res); return res; } #endif /*SCM_SINGLES*/ case scm_tc7_dvect: { double *data = (double *) SCM_VELTS (v); for (k = SCM_LENGTH (v) - 1; k >= 0; k--) res = scm_cons (scm_makdbl (data[k], 0.0), res); return res; } case scm_tc7_cvect: { double (*data)[2] = (double (*)[2]) SCM_VELTS (v); for (k = SCM_LENGTH (v) - 1; k >= 0; k--) res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res); return res; } #endif /*SCM_FLOATS*/ } } #undef FUNC_NAME static char s_bad_ralst[] = "Bad scm_array contents list"; static int l2ra(SCM lst, SCM ra, scm_sizet base, scm_sizet 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" "Returns a uniform array of the type indicated by prototype @var{prot}\n" "with elements the same as those of @var{lst}. Elements must be of the\n" "appropriate type, no coercions are done.") #define FUNC_NAME s_scm_list_to_uniform_array { SCM shp = SCM_EOL; SCM row = lst; SCM ra; scm_sizet 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)) { for (k = 0; k < SCM_LENGTH (ra); 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_wta (lst, s_bad_ralst, FUNC_NAME); return SCM_BOOL_F; } #undef FUNC_NAME static int l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet 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_EOL == 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; ok = ok && 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,scm_sizet j,scm_sizet k,SCM port,scm_print_state *pstate) { long inc = 1; long n = SCM_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) { /* 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_MAKICHR (SCM_UCHARS (ra)[j]), port, pstate); if (SCM_WRITINGP (pstate)) for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); scm_iprin1 (SCM_MAKICHR (SCM_UCHARS (ra)[j]), port, pstate); } else for (j += inc; n-- > 0; j += inc) scm_putc (SCM_CHARS (ra)[j], port); break; case scm_tc7_byvect: if (n-- > 0) scm_intprint (((char *)SCM_CDR (ra))[j], 10, port); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); scm_intprint (((char *)SCM_CDR (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 (SCM_VELTS (ra)[j], 10, port); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); scm_intprint (SCM_VELTS (ra)[j], 10, port); } break; case scm_tc7_svect: if (n-- > 0) scm_intprint (((short *)SCM_CDR (ra))[j], 10, port); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); scm_intprint (((short *)SCM_CDR (ra))[j], 10, port); } break; #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: if (n-- > 0) { SCM z = scm_makflo (1.0); SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j]; scm_floprint (z, port, pstate); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j]; scm_floprint (z, port, pstate); } } break; #endif /*SCM_SINGLES*/ case scm_tc7_dvect: if (n-- > 0) { SCM z = scm_makdbl (1.0 / 3.0, 0.0); SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j]; scm_floprint (z, port, pstate); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j]; scm_floprint (z, port, pstate); } } break; case scm_tc7_cvect: if (n-- > 0) { SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0); SCM_REAL (z) = SCM_REAL (cz) = (((double *) SCM_VELTS (ra))[2 * j]); SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j]; SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate); } } break; #endif /*SCM_FLOATS*/ } } int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) { SCM v = exp; scm_sizet 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 ("', port); return 1; } else { scm_intprint (ndim, 10, port); goto tail; } } case scm_tc7_bvect: if (exp == v) { /* a uve, not an scm_array */ register long i, j, w; scm_putc ('*', port); for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++) { w = SCM_VELTS (exp)[i]; for (j = SCM_LONG_BIT; j; j--) { scm_putc (w & 1 ? '1' : '0', port); w >>= 1; } } j = SCM_LENGTH (exp) % SCM_LONG_BIT; if (j) { w = SCM_VELTS (exp)[SCM_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 #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: scm_putc ('s', port); break; #endif /*SCM_SINGLES*/ case scm_tc7_dvect: scm_putc ('i', port); break; case scm_tc7_cvect: scm_putc ('c', port); break; #endif /*SCM_FLOATS*/ } 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), "Returns an object that would produce an array of the same type as\n" "@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_WTA (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_MAKICHR ('a'); case scm_tc7_byvect: return SCM_MAKICHR ('\0'); case scm_tc7_uvect: return SCM_MAKINUM (1L); case scm_tc7_ivect: return SCM_MAKINUM (-1L); case scm_tc7_svect: return SCM_CDR (scm_intern ("s", 1)); #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: return SCM_CDR (scm_intern ("l", 1)); #endif #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: return scm_makflo (1.0); #endif case scm_tc7_dvect: return scm_makdbl (1.0 / 3.0, 0.0); case scm_tc7_cvect: return scm_makdbl (0.0, 1.0); #endif } } #undef FUNC_NAME static SCM markra (SCM ptr) { return SCM_ARRAY_V (ptr); } static scm_sizet freera (SCM ptr) { scm_must_free (SCM_CHARS (ptr)); return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim); } void scm_init_unif () { scm_tc16_array = scm_make_smob_type_mfpe ("array", 0, markra, freera, scm_raprin1, scm_array_equal_p); scm_add_feature ("array"); #include "unif.x" }