X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/a3a329390f25cf1ea73f639a7967f7eb0b3a3d8f..eb7e1603ad497d0efff686e26e23af987c567721:/libguile/unif.c diff --git a/libguile/unif.c b/libguile/unif.c index 6d9fc67e7..8944697d3 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1,46 +1,20 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004 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. + * 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. * - * 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. + * 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. * - * 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. */ + * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ -/* 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, @@ -51,7 +25,14 @@ */ +#if HAVE_CONFIG_H +# include +#endif + #include +#include +#include + #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/eval.h" @@ -71,6 +52,10 @@ #include #endif +#ifdef HAVE_IO_H +#include +#endif + /* The set of uniform scm_vector types is: * Vector of: Called: @@ -86,14 +71,15 @@ * long long llvect */ -long scm_tc16_array; +scm_t_bits scm_tc16_array; +static SCM exactly_one_third; /* return the size of an element in a uniform array or 0 if type not found. */ -scm_sizet +size_t scm_uniform_element_size (SCM obj) { - scm_sizet result; + size_t result; switch (SCM_TYP7 (obj)) { @@ -111,9 +97,9 @@ scm_uniform_element_size (SCM obj) result = sizeof (short); break; -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: - result = sizeof (long_long); + result = sizeof (long long); break; #endif @@ -141,7 +127,7 @@ scm_uniform_element_size (SCM obj) static int singp (SCM obj) { - if (!SCM_SLOPPY_REALP (obj)) + if (!SCM_REALP (obj)) return 0; else { @@ -151,37 +137,49 @@ singp (SCM obj) } } -SCM -scm_make_uve (long k, SCM prot) +static const char s_scm_make_uve[]; + +static SCM +make_uve (long type, long k, size_t size) #define FUNC_NAME "scm_make_uve" { - SCM v; - long i, type; + SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH); - SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_LENGTH_MAX); + return scm_cell (SCM_MAKE_UVECTOR_TAG (k, type), + (scm_t_bits) scm_gc_malloc (k * size, "vector")); +} +#undef FUNC_NAME +SCM +scm_make_uve (long k, SCM prot) +#define FUNC_NAME "scm_make_uve" +{ if (SCM_EQ_P (prot, SCM_BOOL_T)) { - i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - type = scm_tc7_bvect; + if (k > 0) + { + long i; + SCM_ASSERT_RANGE (1, + scm_long2num (k), k <= SCM_BITVECTOR_MAX_LENGTH); + i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); + return scm_cell (SCM_MAKE_BITVECTOR_TAG (k), + (scm_t_bits) scm_gc_malloc (i, "vector")); + } + else + return scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0); } else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0')) - { - i = sizeof (char) * k; - type = scm_tc7_byvect; - } + return make_uve (scm_tc7_byvect, k, sizeof (char)); else if (SCM_CHARP (prot)) - { - i = sizeof (char) * k; - type = scm_tc7_string; - } + return scm_allocate_string (sizeof (char) * k); else if (SCM_INUMP (prot)) + return make_uve (SCM_INUM (prot) > 0 ? scm_tc7_uvect : scm_tc7_ivect, + k, + sizeof (long)); + else if (SCM_FRACTIONP (prot)) { - i = sizeof (long) * k; - if (SCM_INUM (prot) > 0) - type = scm_tc7_uvect; - else - type = scm_tc7_ivect; + if (scm_num_eq_p (exactly_one_third, prot)) + goto dvect; } else if (SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot))) { @@ -189,63 +187,37 @@ scm_make_uve (long k, SCM prot) s = SCM_SYMBOL_CHARS (prot)[0]; if (s == 's') - { - i = sizeof (short) * k; - type = scm_tc7_svect; - } -#ifdef HAVE_LONG_LONGS + return make_uve (scm_tc7_svect, k, sizeof (short)); +#if SCM_SIZEOF_LONG_LONG != 0 else if (s == 'l') - { - i = sizeof (long_long) * k; - type = scm_tc7_llvect; - } + return make_uve (scm_tc7_llvect, k, sizeof (long long)); #endif else - { - return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED); - } + return scm_c_make_vector (k, SCM_UNDEFINED); } - else - if (SCM_IMP (prot) || !SCM_INEXACTP (prot)) + else if (!SCM_INEXACTP (prot)) /* Huge non-unif vectors are NOT supported. */ /* no special scm_vector */ - return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED); + return scm_c_make_vector (k, SCM_UNDEFINED); else if (singp (prot)) - { - i = sizeof (float) * k; - type = scm_tc7_fvect; - } + return make_uve (scm_tc7_fvect, k, sizeof (float)); else if (SCM_COMPLEXP (prot)) - { - i = 2 * sizeof (double) * k; - type = scm_tc7_cvect; - } - else - { - i = sizeof (double) * k; - type = scm_tc7_dvect; - } - - SCM_NEWCELL (v); - SCM_DEFER_INTS; - SCM_SETCHARS (v, (char *) scm_must_malloc (i ? i : 1, "vector")); - SCM_SETLENGTH (v, k, type); - SCM_ALLOW_INTS; - return v; + return make_uve (scm_tc7_cvect, k, 2 * sizeof (double)); + dvect: + return make_uve (scm_tc7_dvect, k, sizeof (double)); } #undef FUNC_NAME - SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, - (SCM v), - "Returns the number of elements in @var{uve}.") + (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_WTA(1,v); + badarg1:SCM_WRONG_TYPE_ARG (1, v); case scm_tc7_vector: case scm_tc7_wvect: return SCM_MAKINUM (SCM_VECTOR_LENGTH (v)); @@ -260,7 +232,7 @@ SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, case scm_tc7_dvect: case scm_tc7_cvect: case scm_tc7_svect: -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: #endif return SCM_MAKINUM (SCM_UVECTOR_LENGTH (v)); @@ -270,9 +242,9 @@ SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, 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.") + "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; @@ -302,34 +274,46 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, { case scm_tc7_bvect: protp = (SCM_EQ_P (prot, SCM_BOOL_T)); + break; case scm_tc7_string: protp = SCM_CHARP(prot) && (SCM_CHAR (prot) != '\0'); + break; case scm_tc7_byvect: protp = SCM_EQ_P (prot, SCM_MAKE_CHAR ('\0')); + break; case scm_tc7_uvect: protp = SCM_INUMP(prot) && SCM_INUM(prot)>0; + break; case scm_tc7_ivect: protp = SCM_INUMP(prot) && SCM_INUM(prot)<=0; - + break; case scm_tc7_svect: protp = SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot)) && ('s' == SCM_SYMBOL_CHARS (prot)[0]); -#ifdef HAVE_LONG_LONGS + break; +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: protp = SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot)) - && ('s' == SCM_SYMBOL_CHARS (prot)[0]); + && ('l' == SCM_SYMBOL_CHARS (prot)[0]); + break; #endif case scm_tc7_fvect: protp = singp (prot); + break; case scm_tc7_dvect: - protp = SCM_REALP(prot); + protp = ((SCM_REALP(prot) && ! singp (prot)) + || (SCM_FRACTIONP (prot) + && scm_num_eq_p (exactly_one_third, prot))); + break; case scm_tc7_cvect: protp = SCM_COMPLEXP(prot); + break; case scm_tc7_vector: case scm_tc7_wvect: protp = SCM_NULLP(prot); + break; default: /* no default */ ; @@ -342,8 +326,8 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, 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.") + "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)) @@ -361,7 +345,7 @@ SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, case scm_tc7_fvect: case scm_tc7_cvect: case scm_tc7_dvect: -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: #endif case scm_tc7_svect: @@ -379,14 +363,14 @@ 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" + "@lisp\n" "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n" - "@end example") + "@end lisp") #define FUNC_NAME s_scm_array_dimensions { SCM res = SCM_EOL; - scm_sizet k; - scm_array_dim *s; + size_t k; + scm_t_array_dim *s; if (SCM_IMP (ra)) return SCM_BOOL_F; switch (SCM_TYP7 (ra)) @@ -404,7 +388,7 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, case scm_tc7_cvect: case scm_tc7_dvect: case scm_tc7_svect: -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: #endif return scm_cons (scm_uniform_vector_length (ra), SCM_EOL); @@ -454,8 +438,8 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, #define FUNC_NAME s_scm_shared_array_increments { SCM res = SCM_EOL; - scm_sizet k; - scm_array_dim *s; + 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); @@ -471,22 +455,25 @@ 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 scm_sizet pos = SCM_ARRAY_BASE (ra); - register scm_sizet k = SCM_ARRAY_NDIM (ra); - scm_array_dim *s = SCM_ARRAY_DIMS (ra); + 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)) { - SCM_ASSERT (1 == k, scm_makfrom0str (what), SCM_WNA, NULL); + if (k != 1) + scm_error_num_args_subr (what); return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); } - while (k && SCM_NIMP (args)) + while (k && SCM_CONSP (args)) { ind = SCM_CAR (args); args = SCM_CDR (args); - SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, what); + 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); @@ -494,22 +481,23 @@ scm_aind (SCM ra, SCM args, const char *what) k--; s++; } - SCM_ASSERT (0 == k && SCM_NULLP (args), scm_makfrom0str (what), SCM_WNA, - NULL); + 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, ((long) ndim << 17) + scm_tc16_array, - scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)), - "array")); + SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_tc16_array, + scm_gc_malloc ((sizeof (scm_t_array) + + ndim * sizeof (scm_t_array_dim)), + "array")); SCM_ARRAY_V (ra) = scm_nullvect; SCM_ALLOW_INTS; return ra; @@ -522,10 +510,12 @@ static char s_bad_spec[] = "Bad scm_array dimension"; SCM scm_shap2ra (SCM args, const char *what) { - scm_array_dim *s; + scm_t_array_dim *s; SCM ra, spec, sp; int ndim = scm_ilength (args); - SCM_ASSERT (0 <= ndim, args, s_bad_spec, what); + 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); @@ -534,20 +524,22 @@ scm_shap2ra (SCM args, const char *what) spec = SCM_CAR (args); if (SCM_INUMP (spec)) { - SCM_ASSERT (SCM_INUM (spec) >= 0, spec, s_bad_spec, what); + 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 { - SCM_ASSERT (SCM_CONSP (spec) && SCM_INUMP (SCM_CAR (spec)), spec, - s_bad_spec, what); + 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); - SCM_ASSERT (SCM_CONSP (sp) - && SCM_INUMP (SCM_CAR (sp)) && SCM_NULLP (SCM_CDR (sp)), - spec, s_bad_spec, what); + 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; } @@ -556,25 +548,22 @@ scm_shap2ra (SCM args, const char *what) } 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.") + (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_sizet k; - unsigned long int rlen = 1; - scm_array_dim *s; + size_t k; + unsigned long rlen = 1; + scm_t_array_dim *s; SCM ra; + if (SCM_INUMP (dims)) { - SCM answer; - - SCM_ASSERT_RANGE (1, dims, SCM_INUM (dims) <= SCM_LENGTH_MAX); - - answer = scm_make_uve (SCM_INUM (dims), prot); + SCM answer = scm_make_uve (SCM_INUM (dims), prot); if (!SCM_UNBNDP (fill)) scm_array_fill_x (answer, fill); else if (SCM_SYMBOLP (prot)) @@ -583,12 +572,14 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 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_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS); + SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); s = SCM_ARRAY_DIMS (ra); k = SCM_ARRAY_NDIM (ra); + while (k--) { s[k].inc = rlen; @@ -596,8 +587,6 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; } - SCM_ASSERT_RANGE (1, dims, rlen <= SCM_LENGTH_MAX); - SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot); if (!SCM_UNBNDP (fill)) @@ -618,7 +607,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, void scm_ra_set_contp (SCM ra) { - scm_sizet k = SCM_ARRAY_NDIM (ra); + size_t k = SCM_ARRAY_NDIM (ra); if (k) { long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc; @@ -626,14 +615,14 @@ scm_ra_set_contp (SCM ra) { if (inc != SCM_ARRAY_DIMS (ra)[k].inc) { - SCM_SETAND_CAR (ra, ~SCM_ARRAY_CONTIGUOUS); + SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra); return; } inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1); } } - SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS); + SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); } @@ -644,7 +633,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, "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" + "@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" @@ -653,17 +642,19 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, "(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") + "@end lisp") #define FUNC_NAME s_scm_make_shared_array { SCM ra; SCM inds, indptr; SCM imap; - scm_sizet i, k; + size_t k, i; long old_min, new_min, old_max, new_max; - scm_array_dim *s; - SCM_VALIDATE_ARRAY (1,oldra); - SCM_VALIDATE_PROC (2,mapfunc); + 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)) { @@ -699,16 +690,16 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, return ra; } } - imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL); + imap = scm_apply_0 (mapfunc, scm_reverse (inds)); if (SCM_ARRAYP (oldra)) - i = (scm_sizet) scm_aind (oldra, imap, FUNC_NAME); + i = (size_t) 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); + 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); @@ -721,17 +712,16 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, 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); + 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)) - { - SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), - imap, s_bad_ind, FUNC_NAME); + 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; @@ -746,8 +736,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, 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 (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); @@ -766,34 +756,38 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, /* args are RA . DIMS */ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, (SCM ra, 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" + "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 example") + "@end lisp") #define FUNC_NAME s_scm_transpose_array { - SCM res, vargs, *ve = &vargs; - scm_array_dim *s, *r; + SCM res, vargs; + SCM const *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_WTA (1,ra); + badarg:SCM_WRONG_TYPE_ARG (1, ra); case scm_tc7_bvect: case scm_tc7_string: case scm_tc7_byvect: @@ -803,22 +797,21 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, case scm_tc7_dvect: case scm_tc7_cvect: case scm_tc7_svect: -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: #endif - SCM_ASSERT (!SCM_NULLP (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); + 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); - SCM_ASSERT (SCM_VECTOR_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), - scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); - ve = SCM_VELTS (vargs); + 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++) { @@ -863,7 +856,8 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, r->inc += s->inc; } } - SCM_ASSERT (ndim <= 0, args, "bad argument list", FUNC_NAME); + if (ndim > 0) + SCM_MISC_ERROR ("bad argument list", SCM_EOL); scm_ra_set_contp (res); return res; } @@ -885,28 +879,30 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, "@code{eq?}. The value returned by @var{array-prototype} when given an\n" "enclosed array is unspecified.\n\n" "examples:\n" - "@example\n" + "@lisp\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") + "@end lisp") #define FUNC_NAME s_scm_enclose_array { SCM axv, res, ra_inr; - scm_array_dim vdim, *s = &vdim; + 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); - SCM_ASSERT (0 <= ninr, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); + 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_WTA (1,ra); + badarg1:SCM_WRONG_TYPE_ARG (1, ra); case scm_tc7_string: case scm_tc7_bvect: case scm_tc7_byvect: @@ -918,7 +914,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, case scm_tc7_vector: case scm_tc7_wvect: case scm_tc7_svect: -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: #endif s->lbnd = 0; @@ -937,14 +933,16 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, break; } noutr = ndim - ninr; + if (noutr < 0) + SCM_WRONG_NUM_ARGS (); axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKE_CHAR (0)); - SCM_ASSERT (0 <= noutr, 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); + 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; @@ -969,15 +967,17 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, (SCM v, SCM args), - "Returns @code{#t} if its arguments would be acceptable to array-ref.") + "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 scm_sizet k; + register size_t k; register long j; - scm_array_dim *s; + scm_t_array_dim *s; + SCM_VALIDATE_REST_ARGUMENT (args); SCM_ASRTGO (SCM_NIMP (v), badarg1); if (SCM_NIMP (args)) @@ -991,8 +991,8 @@ tail: switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA (1,v); - wna: scm_wrong_num_args (scm_makfrom0str (FUNC_NAME)); + 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); @@ -1017,7 +1017,8 @@ tail: ind = SCM_CAR (args); args = SCM_CDR (args); s++; - SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, FUNC_NAME); + if (!SCM_INUMP (ind)) + SCM_MISC_ERROR (s_bad_ind, SCM_EOL); } SCM_ASRTGO (0 == k, wna); v = SCM_ARRAY_V (v); @@ -1031,7 +1032,7 @@ tail: case scm_tc7_dvect: case scm_tc7_cvect: case scm_tc7_svect: -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: #endif case scm_tc7_vector: @@ -1051,8 +1052,9 @@ 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" - "Returns the element at the @code{(index1, index2)} element in @var{array}.") + "@deffnx {Scheme Procedure} 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; @@ -1078,7 +1080,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, } else { - SCM_VALIDATE_INUM (2,args); + SCM_VALIDATE_INUM (2, args); pos = SCM_INUM (args); } length = SCM_INUM (scm_uniform_vector_length (v)); @@ -1090,13 +1092,13 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, if (SCM_NULLP (args)) return v; badarg: - SCM_WTA (1,v); - abort (); + SCM_WRONG_TYPE_ARG (1, v); + /* not reached */ outrng: scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); wna: - scm_wrong_num_args (SCM_FUNC_NAME); + SCM_WRONG_NUM_ARGS (); case scm_tc7_smob: { /* enclosed */ int k = SCM_ARRAY_NDIM (v); @@ -1123,13 +1125,13 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, 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]); + 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 +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: - return scm_long_long2num (((long_long *) SCM_CELL_WORD_1 (v))[pos]); + return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]); #endif case scm_tc7_fvect: @@ -1150,14 +1152,15 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, tries to recycle conses. (Make *sure* you want them recycled.) */ SCM -scm_cvref (SCM v, scm_sizet pos, SCM last) +scm_cvref (SCM v, unsigned long pos, SCM last) +#define FUNC_NAME "scm_cvref" { switch SCM_TYP7 (v) { default: - scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref"); + SCM_WRONG_TYPE_ARG (SCM_ARG1, v); case scm_tc7_bvect: - if (SCM_BITVEC_REF(v,pos)) + if (SCM_BITVEC_REF(v, pos)) return SCM_BOOL_T; else return SCM_BOOL_F; @@ -1171,26 +1174,26 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) 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 +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: - return scm_long_long2num (((long_long *) SCM_CELL_WORD_1 (v))[pos]); + 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)) + if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0)) { 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)) + if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0)) { 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)) + if (SCM_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]; @@ -1217,6 +1220,8 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) } } } +#undef FUNC_NAME + SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x); @@ -1225,12 +1230,13 @@ SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_ar 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" + "@deffnx {Scheme Procedure} uniform-array-set1! v obj args\n" + "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 { long pos = 0; + SCM_ASRTGO (SCM_NIMP (v), badarg1); if (SCM_ARRAYP (v)) { @@ -1240,16 +1246,15 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, else { unsigned long int length; - if (SCM_NIMP (args)) + if (SCM_CONSP (args)) { - SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args, - SCM_ARG3, FUNC_NAME); + SCM_ASSERT (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_VALIDATE_INUM_COPY (3, args, pos); } length = SCM_INUM (scm_uniform_vector_length (v)); SCM_ASRTGO (pos >= 0 && pos < length, outrng); @@ -1257,21 +1262,21 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, switch (SCM_TYP7 (v)) { default: badarg1: - SCM_WTA (1,v); - abort (); + SCM_WRONG_TYPE_ARG (1, v); + /* not reached */ outrng: scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); wna: - scm_wrong_num_args (SCM_FUNC_NAME); + SCM_WRONG_NUM_ARGS (); case scm_tc7_smob: /* enclosed */ goto badarg1; case scm_tc7_bvect: if (SCM_FALSEP (obj)) - SCM_BITVEC_CLR(v,pos); + SCM_BITVEC_CLR(v, pos); else if (SCM_EQ_P (obj, SCM_BOOL_T)) - SCM_BITVEC_SET(v,pos); + SCM_BITVEC_SET(v, pos); else - badobj:SCM_WTA (2,obj); + badobj:SCM_WRONG_TYPE_ARG (2, obj); break; case scm_tc7_string: SCM_ASRTGO (SCM_CHARP (obj), badobj); @@ -1284,41 +1289,44 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, ((char *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj); break; case scm_tc7_uvect: - SCM_VELTS(v)[pos] = SCM_PACK (scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME)); + ((unsigned long *) SCM_UVECTOR_BASE (v))[pos] + = scm_num2ulong (obj, SCM_ARG2, FUNC_NAME); break; case scm_tc7_ivect: - SCM_VELTS(v)[pos] = SCM_PACK (scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME)); + ((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_CELL_WORD_1 (v))[pos] = SCM_INUM (obj); + ((short *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj); break; -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: - ((long_long *) SCM_CELL_WORD_1 (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, FUNC_NAME); + ((long long *) SCM_UVECTOR_BASE (v))[pos] + = scm_num2long_long (obj, SCM_ARG2, FUNC_NAME); break; #endif - - case scm_tc7_fvect: - ((float *) SCM_CELL_WORD_1 (v))[pos] = (float) scm_num2dbl (obj, FUNC_NAME); + ((float *) SCM_UVECTOR_BASE (v))[pos] + = (float) scm_num2dbl (obj, FUNC_NAME); break; case scm_tc7_dvect: - ((double *) SCM_CELL_WORD_1 (v))[pos] = scm_num2dbl (obj, FUNC_NAME); + ((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_CELL_WORD_1 (v))[2 * pos] = SCM_REAL_VALUE (obj); - ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1] = 0.0; + ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_REAL_VALUE (obj); + ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = 0.0; } else { - ((double *) SCM_CELL_WORD_1 (v))[2 * pos] = SCM_COMPLEX_REAL (obj); - ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1] = SCM_COMPLEX_IMAG (obj); + ((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; + SCM_VECTOR_SET (v, pos, obj); break; } return SCM_UNSPECIFIED; @@ -1331,7 +1339,6 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, 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" @@ -1361,13 +1368,13 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, case scm_tc7_dvect: case scm_tc7_cvect: case scm_tc7_svect: -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: #endif return ra; case scm_tc7_smob: { - scm_sizet k, ndim = SCM_ARRAY_NDIM (ra), len = 1; + 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++) @@ -1410,7 +1417,7 @@ scm_ra2contig (SCM ra, int copy) { SCM ret; long inc = 1; - scm_sizet k, len = 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); @@ -1432,7 +1439,7 @@ scm_ra2contig (SCM ra, int copy) 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)); + SCM_ARRAY_V (ret) = scm_make_uve (inc, scm_array_prototype (ra)); if (copy) scm_array_copy_x (ra, ret); return ret; @@ -1442,11 +1449,11 @@ scm_ra2contig (SCM ra, int copy) 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" + "@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 during\n" - "uniform-array-read! the objects up to that point only are put into @var{ura}\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" @@ -1471,13 +1478,15 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, 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)); + vlen = (SCM_TYP7 (v) == scm_tc7_smob + ? 0 + : SCM_INUM (scm_uniform_vector_length (v))); loop: switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA (SCM_ARG1,v); + badarg1:SCM_WRONG_TYPE_ARG (SCM_ARG1, v); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (v), badarg1); cra = scm_ra2contig (ra, 0); @@ -1509,10 +1518,10 @@ loop: base = (char *) SCM_UVECTOR_BASE (v); sz = sizeof (short); break; -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (long_long); + sz = sizeof (long long); break; #endif case scm_tc7_fvect: @@ -1551,7 +1560,7 @@ loop: if (SCM_NIMP (port_or_fd)) { - scm_port *pt = SCM_PTAB_ENTRY (port_or_fd); + scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd); int remaining = (cend - offset) * sz; char *dest = base + (cstart + offset) * sz; @@ -1592,7 +1601,7 @@ loop: { SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd), base + (cstart + offset) * sz, - (scm_sizet) (sz * (cend - offset)))); + (sz * (cend - offset)))); if (ans == -1) SCM_SYSERROR; } @@ -1608,13 +1617,13 @@ loop: 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" + "@deffnx {Scheme Procedure} 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" + "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)}.") @@ -1635,19 +1644,21 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, 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)); - + vlen = (SCM_TYP7 (v) == scm_tc7_smob + ? 0 + : SCM_INUM (scm_uniform_vector_length (v))); + loop: switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA (1, v); + 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); + 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: @@ -1673,10 +1684,10 @@ loop: base = (char *) SCM_UVECTOR_BASE (v); sz = sizeof (short); break; -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: base = (char *) SCM_UVECTOR_BASE (v); - sz = sizeof (long_long); + sz = sizeof (long long); break; #endif case scm_tc7_fvect: @@ -1724,7 +1735,7 @@ loop: { SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd), base + (cstart + offset) * sz, - (scm_sizet) (sz * (cend - offset)))); + (sz * (cend - offset)))); if (ans == -1) SCM_SYSERROR; } @@ -1740,8 +1751,9 @@ 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), - "Returns the number of occurrences of the boolean B in BITVECTOR.") + (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); @@ -1778,9 +1790,15 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, 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.") + "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 { long i, lenw, xbits, pos; @@ -1788,7 +1806,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, SCM_VALIDATE_BOOL (1, item); SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME); - SCM_VALIDATE_INUM_COPY (3,k,pos); + 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)) @@ -1840,14 +1858,33 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, 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.") + (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 uniform vector of unsigned long integers, then\n" + "they're indexes into @var{v} which are set to @var{obj}.\n" + "\n" + "@example\n" + "(define bv #*01000010)\n" + "(bit-set*! bv #u(5 2 7) #t)\n" + "bv\n" + "@result{} #*01100111\n" + "@end example") #define FUNC_NAME s_scm_bit_set_star_x { register long i, k, vlen; @@ -1856,7 +1893,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, switch SCM_TYP7 (kv) { default: - badarg2:SCM_WTA (2,kv); + badarg2:SCM_WRONG_TYPE_ARG (2, kv); case scm_tc7_uvect: vlen = SCM_BITVECTOR_LENGTH (v); if (SCM_FALSEP (obj)) @@ -1865,7 +1902,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, k = SCM_UNPACK (SCM_VELTS (kv)[--i]); if (k >= vlen) scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); - SCM_BITVEC_CLR(v,k); + SCM_BITVEC_CLR(v, k); } else if (SCM_EQ_P (obj, SCM_BOOL_T)) for (i = SCM_UVECTOR_LENGTH (kv); i;) @@ -1873,19 +1910,19 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, k = SCM_UNPACK (SCM_VELTS (kv)[--i]); if (k >= vlen) scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); - SCM_BITVEC_SET(v,k); + SCM_BITVEC_SET(v, k); } else - badarg3:SCM_WTA (3,obj); + 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_UNPACK (SCM_VELTS (v)[k]) &= ~ SCM_UNPACK(SCM_VELTS (kv)[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_UNPACK (SCM_VELTS (v)[k]) |= SCM_UNPACK (SCM_VELTS (kv)[k]); + SCM_BITVECTOR_BASE (v) [k] |= SCM_BITVECTOR_BASE (kv) [k]; else goto badarg3; break; @@ -1897,11 +1934,23 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, (SCM v, SCM kv, SCM obj), - "Returns\n" + "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 uniform vector of unsigned long integers, then\n" + "it's the indexes in @var{v} to consider.\n" + "\n" + "For example,\n" + "\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.") + "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n" + "(bit-count* #*01110111 #u(7 0 4) #f) @result{} 2\n" + "@end example") #define FUNC_NAME s_scm_bit_count_star { register long i, vlen, count = 0; @@ -1914,7 +1963,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, { default: badarg2: - SCM_WTA (2,kv); + SCM_WRONG_TYPE_ARG (2, kv); case scm_tc7_uvect: vlen = SCM_BITVECTOR_LENGTH (v); if (SCM_FALSEP (obj)) @@ -1923,7 +1972,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, 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)) + if (!SCM_BITVEC_REF(v, k)) count++; } else if (SCM_EQ_P (obj, SCM_BOOL_T)) @@ -1932,11 +1981,11 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, 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)) + if (SCM_BITVEC_REF (v, k)) count++; } else - badarg3:SCM_WTA (3,obj); + 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); @@ -1965,7 +2014,8 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, (SCM v), - "Modifies @var{bv} by replacing each element with its negation.") + "Modify the bit vector @var{v} by replacing each element with\n" + "its negation.") #define FUNC_NAME s_scm_bit_invert_x { long int k; @@ -1974,7 +2024,7 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, k = SCM_BITVECTOR_LENGTH (v); for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_UNPACK (SCM_VELTS (v)[k]) = ~SCM_UNPACK (SCM_VELTS (v)[k]); + SCM_BITVECTOR_BASE (v) [k] = ~SCM_BITVECTOR_BASE (v) [k]; return SCM_UNSPECIFIED; } @@ -2013,11 +2063,11 @@ scm_istr2bve (char *str, long len) static SCM -ra2l (SCM ra,scm_sizet base,scm_sizet k) +ra2l (SCM ra, unsigned long base, unsigned long k) { register SCM res = SCM_EOL; register long inc = SCM_ARRAY_DIMS (ra)[k].inc; - register scm_sizet i; + 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; @@ -2043,7 +2093,8 @@ ra2l (SCM ra,scm_sizet base,scm_sizet k) 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}.") + "Return a list consisting of all the elements, in order, of\n" + "@var{array}.") #define FUNC_NAME s_scm_array_to_list { SCM res = SCM_EOL; @@ -2052,7 +2103,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA (1,v); + 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); @@ -2072,36 +2123,44 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), 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; - data = (short *)SCM_VELTS(v); - for (k = SCM_UVECTOR_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_UVECTOR_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_long_long2num(data[k]), 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; + } +#if SCM_SIZEOF_LONG_LONG != 0 + 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); @@ -2128,24 +2187,23 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, #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); +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" - "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.") + "@deffnx {Scheme 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; - scm_sizet k; + unsigned long k; long n; - SCM_VALIDATE_INUM_COPY (1,ndim,k); + SCM_VALIDATE_INUM_COPY (1, ndim, k); while (k--) { n = scm_ilength (row); @@ -2157,7 +2215,6 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, 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); @@ -2173,13 +2230,13 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, 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; + badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S", + scm_list_1 (lst)); } #undef FUNC_NAME static int -l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k) +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); @@ -2190,26 +2247,26 @@ l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k) { while (n--) { - if (SCM_IMP (lst) || SCM_NCONSP (lst)) + if (!SCM_CONSP (lst)) return 0; ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1); base += inc; lst = SCM_CDR (lst); } - if (SCM_NNULLP (lst)) + if (!SCM_NULLP (lst)) return 0; } else { while (n--) { - if (SCM_IMP (lst) || SCM_NCONSP (lst)) + if (!SCM_CONSP (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)) + if (!SCM_NULLP (lst)) return 0; } return ok; @@ -2217,10 +2274,12 @@ l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k) static void -rapr1 (SCM ra,scm_sizet j,scm_sizet k,SCM port,scm_print_state *pstate) +rapr1 (SCM ra, unsigned long j, unsigned long k, SCM port, scm_print_state *pstate) { long inc = 1; - long n = SCM_INUM (scm_uniform_vector_length (ra)); + long n = (SCM_TYP7 (ra) == scm_tc7_smob + ? 0 + : SCM_INUM (scm_uniform_vector_length (ra))); int enclosed = 0; tail: switch SCM_TYP7 (ra) @@ -2258,8 +2317,7 @@ tail: } break; } - if SCM_ARRAY_NDIM - (ra) + 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); @@ -2395,7 +2453,7 @@ int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) { SCM v = exp; - scm_sizet base = 0; + unsigned long base = 0; scm_putc ('#', port); tail: switch SCM_TYP7 (v) @@ -2426,7 +2484,7 @@ tail: scm_putc ('*', port); for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++) { - scm_bits_t w = SCM_UNPACK (SCM_VELTS (exp)[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); @@ -2463,7 +2521,7 @@ tail: case scm_tc7_svect: scm_putc ('h', port); break; -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: scm_putc ('l', port); break; @@ -2486,8 +2544,8 @@ tail: 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" + "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 { @@ -2497,7 +2555,7 @@ loop: switch SCM_TYP7 (ra) { default: - badarg:SCM_WTA (1,ra); + badarg:SCM_WRONG_TYPE_ARG (1, ra); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (ra), badarg); if (enclosed++) @@ -2518,15 +2576,15 @@ loop: case scm_tc7_ivect: return SCM_MAKINUM (-1L); case scm_tc7_svect: - return SCM_CDR (scm_intern ("s", 1)); -#ifdef HAVE_LONG_LONGS + return scm_str2symbol ("s"); +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: - return SCM_CDR (scm_intern ("l", 1)); + 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); + return exactly_one_third; case scm_tc7_cvect: return scm_make_complex (0.0, 1.0); } @@ -2535,27 +2593,32 @@ loop: static SCM -markra (SCM ptr) +array_mark (SCM ptr) { return SCM_ARRAY_V (ptr); } -static scm_sizet -freera (SCM ptr) +static size_t +array_free (SCM ptr) { - scm_must_free (SCM_ARRAY_MEM (ptr)); - return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim); + scm_gc_free (SCM_ARRAY_MEM (ptr), + (sizeof (scm_t_array) + + SCM_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)), + "array"); + return 0; } void scm_init_unif () { - scm_tc16_array = scm_make_smob_type_mfpe ("array", 0, - markra, - freera, - scm_raprin1, - scm_array_equal_p); + 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); + exactly_one_third = scm_permanent_object (scm_make_ratio (SCM_MAKINUM (1), + SCM_MAKINUM (3))); scm_add_feature ("array"); #include "libguile/unif.x" }