From 5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:23 -0800 Subject: Import Upstream version 4e6 --- unif.c | 2000 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2000 insertions(+) create mode 100644 unif.c (limited to 'unif.c') diff --git a/unif.c b/unif.c new file mode 100644 index 0000000..4bc2ecf --- /dev/null +++ b/unif.c @@ -0,0 +1,2000 @@ +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 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, 675 Mass Ave, Cambridge, MA 02139, 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. + */ + +/* "unif.c" Uniform vectors and arrays + Authors: Aubrey Jaffer & Radey Shouman. + +The set of uniform vector types is: + Vector of: Called: +char string +boolean bvect +signed int ivect +unsigned int uvect +float fvect +double dvect +complex double cvect +*/ + +#include "scm.h" + +#ifndef STDC_HEADERS + int ungetc P((int c, FILE *stream)); + sizet fwrite (); +#endif + +long tc16_array = 0; + +char s_resizuve[] = "vector-set-length!"; +SCM resizuve(vect, len) + SCM vect, len; +{ + long l = INUM(len); + sizet siz, sz; + ASRTGO(NIMP(vect), badarg1); + switch TYP7(vect) { + default: badarg1: wta(vect, (char *)ARG1, s_resizuve); + case tc7_string: + ASRTGO(vect != nullstr, badarg1); + sz = sizeof(char); + l++; + break; + case tc7_vector: + ASRTGO(vect != nullvect, badarg1); + sz = sizeof(SCM); + break; +#ifdef ARRAYS + case tc7_bvect: + l = (l+LONG_BIT-1)/LONG_BIT; + case tc7_uvect: + case tc7_ivect: + sz = sizeof(long); + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + sz = sizeof(float); + break; +# endif + case tc7_dvect: + sz = sizeof(double); + break; + case tc7_cvect: + sz = 2*sizeof(double); + break; +# endif +#endif + } + ASSERT(INUMP(len), len, ARG2, s_resizuve); + if (!l) l = 1L; + siz = l * sz; + if (siz != l * sz) wta(MAKINUM(l * sz), (char *) NALLOC, s_resizuve); + DEFER_INTS; + SETCHARS(vect, (char *)must_realloc((char *)CHARS(vect), + (long)LENGTH(vect)*sz, + (long)siz, s_resizuve)); + if VECTORP(vect) { + sz = LENGTH(vect); + while(l > sz) VELTS(vect)[--l] = UNSPECIFIED; + } + else if STRINGP(vect) CHARS(vect)[l-1] = 0; + SETLENGTH(vect, INUM(len), TYP7(vect)); + ALLOW_INTS; + return vect; +} + +#ifdef ARRAYS + +# ifdef FLOATS +# ifdef SINGLES +SCM makflo (x) + float x; +{ + SCM z; + if (x==0.0) return flo0; + NEWCELL(z); + DEFER_INTS; + CAR(z) = tc_flo; + FLO(z) = x; + ALLOW_INTS; + return z; +} +# endif +# endif + +SCM make_uve(k, prot) + long k; + SCM prot; +{ + SCM v; + long i, type; + if (BOOL_T==prot) { + i = sizeof(long)*((k+LONG_BIT-1)/LONG_BIT); + type = tc7_bvect; + } + else if ICHRP(prot) { + i = sizeof(char)*k; + type = tc7_string; + } + else if INUMP(prot) { + i = sizeof(long)*k; + if (INUM(prot)>0) type = tc7_uvect; + else type = tc7_ivect; + } + else +# ifdef FLOATS + if (IMP(prot) || !INEXP(prot)) +# endif + /* Huge non-unif vectors are NOT supported. */ + return make_vector(MAKINUM(k), UNDEFINED); /* no special vector */ +# ifdef FLOATS +# ifdef SINGLES + else if SINGP(prot) { +# ifdef CDR_DOUBLES + double x = FLO(prot); + float fx = x; + if (x != fx) { + i = sizeof(double)*k; + type = tc7_dvect; + } + else +# endif + { + i = sizeof(float)*k; + type = tc7_fvect; + } + } +# endif + else if (CPLXP(prot)) { + i = 2*sizeof(double)*k; + type = tc7_cvect; + } + else { + i = sizeof(double)*k; + type = tc7_dvect; + } +# endif + + NEWCELL(v); + DEFER_INTS; + SETCHARS(v, must_malloc((i ? i : 1L), s_vector)); + SETLENGTH(v, (k0) ? BOOL_T : BOOL_F; + case tc7_ivect: + return nprot || (INUMP(prot) && INUM(prot)<=0) ? BOOL_T : BOOL_F; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: return nprot || (NIMP(prot) && SINGP(prot)) ? BOOL_T : BOOL_F; +# endif + case tc7_dvect: return nprot || (NIMP(prot) && REALP(prot)) ? BOOL_T : BOOL_F; + case tc7_cvect: return nprot || (NIMP(prot) && CPLXP(prot)) ? BOOL_T : BOOL_F; +# endif + case tc7_vector: return nprot || NULLP(prot) ? BOOL_T : BOOL_F; + default:; + } + return BOOL_F; +} +SCM array_rank(ra) + SCM ra; +{ + if IMP(ra) return INUM0; + switch (TYP7(ra)) { + default: return INUM0; + case tc7_string: case tc7_vector: case tc7_bvect: + case tc7_uvect: case tc7_ivect: case tc7_fvect: + case tc7_cvect: case tc7_dvect: + return MAKINUM(1L); + case tc7_smob: + if ARRAYP(ra) return MAKINUM(ARRAY_NDIM(ra)); + return INUM0; + } +} +static char s_array_dims[] = "array-dimensions"; +SCM array_dims(ra) + SCM ra; +{ + SCM res=EOL; + sizet k; + array_dim *s; + if IMP(ra) return BOOL_F; + switch (TYP7(ra)) { + default: return BOOL_F; + case tc7_string: case tc7_vector: case tc7_bvect: + case tc7_uvect: case tc7_ivect: case tc7_fvect: + case tc7_cvect: case tc7_dvect: + return cons(MAKINUM(LENGTH(ra)), EOL); + case tc7_smob: + if (!ARRAYP(ra)) return BOOL_F; + k = ARRAY_NDIM(ra); + s = ARRAY_DIMS(ra); + while (k--) + res = cons(s[k].lbnd ? cons2(MAKINUM(s[k].lbnd), MAKINUM(s[k].ubnd), EOL) : + MAKINUM(1+(s[k].ubnd)) + , res); + return res; + } +} +static char s_bad_ind[] = "Bad array index"; +long aind(ra, args, what) + SCM ra, args; + char *what; +{ + SCM ind; + register long j; + register sizet pos = ARRAY_BASE(ra); + register sizet k = ARRAY_NDIM(ra); + array_dim *s = ARRAY_DIMS(ra); + if INUMP(args) { + ASSERT(1==k, UNDEFINED, WNA, what); + j = INUM(args); + ASSERT(j >= (s->lbnd) && j <= (s->ubnd), args, OUTOFRANGE, what); + return pos + (j - s->lbnd)*(s->inc); + } + ASSERT((IMP(args) ? NULLP(args) : CONSP(args)), args, s_bad_ind, what); + while (k && NIMP(args)) { + ind = CAR(args); + args = CDR(args); + ASSERT(INUMP(ind), ind, s_bad_ind, what); + j = INUM(ind); + ASSERT(j >= (s->lbnd) && j <= (s->ubnd), ind, OUTOFRANGE, what); + pos += (j - s->lbnd)*(s->inc); + k--; + s++; + } + ASSERT(0==k && NULLP(args), UNDEFINED, WNA, what); + return pos; +} + +SCM make_ra(ndim) + int ndim; +{ + SCM ra; + NEWCELL(ra); + DEFER_INTS; + SETCDR(ra, must_malloc((long)(sizeof(array)+ndim*sizeof(array_dim)), + "array")); + CAR(ra) = ((long)ndim << 17) + tc16_array; + ARRAY_V(ra) = nullvect; + ALLOW_INTS; + return ra; +} + +static char s_bad_spec[] = "Bad array dimension"; +/* Increments will still need to be set. */ +SCM shap2ra(args, what) + SCM args; + char *what; +{ + array_dim *s; + SCM ra, spec, sp; + int ndim = ilength(args); + ASSERT(0 <= ndim, args, s_bad_spec, what); + ra = make_ra(ndim); + ARRAY_BASE(ra) = 0; + s = ARRAY_DIMS(ra); + for (; NIMP(args); s++, args = CDR(args)) { + spec = CAR(args); + if IMP(spec) { + ASSERT(INUMP(spec)&&INUM(spec)>=0, spec, s_bad_spec, what); + s->lbnd = 0; + s->ubnd = INUM(spec) - 1; + s->inc = 1; + } + else { + ASSERT(CONSP(spec) && INUMP(CAR(spec)), spec, s_bad_spec, what); + s->lbnd = INUM(CAR(spec)); + sp = CDR(spec); + ASSERT(INUMP(CAR(sp)) && NULLP(CDR(sp)), + spec, s_bad_spec, what); + s->ubnd = INUM(CAR(sp)); + s->inc = 1; + } + } + return ra; +} + +static char s_uve_fill[] = "uniform-vector-fill!"; +int rafill(ra, fill, ignore) + SCM ra, fill, ignore; +{ + sizet i, n; + long inc = 1; + sizet base = 0; + if ARRAYP(ra) { + n = ARRAY_DIMS(ra)->ubnd - ARRAY_DIMS(ra)->lbnd + 1; + inc = ARRAY_DIMS(ra)->inc; + base = ARRAY_BASE(ra); + ra = ARRAY_V(ra); + } + else + n = LENGTH(ra); + switch TYP7(ra) { + badarg2: wta(fill, (char *)ARG2, s_uve_fill); + default: ASSERT(NFALSEP(arrayp(ra, UNDEFINED)), ra, ARG1, s_uve_fill); + for (i = base; n--; i += inc) + aset(ra, fill, MAKINUM(i)); + break; + case tc7_vector: { + SCM *ve = VELTS(ra); + for (i = base; n--; i += inc) + ve[i] = fill; + break; + } + case tc7_string: { + char *ve = CHARS(ra); + SCM f = ICHR(fill); + ASRTGO(ICHRP(fill), badarg2); + for (i = base; n--; i += inc) + ve[i] = f; + break; + } + case tc7_bvect: { + long *ve = (long *)VELTS(ra); + if (1==inc && (n >= LONG_BIT || n==LENGTH(ra))) { + i = base/LONG_BIT; + if (BOOL_F==fill) { + if (base % LONG_BIT) /* leading partial word */ + ve[i++] &= ~(~0L << (base % LONG_BIT)); + for (; i < (base + n)/LONG_BIT; i++) + ve[i] = 0L; + if ((base + n) % LONG_BIT) /* trailing partial word */ + ve[i] &= (~0L << ((base + n) % LONG_BIT)); + } + else if (BOOL_T==fill) { + if (base % LONG_BIT) + ve[i++] |= ~0L << (base % LONG_BIT); + for (; i < (base + n)/LONG_BIT; i++) + ve[i] = ~0L; + if ((base + n) % LONG_BIT) + ve[i] |= ~(~0L << ((base + n) % LONG_BIT)); + } + else goto badarg2; + } + else { + if (BOOL_F==fill) + for (i = base; n--; i += inc) + ve[i/LONG_BIT] &= ~(1L<<(i%LONG_BIT)); + else if (BOOL_T==fill) + for (i = base; n--; i += inc) + ve[i/LONG_BIT] |= (1L<<(i%LONG_BIT)); + else goto badarg2; + } + break; + } + case tc7_uvect: + case tc7_ivect: + { + long *ve = VELTS(ra); + long f = (tc7_uvect==TYP7(ra) ? + num2ulong(fill, (char *)ARG2, s_uve_fill) : + num2long(fill, (char *)ARG2, s_uve_fill)); + for (i = base; n--; i += inc) + ve[i] = f; + break; + } +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *ve = (float *)VELTS(ra); + float f = num2dbl(fill, (char *)ARG2, s_uve_fill); + for (i = base; n--; i += inc) + ve[i] = f; + break; + } +# endif /* SINGLES */ + case tc7_dvect: { + double *ve = (double *)VELTS(ra); + double f = num2dbl(fill, (char *)ARG2, s_uve_fill); + for (i = base; n--; i += inc) + ve[i] = f; + break; + } + case tc7_cvect: { + double fr, fi=0.0; + double (*ve)[2] = (double (*)[2])VELTS(ra); + if (NIMP(fill) && CPLXP(fill)) { + fr = REAL(fill); + fi = IMAG(fill); + } + else + fr = num2dbl(fill, (char *)ARG2, s_uve_fill); + for (i = base; n--; i += inc) { + ve[i][0] = fr; + ve[i][1] = fi; + } + break; + } +# endif /* FLOATS */ + } + return 1; +} +SCM uve_fill(uve, fill) + SCM uve, fill; +{ + + ASSERT(NIMP(uve) && (!ARRAYP(uve) || 1==ARRAY_NDIM(uve)), + uve, ARG1, s_uve_fill); + rafill(uve, fill, EOL); + return UNSPECIFIED; +} + +static char s_dims2ura[] = "dimensions->uniform-array"; +SCM dims2ura(dims, prot, fill) + SCM dims, prot, fill; +{ + sizet k, vlen = 1; + long rlen = 1; + array_dim *s; + SCM ra; + if INUMP(dims) + if (INUM(dims) < LENGTH_MAX) { + ra = make_uve(INUM(dims), prot); + if NNULLP(fill) + rafill(ra, CAR(fill), EOL); + return ra; + } + else + dims = cons(dims, EOL); + ASSERT(NULLP(dims) || (NIMP(dims) && CONSP(dims)), dims, ARG1, s_dims2ura); + ra = shap2ra(dims, s_dims2ura); + CAR(ra) |= ARRAY_CONTIGUOUS; + s = ARRAY_DIMS(ra); + k = 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 < LENGTH_MAX) + ARRAY_V(ra) = make_uve((rlen > 0 ? rlen : 0L), prot); + else { + sizet bit; + switch TYP7(make_uve(0L, prot)) { + default: bit = LONG_BIT; break; + case tc7_vector: wta(dims, (char *)OUTOFRANGE, s_dims2ura); + case tc7_bvect: bit = 1; break; + case tc7_string: bit = CHAR_BIT; break; + case tc7_fvect: bit = sizeof(float)*CHAR_BIT/sizeof(char); break; + case tc7_dvect: bit = sizeof(double)*CHAR_BIT/sizeof(char); break; + case tc7_cvect: bit = 2*sizeof(double)*CHAR_BIT/sizeof(char); break; + } + ARRAY_BASE(ra) = (LONG_BIT + bit - 1)/bit; + rlen += ARRAY_BASE(ra); + ARRAY_V(ra) = make_uve(rlen, prot); + *((long *)VELTS(ARRAY_V(ra))) = rlen; + } + if NNULLP(fill) { + ASSERT(1==ilength(fill), UNDEFINED, WNA, s_dims2ura); + rafill(ARRAY_V(ra), CAR(fill), EOL); + } + if (1==ARRAY_NDIM(ra) && 0==ARRAY_BASE(ra)) + if (s->ubnd < s->lbnd || (0==s->lbnd && 1==s->inc)) return ARRAY_V(ra); + return ra; +} + +void ra_set_contp(ra) + SCM ra; +{ + sizet k = ARRAY_NDIM(ra); + long inc; + if (k) inc = ARRAY_DIMS(ra)[k-1].inc; + while (k--) { + if (inc != ARRAY_DIMS(ra)[k].inc) { + CAR(ra) &= ~ARRAY_CONTIGUOUS; + return; + } + inc *= (ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1); + } + CAR(ra) |= ARRAY_CONTIGUOUS; +} +char s_make_sh_array[] = "make-shared-array"; +SCM make_sh_array(oldra, mapfunc, dims) + SCM oldra; + SCM mapfunc; + SCM dims; +{ + SCM ra; + SCM inds, indptr; + SCM imap; + sizet i, k; + long old_min, new_min, old_max, new_max; + array_dim *s; + ASSERT(BOOL_T==procedurep(mapfunc), mapfunc, ARG2, s_make_sh_array); + ASSERT(NIMP(oldra) && arrayp(oldra, UNDEFINED), oldra, ARG1, s_make_sh_array); + ra = shap2ra(dims, s_make_sh_array); + if (ARRAYP(oldra)) { + ARRAY_V(ra) = ARRAY_V(oldra); + old_min = old_max = ARRAY_BASE(oldra); + s=ARRAY_DIMS(oldra); + k = 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 { + ARRAY_V(ra) = oldra; + old_min = 0; + old_max = (long)LENGTH(oldra) - 1; + } + inds = EOL; + s = ARRAY_DIMS(ra); + for (k = 0; k < ARRAY_NDIM(ra); k++) { + inds = cons(MAKINUM(s[k].lbnd), inds); + if (s[k].ubnd < s[k].lbnd) { + if (1==ARRAY_NDIM(ra)) + ra = make_uve(0L, array_prot(ra)); + else + ARRAY_V(ra) = make_uve(0L, array_prot(ra)); + return ra; + } + } + imap = apply(mapfunc, reverse(inds), EOL); + if ARRAYP(oldra) + i = (sizet)aind(oldra, imap, s_make_sh_array); + else { + if NINUMP(imap) { + ASSERT(1==ilength(imap) && INUMP(CAR(imap)), + imap, s_bad_ind, s_make_sh_array); + imap = CAR(imap); + } + i = INUM(imap); + } + ARRAY_BASE(ra) = new_min = new_max = i; + indptr = inds; + k = ARRAY_NDIM(ra); + while (k--) { + if (s[k].ubnd > s[k].lbnd) { + CAR(indptr) = MAKINUM(INUM(CAR(indptr))+1); + imap = apply(mapfunc, reverse(inds), EOL); + if ARRAYP(oldra) + s[k].inc = aind(oldra, imap, s_make_sh_array) - i; + else { + if NINUMP(imap) { + ASSERT(1==ilength(imap) && INUMP(CAR(imap)), + imap, s_bad_ind, s_make_sh_array); + imap = CAR(imap); + } + s[k].inc = (long)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 = CDR(indptr); + } + ASSERT(old_min <= new_min && old_max >= new_max, UNDEFINED, + "mapping out of range", s_make_sh_array); + if (1==ARRAY_NDIM(ra) && 0==ARRAY_BASE(ra)) { + if (1==s->inc && 0==s->lbnd + && LENGTH(ARRAY_V(ra))==1+s->ubnd) return ARRAY_V(ra); + if (s->ubnd < s->lbnd) return make_uve(0L, array_prot(ra)); + } + ra_set_contp(ra); + return ra; +} + +/* args are RA . DIMS */ +static char s_trans_array[] = "transpose-array"; +SCM trans_array(args) + SCM args; +{ + SCM ra, res, vargs, *ve = &vargs; + array_dim *s, *r; + int ndim, i, k; + ASSERT(NIMP(args), UNDEFINED, WNA, s_trans_array); + ra = CAR(args); + args = CDR(args); + switch TYP7(ra) { + default: badarg: wta(ra, (char *)ARG1, s_trans_array); + case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect: + case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: + ASSERT(NIMP(args) && NULLP(CDR(args)), UNDEFINED, WNA, s_trans_array); + ASSERT(INUM0==CAR(args), CAR(args), ARG1, s_trans_array); + return ra; + case tc7_smob: ASRTGO(ARRAYP(ra), badarg); + vargs = vector(args); + ASSERT(LENGTH(vargs)==ARRAY_NDIM(ra), UNDEFINED, WNA, s_trans_array); + ve = VELTS(vargs); + ndim = 0; + for (k = 0; k < ARRAY_NDIM(ra); k++) { + i = INUM(ve[k]); + ASSERT(INUMP(ve[k]) && i >=0 && i < ARRAY_NDIM(ra), + ve[k], ARG2, s_trans_array); + if (ndim < i) ndim = i; + } + ndim++; + res = make_ra(ndim); + ARRAY_V(res) = ARRAY_V(ra); + ARRAY_BASE(res) = ARRAY_BASE(ra); + for (k = ndim; k--;) { + ARRAY_DIMS(res)[k].lbnd = 0; + ARRAY_DIMS(res)[k].ubnd = -1; + } + for (k = ARRAY_NDIM(ra); k--;) { + i = INUM(ve[k]); + s = &(ARRAY_DIMS(ra)[k]); + r = &(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) { + ARRAY_BASE(res) += (s->lbnd - r->lbnd)*r->inc; + r->lbnd = s->lbnd; + } + r->inc += s->inc; + } + } + ASSERT(ndim <= 0, args, "bad argument list", s_trans_array); + ra_set_contp(res); + return res; + } +} + +/* args are RA . AXES */ +static char s_encl_array[] = "enclose-array"; +SCM encl_array(axes) + SCM axes; +{ + SCM axv, ra, res, ra_inr; + array_dim vdim, *s = &vdim; + int ndim, j, k, ninr, noutr; + ASSERT(NIMP(axes), UNDEFINED, WNA, s_encl_array); + ra = CAR(axes); + axes = CDR(axes); + if NULLP(axes) + axes = cons((ARRAYP(ra) ? MAKINUM(ARRAY_NDIM(ra) - 1) : INUM0), EOL); + ninr = ilength(axes); + ra_inr = make_ra(ninr); + ASRTGO(NIMP(ra), badarg1); + switch TYP7(ra) { + default: badarg1: wta(ra, (char *)ARG1, s_encl_array); + case tc7_string: case tc7_bvect: case tc7_uvect: case tc7_ivect: + case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: + s->lbnd = 0; + s->ubnd = LENGTH(ra) - 1; + s->inc = 1; + ARRAY_V(ra_inr) = ra; + ARRAY_BASE(ra_inr) = 0; + ndim = 1; + break; + case tc7_smob: ASRTGO(ARRAYP(ra), badarg1); + s = ARRAY_DIMS(ra); + ARRAY_V(ra_inr) = ARRAY_V(ra); + ARRAY_BASE(ra_inr) = ARRAY_BASE(ra); + ndim = ARRAY_NDIM(ra); + break; + } + noutr = ndim - ninr; + axv = make_string(MAKINUM(ndim), MAKICHR(0)); + ASSERT(0 <= noutr && 0 <= ninr, UNDEFINED, WNA, s_encl_array); + res = make_ra(noutr); + ARRAY_BASE(res) = ARRAY_BASE(ra_inr); + ARRAY_V(res) = ra_inr; + for (k = 0; k < ninr; k++, axes = CDR(axes)) { + j = INUM(CAR(axes)); + ASSERT(INUMP(CAR(axes)) && jlbnd) || j > (s->ubnd)) ret = BOOL_F; + k--; + s++; + } + ASRTGO(0==k && NULLP(args), wna); + return ret; + } + else goto scalar; + case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect: + case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: + ASRTGO(NIMP(args) && NULLP(CDR(args)), wna); + ind = CAR(args); + ASSERT(INUMP(ind), ind, s_bad_ind, s_array_inbp); + j = INUM(ind); + return j >= 0 && j < LENGTH(v) ? BOOL_T : BOOL_F; + } +} +static char s_aref[] = "array-ref"; +SCM aref(v, args) + SCM v, args; +{ + long pos; + if IMP(v) { + ASRTGO(NULLP(args), badarg); + return v; + } + else if ARRAYP(v) { + pos = aind(v, args, s_aref); + v = ARRAY_V(v); + } + else { + if NIMP(args) { + ASSERT(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_aref); + pos = INUM(CAR(args)); + ASRTGO(NULLP(CDR(args)), wna); + } + else { + ASSERT(INUMP(args), args, ARG2, s_aref); + pos = INUM(args); + } + ASRTGO(pos >= 0 && pos < LENGTH(v), outrng); + } + switch TYP7(v) { + default: if NULLP(args) return v; + badarg: wta(v, (char *)ARG1, s_aref); + outrng: wta(MAKINUM(pos), (char *)OUTOFRANGE, s_aref); + wna: wta(UNDEFINED, (char *)WNA, s_aref); + case tc7_smob: { /* enclosed */ + int k = ARRAY_NDIM(v); + SCM res = make_ra(k); + if (!ARRAYP(v)) { + ASRTGO(NULLP(args),badarg); + return v; + } + ARRAY_V(res) = ARRAY_V(v); + ARRAY_BASE(res) = pos; + while (k--) { + ARRAY_DIMS(res)[k].lbnd = ARRAY_DIMS(v)[k].lbnd; + ARRAY_DIMS(res)[k].ubnd = ARRAY_DIMS(v)[k].ubnd; + ARRAY_DIMS(res)[k].inc = ARRAY_DIMS(v)[k].inc; + } + return res; + } + case tc7_bvect: + if (VELTS(v)[pos/LONG_BIT]&(1L<<(pos%LONG_BIT))) + return BOOL_T; + else return BOOL_F; + case tc7_string: + return MAKICHR(CHARS(v)[pos]); +# ifdef INUMS_ONLY + case tc7_uvect: + case tc7_ivect: + return MAKINUM(VELTS(v)[pos]); +# else + case tc7_uvect: + return ulong2num(VELTS(v)[pos]); + case tc7_ivect: + return long2num(VELTS(v)[pos]); +# endif +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + return makflo(((float *)CDR(v))[pos]); +# endif + case tc7_dvect: + return makdbl(((double *)CDR(v))[pos], 0.0); + case tc7_cvect: + return makdbl(((double *)CDR(v))[2*pos], + ((double *)CDR(v))[2*pos+1]); +# endif + case tc7_vector: + return VELTS(v)[pos]; + } +} +SCM scm_array_ref(args) + SCM args; +{ + ASSERT(NIMP(args), UNDEFINED, WNA, s_aref); + return aref(CAR(args), CDR(args)); +} + +/* Internal version of aref for uves that does no error checking and + tries to recycle conses. (Make *sure* you want them recycled.) */ +SCM cvref(v, pos, last) + SCM v; + sizet pos; + SCM last; +{ + switch TYP7(v) { + default: wta(v, (char *)ARG1, "PROGRAMMING ERROR: cvref"); + case tc7_bvect: + if (VELTS(v)[pos/LONG_BIT]&(1L<<(pos%LONG_BIT))) + return BOOL_T; + else return BOOL_F; + case tc7_string: + return MAKICHR(CHARS(v)[pos]); +# ifdef INUMS_ONLY + case tc7_uvect: + case tc7_ivect: + return MAKINUM(VELTS(v)[pos]); +# else + case tc7_uvect: + return ulong2num(VELTS(v)[pos]); + case tc7_ivect: + return long2num(VELTS(v)[pos]); +# endif +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + if (NIMP(last) && (last != flo0) && (tc_flo==CAR(last))) { + FLO(last) = ((float *)CDR(v))[pos]; + return last; + } + return makflo(((float *)CDR(v))[pos]); +# endif + case tc7_cvect: + if (0.0!=((double *)CDR(v))[2*pos+1]) { + if (NIMP(last) && tc_dblc==CAR(last)) { + REAL(last) = ((double *)CDR(v))[2*pos]; + IMAG(last) = ((double *)CDR(v))[2*pos+1]; + return last; + } + return makdbl(((double *)CDR(v))[2*pos], + ((double *)CDR(v))[2*pos+1]); + } + else pos *= 2; + /* Fall through */ + case tc7_dvect: +# ifdef CDR_DOUBLES + if (NIMP(last) && (last != flo0) && (tc_flo==CAR(last))) { + FLO(last) = ((double *)CDR(v))[pos]; + return last; + } +# else +# ifdef SINGLES + if (NIMP(last) && tc_dblr==CAR(last)) +# else + if (NIMP(last) && (last != flo0) && (tc_dblr==CAR(last))) +# endif + { + REAL(last) = ((double *)CDR(v))[pos]; + return last; + } +# endif /* ndef CDR_DOUBLES */ + return makdbl(((double *)CDR(v))[pos], 0.0); +# endif /* def FLOATS */ + case tc7_vector: + return VELTS(v)[pos]; + case tc7_smob: { /* enclosed array */ + int k = ARRAY_NDIM(v); + if (IMP(last) || (!ARRAYP(last))) { + last = make_ra(k); + ARRAY_V(last) = ARRAY_V(v); + while (k--) { + ARRAY_DIMS(last)[k].ubnd = ARRAY_DIMS(v)[k].ubnd; + ARRAY_DIMS(last)[k].lbnd = ARRAY_DIMS(v)[k].lbnd; + ARRAY_DIMS(last)[k].inc = ARRAY_DIMS(v)[k].inc; + } + } + ARRAY_BASE(last) = pos; + return last; + } + } +} + +static char s_aset[] = "array-set!"; +SCM aset(v, obj, args) + SCM v, obj, args; +{ + long pos; + ASRTGO(NIMP(v), badarg1); + if ARRAYP(v) { + pos = aind(v, args, s_aset); + v = ARRAY_V(v); + } + else { + if NIMP(args) { + ASSERT(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_aset); + pos = INUM(CAR(args)); + ASRTGO(NULLP(CDR(args)), wna); + } + else { + ASSERT(INUMP(args), args, ARG2, s_aset); + pos = INUM(args); + } + ASRTGO(pos >= 0 && pos < LENGTH(v), outrng); + } + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_aset); + outrng: wta(MAKINUM(pos), (char *)OUTOFRANGE, s_aset); + wna: wta(UNDEFINED, (char *)WNA, s_aset); + case tc7_smob: /* enclosed */ + goto badarg1; + case tc7_bvect: + if (BOOL_F==obj) + VELTS(v)[pos/LONG_BIT] &= ~(1L<<(pos%LONG_BIT)); + else if (BOOL_T==obj) + VELTS(v)[pos/LONG_BIT] |= (1L<<(pos%LONG_BIT)); + else badarg2: wta(obj, (char *)ARG2, s_aset); + break; + case tc7_string: + ASRTGO(ICHRP(obj), badarg2); + CHARS(v)[pos] = ICHR(obj); break; +# ifdef INUMS_ONLY + case tc7_uvect: + ASRTGO(INUM(obj) >= 0, badarg2); + case tc7_ivect: + ASRTGO(INUMP(obj), badarg2); VELTS(v)[pos] = INUM(obj); break; +# else + case tc7_uvect: + VELTS(v)[pos] = num2ulong(obj, (char *)ARG2, s_aset); break; + case tc7_ivect: + VELTS(v)[pos] = num2long(obj, (char *)ARG2, s_aset); break; +# endif +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + ((float*)VELTS(v))[pos] = (float)num2dbl(obj, (char *)ARG2, s_aset); break; +# endif + case tc7_dvect: + ((double*)VELTS(v))[pos] = num2dbl(obj, (char *)ARG2, s_aset); break; + case tc7_cvect: + if (NIMP(obj) && CPLXP(obj)) { + ((double *)CDR(v))[2*pos] = REALPART(obj); + ((double *)CDR(v))[2*pos+1] = IMAG(obj); + } + else { + ((double *)CDR(v))[2*pos] = num2dbl(obj, (char *)ARG2, s_aset); + ((double *)CDR(v))[2*pos+1] = 0.0; + } + break; +# endif + case tc7_vector: + VELTS(v)[pos] = obj; break; + } + return UNSPECIFIED; +} + +static char s_array_contents[] = "array-contents"; +SCM array_contents(ra, strict) + SCM ra, strict; +{ + SCM sra; + if IMP(ra) return BOOL_F; + switch TYP7(ra) { + default: + return BOOL_F; + case tc7_vector: case tc7_string: case tc7_bvect: case tc7_uvect: + case tc7_ivect: case tc7_fvect: case tc7_dvect: case tc7_cvect: + return ra; + case tc7_smob: { + sizet k, ndim = ARRAY_NDIM(ra), len = 1; + if (!ARRAYP(ra) || !ARRAY_CONTP(ra)) return BOOL_F; + for (k = 0; k < ndim; k++) + len *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1; + if (!UNBNDP(strict)) { + if (ndim && (1 != ARRAY_DIMS(ra)[ndim-1].inc)) return BOOL_F; + if (tc7_bvect==TYP7(ARRAY_V(ra))) { + if (ARRAY_BASE(ra)%LONG_BIT) return BOOL_F; + if (len != LENGTH(ARRAY_V(ra)) && len%LONG_BIT) return BOOL_F; + } + } + if ((len==LENGTH(ARRAY_V(ra))) && 0==ARRAY_BASE(ra) && ARRAY_DIMS(ra)->inc) + return ARRAY_V(ra); + sra = make_ra(1); + ARRAY_DIMS(sra)->lbnd = 0; + ARRAY_DIMS(sra)->ubnd = len - 1; + ARRAY_V(sra) = ARRAY_V(ra); + ARRAY_BASE(sra) = ARRAY_BASE(ra); + ARRAY_DIMS(sra)->inc = (ndim ? ARRAY_DIMS(ra)[ndim - 1].inc : 1); + return sra; + } + } +} + +static char s_uve_rd[] = "uniform-vector-read!"; +SCM uve_read(v, port) + SCM v, port; +{ + long sz, len, ans; + long start=0; + if UNBNDP(port) port = cur_inp; + else ASSERT(NIMP(port) && OPINFPORTP(port), port, ARG2, s_uve_rd); + ASRTGO(NIMP(v), badarg1); + len = LENGTH(v); + loop: + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_uve_rd); + case tc7_smob: + v = array_contents(v, BOOL_T); + ASRTGO(NIMP(v), badarg1); + if ARRAYP(v) { + array_dim *d = ARRAY_DIMS(v); + start = ARRAY_BASE(v); + len = d->inc * (d->ubnd - d->lbnd + 1); + v = ARRAY_V(v); + } + else + len = LENGTH(v); + goto loop; + case tc7_string: + sz = sizeof(char); + break; + case tc7_bvect: + len = (len+LONG_BIT-1)/LONG_BIT; + start /= LONG_BIT; + case tc7_uvect: + case tc7_ivect: + sz = sizeof(long); + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + sz = sizeof(float); + break; +# endif + case tc7_dvect: + sz = sizeof(double); + break; + case tc7_cvect: + sz = 2*sizeof(double); + break; +# endif + } + /* An ungetc before an fread will not work on some systems if setbuf(0). + do #define NOSETBUF in scmfig.h to fix this. */ + if CRDYP(port) { /* UGGH!!! */ + ungetc(CGETUN(port), STREAM(port)); + CLRDY(port); /* Clear ungetted char */ + } + SYSCALL(ans = fread(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port));); + if (TYP7(v)==tc7_bvect) ans *= LONG_BIT; + return MAKINUM(ans); +} + +static char s_uve_wr[] = "uniform-vector-write"; +SCM uve_write(v, port) + SCM v, port; +{ + long sz, len, ans; + long start=0; + if UNBNDP(port) port = cur_outp; + else ASSERT(NIMP(port) && OPOUTFPORTP(port), port, ARG2, s_uve_wr); + ASRTGO(NIMP(v), badarg1); + len = LENGTH(v); + loop: + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_uve_wr); + case tc7_smob: + v = array_contents(v, BOOL_T); + ASRTGO(NIMP(v), badarg1); + if ARRAYP(v) { + array_dim *d = ARRAY_DIMS(v); + start = ARRAY_BASE(v); + len = d->inc * (d->ubnd - d->lbnd + 1); + v = ARRAY_V(v); + } + else + len = LENGTH(v); + goto loop; + case tc7_string: + sz = sizeof(char); + break; + case tc7_bvect: + len = (len+LONG_BIT-1)/LONG_BIT; + start /= LONG_BIT; + case tc7_uvect: + case tc7_ivect: + sz = sizeof(long); + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + sz = sizeof(float); + break; +# endif + case tc7_dvect: + sz = sizeof(double); + break; + case tc7_cvect: + sz = 2*sizeof(double); + break; +# endif + } + SYSCALL(ans = fwrite(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port));); + if (TYP7(v)==tc7_bvect) ans *= LONG_BIT; + return MAKINUM(ans); +} + +static char cnt_tab[16] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; +static char s_count[] = "bit-count"; +SCM lcount(item, seq) + SCM item, seq; +{ + long i, imin, ubnd, lbnd = 0; + int enclosed = 0; + register unsigned long cnt = 0, w; + ASSERT(NIMP(seq), seq, ARG2, s_count); + ubnd = LENGTH(seq) - 1; + tail: + switch TYP7(seq) { + default: badarg2: wta(seq, (char *)ARG2, s_count); + case tc7_bvect: + if (lbnd>ubnd) return INUM0; + i = ubnd/LONG_BIT; + imin = lbnd/LONG_BIT; + w = VELTS(seq)[i]; + if FALSEP(item) w = ~w; + w <<= LONG_BIT-1-(ubnd%LONG_BIT); + w >>= LONG_BIT-1-(ubnd%LONG_BIT); /* There may be only a partial word. */ + while (imin < i--) { + for(;w;w >>= 4) cnt += cnt_tab[w & 0x0f]; + w = VELTS(seq)[i]; + if FALSEP(item) w = ~w; + } + w >>= (lbnd%LONG_BIT); + for(;w;w >>= 4) cnt += cnt_tab[w & 0x0f]; + return MAKINUM(cnt); + case tc7_smob: + ASRTGO(ARRAYP(seq) && 1==ARRAY_NDIM(seq) && 0==enclosed++, badarg2); + { + long n, inc = ARRAY_DIMS(seq)->inc; + switch (inc) { + default: + i = ARRAY_BASE(seq); + n = ARRAY_DIMS(seq)->ubnd - ARRAY_DIMS(seq)->lbnd + 1; + if (n<=0) return INUM0; + seq = ARRAY_V(seq); + if FALSEP(item) + for (;n--; i+=inc) + if (!((VELTS(seq)[i/LONG_BIT]) & (1L<<(i%LONG_BIT)))) cnt++; + else + for (;n--; i+=inc) + if ((VELTS(seq)[i/LONG_BIT]) & (1L<<(i%LONG_BIT))) cnt++; + return MAKINUM(cnt); + case 1: + lbnd = ARRAY_BASE(seq); + ubnd = lbnd + (ARRAY_DIMS(seq)->ubnd - ARRAY_DIMS(seq)->lbnd)*inc; + seq = ARRAY_V(seq); + goto tail; + case -1: + ubnd = ARRAY_BASE(seq); + lbnd = ubnd + (ARRAY_DIMS(seq)->ubnd - ARRAY_DIMS(seq)->lbnd)*inc; + seq = ARRAY_V(seq); + goto tail; + } + } + } +} +static char s_uve_pos[] = "bit-position"; +SCM position(item, v, k) + SCM item, v, k; +{ + long i, len, lenw, xbits, pos = INUM(k), offset = 0; + int enclosed = 0; + register unsigned long w; + ASSERT(NIMP(v), v, ARG2, s_uve_pos); + ASSERT(INUMP(k), k, ARG3, s_uve_pos); + len = LENGTH(v); + tail: + switch TYP7(v) { + default: badarg2: wta(v, (char *)ARG2, s_uve_pos); + case tc7_bvect: + ASSERT((pos <= len) && (pos >= 0), k, OUTOFRANGE, s_uve_pos); + if (pos==len) return BOOL_F; + if (0==len) return MAKINUM(-1L); + lenw = (len-1)/LONG_BIT; /* watch for part words */ + i = pos/LONG_BIT; + w = VELTS(v)[i]; + if FALSEP(item) w = ~w; + xbits = (pos%LONG_BIT); + pos -= xbits; + w = ((w >> xbits) << xbits); + xbits = LONG_BIT-1-(len-1)%LONG_BIT; + while (!0) { + if (w && (i==lenw)) + w = ((w << xbits) >> xbits); + if (w) while (w) switch (w & 0x0f) + { + default: return MAKINUM(pos-offset); + case 2: case 6: case 10: case 14: return MAKINUM(pos+1-offset); + case 4: case 12: return MAKINUM(pos+2-offset); + case 8: return MAKINUM(pos+3-offset); + case 0: pos += 4; w >>= 4; + } + if (++i > lenw) break; + pos += LONG_BIT; + w = VELTS(v)[i]; + if FALSEP(item) w = ~w; + } + return BOOL_F; + case tc7_smob: ASRTGO(ARRAYP(v) && 1==ARRAY_NDIM(v) && !enclosed++, badarg2); + ASSERT(pos >= ARRAY_DIMS(v)->lbnd, k, OUTOFRANGE, s_uve_pos); + if (1==ARRAY_DIMS(v)->inc) { + len = ARRAY_DIMS(v)->ubnd - ARRAY_DIMS(v)->lbnd + ARRAY_BASE(v) + 1; + offset = ARRAY_BASE(v) - ARRAY_DIMS(v)->lbnd; + pos += offset; + v = ARRAY_V(v); + goto tail; + } + else { + long inc = ARRAY_DIMS(v)->inc; + long ubnd = ARRAY_DIMS(v)->ubnd; + if (ubnd < ARRAY_DIMS(v)->lbnd) + return MAKINUM(ARRAY_DIMS(v)->lbnd - 1); + i = ARRAY_BASE(v) + (pos - ARRAY_DIMS(v)->lbnd)*inc; + v = ARRAY_V(v); + for (; pos <= ubnd; pos++) { + if (item == + ((VELTS(v)[i/LONG_BIT])&(1L<<(i%LONG_BIT)) ? BOOL_T : BOOL_F)) + return MAKINUM(pos); + i += inc; + } + return BOOL_F; + } + } +} + +static char s_bit_set[] = "bit-set*!"; +SCM bit_set(v, kv, obj) + SCM v, kv, obj; +{ + register long i, k, vlen; + ASRTGO(NIMP(v), badarg1); + ASRTGO(NIMP(kv), badarg2); + switch TYP7(kv) { + default: badarg2: wta(kv, (char *)ARG2, s_bit_set); + case tc7_uvect: + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_bit_set); + case tc7_bvect: + vlen = LENGTH(v); + if (BOOL_F==obj) for (i = LENGTH(kv);i;) { + k = VELTS(kv)[--i]; + ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_set); + VELTS(v)[k/LONG_BIT] &= ~(1L<<(k%LONG_BIT)); + } + else if (BOOL_T==obj) for (i = LENGTH(kv); i;) { + k = VELTS(kv)[--i]; + ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_set); + VELTS(v)[k/LONG_BIT] |= (1L<<(k%LONG_BIT)); + } + else + badarg3: wta(obj, (char *)ARG3, s_bit_set); + } + break; + case tc7_bvect: + ASRTGO(TYP7(v)==tc7_bvect && LENGTH(v)==LENGTH(kv), badarg1); + if (BOOL_F==obj) + for (k = (LENGTH(v)+LONG_BIT-1)/LONG_BIT;k--;) + VELTS(v)[k] &= ~(VELTS(kv)[k]); + else if (BOOL_T==obj) + for (k = (LENGTH(v)+LONG_BIT-1)/LONG_BIT;k--;) + VELTS(v)[k] |= VELTS(kv)[k]; + else goto badarg3; + break; + } + return UNSPECIFIED; +} + +static char s_bit_count[] = "bit-count*"; +SCM bit_count(v, kv, obj) + SCM v, kv, obj; +{ + register long i, vlen, count = 0; + register unsigned long k; + ASRTGO(NIMP(v), badarg1); + ASRTGO(NIMP(kv), badarg2); + switch TYP7(kv) { + default: badarg2: wta(kv, (char *)ARG2, s_bit_count); + case tc7_uvect: + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_bit_count); + case tc7_bvect: + vlen = LENGTH(v); + if (BOOL_F==obj) for (i = LENGTH(kv);i;) { + k = VELTS(kv)[--i]; + ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_count); + if (!(VELTS(v)[k/LONG_BIT] & (1L<<(k%LONG_BIT)))) count++; + } + else if (BOOL_T==obj) for (i = LENGTH(kv); i;) { + k = VELTS(kv)[--i]; + ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_count); + if (VELTS(v)[k/LONG_BIT] & (1L<<(k%LONG_BIT))) count++; + } + else + badarg3: wta(obj, (char *)ARG3, s_bit_count); + } + break; + case tc7_bvect: + ASRTGO(TYP7(v)==tc7_bvect && LENGTH(v)==LENGTH(kv), badarg1); + if (0==LENGTH(v)) return INUM0; + ASRTGO(BOOL_T==obj || BOOL_F==obj, badarg3); + obj = (BOOL_T==obj); + i = (LENGTH(v)-1)/LONG_BIT; + k = VELTS(kv)[i] & (obj ? VELTS(v)[i] : ~VELTS(v)[i]); + k <<= LONG_BIT-1-((LENGTH(v)-1)%LONG_BIT); + while (!0) { + for(;k;k >>= 4) count += cnt_tab[k & 0x0f]; + if (0==i--) return MAKINUM(count); + k = VELTS(kv)[i] & (obj ? VELTS(v)[i] : ~VELTS(v)[i]); + } + } + return MAKINUM(count); +} + +static char s_bit_inv[] = "bit-invert!"; +SCM bit_inv(v) + SCM v; +{ + register long k; + ASRTGO(NIMP(v), badarg1); + k = LENGTH(v); + switch TYP7(v) { + case tc7_bvect: + for (k = (k+LONG_BIT-1)/LONG_BIT;k--;) + VELTS(v)[k] = ~VELTS(v)[k]; + break; + default: badarg1: wta(v, (char *)ARG1, s_bit_inv); + } + return UNSPECIFIED; +} + +static char s_strup[] = "string-upcase!"; +SCM strup(v) + SCM v; +{ + register long k; + register unsigned char *cs; + ASRTGO(NIMP(v), badarg1); + k = LENGTH(v); + switch TYP7(v) { + case tc7_string: + cs = UCHARS(v); + while (k--) cs[k] = upcase[cs[k]]; + break; + default: badarg1: wta(v, (char *)ARG1, s_strup); + } + return v; +} + +static char s_strdown[] = "string-downcase!"; +SCM strdown(v) + SCM v; +{ + register long k; + register unsigned char *cs; + ASRTGO(NIMP(v), badarg1); + k = LENGTH(v); + switch TYP7(v) { + case tc7_string: + cs = UCHARS(v); + while (k--) cs[k] = downcase[cs[k]]; + break; + default: badarg1: wta(v, (char *)ARG1, s_strdown); + } + return v; +} + +# include +static char s_strcap[] = "string-capitalize!"; +SCM strcap(v) + SCM v; +{ + long i = 0, len; + register unsigned char *str; + register int non_first_alpha = 0; + ASRTGO(NIMP(v), badarg1); + len = LENGTH(v); + switch TYP7(v) { + case tc7_string: + for (str = UCHARS(v);i < len; i++) { + int c = str[i]; + if (isascii(c) && isalpha(c)) + if (non_first_alpha) str[i] = downcase[c]; + else { + non_first_alpha = !0; + str[i] = upcase[c]; + } + else non_first_alpha = 0; + } + break; + default: badarg1: wta(v, (char *)ARG1, s_strcap); + } + return v; +} + +SCM istr2bve(str, len) + char *str; + long len; +{ + SCM v = make_uve(len, BOOL_T); + long *data = (long *)VELTS(v); + register unsigned long mask; + register long k; + register long j; + for (k = 0; k < (len+LONG_BIT-1)/LONG_BIT; k++) { + data[k] = 0L; + j = len - k*LONG_BIT; + if (j > LONG_BIT) j = LONG_BIT; + for (mask = 1L; j--; mask <<= 1) + switch (*str++) { + case '0': break; + case '1': data[k] |= mask; break; + default: return BOOL_F; + } + } + return v; +} + +static SCM ra2l(ra, base, k) + SCM ra; + sizet base; + sizet k; +{ + register SCM res = EOL; + register long inc = ARRAY_DIMS(ra)[k].inc; + register sizet i; + if (ARRAY_DIMS(ra)[k].ubnd < ARRAY_DIMS(ra)[k].lbnd) return EOL; + i = base + (1 + ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd)*inc; + if (k < ARRAY_NDIM(ra) - 1) { + do { + i -= inc; + res = cons(ra2l(ra, i, k+1), res); + } while (i != base); + } + else + do { + i -= inc; + res = cons(cvref(ARRAY_V(ra), i, UNDEFINED), res); + } while (i != base); + return res; +} + +static char s_array2list[] = "array->list"; +SCM array2list(v) + SCM v; +{ + SCM res = EOL; + register long k; + ASRTGO(NIMP(v), badarg1); + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_array2list); + case tc7_smob: ASRTGO(ARRAYP(v), badarg1); + return ra2l(v, ARRAY_BASE(v), 0); + case tc7_vector: return vector2list(v); + case tc7_string: return string2list(v); + case tc7_bvect: { + long *data = (long *)VELTS(v); + register unsigned long mask; + for (k = (LENGTH(v)-1)/LONG_BIT; k > 0; k--) + for (mask = 1L<<(LONG_BIT-1); mask; mask >>=1) + res = cons(((long *)data)[k] & mask ? BOOL_T : BOOL_F, res); + for (mask = 1L<<((LENGTH(v)%LONG_BIT)-1); mask; mask >>=1) + res = cons(((long *)data)[k] & mask ? BOOL_T : BOOL_F, res); + return res; + } +# ifdef INUMS_ONLY + case tc7_uvect: + case tc7_ivect: { + long *data = (long *)VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(MAKINUM(data[k]), res); + return res; + } +# else + case tc7_uvect: { + long *data = (long *)VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(ulong2num(data[k]), res); + return res; + } + case tc7_ivect: { + long *data = (long *)VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(long2num(data[k]), res); + return res; + } +# endif +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *data = (float *)VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(makflo(data[k]), res); + return res; + } +# endif /*SINGLES*/ + case tc7_dvect: { + double *data = (double *)VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(makdbl(data[k], 0.0), res); + return res; + } + case tc7_cvect: { + double (*data)[2] = (double (*)[2])VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(makdbl(data[k][0], data[k][1]), res); + return res; + } +# endif /*FLOATS*/ + } +} + +static int l2ra P((SCM lst, SCM ra, sizet base, sizet k)); +static char s_bad_ralst[] = "Bad array contents list"; +static char s_list2ura[] = "list->uniform-array"; +SCM list2ura(ndim, prot, lst) + SCM ndim; + SCM prot; + SCM lst; +{ + SCM shp=EOL; + SCM row=lst; + SCM ra; + sizet k; + long n; + ASSERT(INUMP(ndim), ndim, ARG1, s_list2ura); + k = INUM(ndim); + for (; k--; NIMP(row) && (row = CAR(row))) { + n = ilength(row); + ASSERT(n>=0, lst, ARG2, s_list2ura); + shp = cons(MAKINUM(n), shp); + } + ra = dims2ura(reverse(shp), prot, EOL); + if NULLP(shp) { + ASRTGO(1==ilength(lst), badlst); + aset(ra, CAR(lst), EOL); + return ra; + } + if (!ARRAYP(ra)) { + for (k = 0; k < LENGTH(ra); k++, lst = CDR(lst)) + aset(ra, CAR(lst), MAKINUM(k)); + return ra; + } + if (l2ra(lst, ra, ARRAY_BASE(ra), 0)) + return ra; + else + badlst: wta(lst, s_bad_ralst, s_list2ura); + return BOOL_F; +} + +static int l2ra(lst, ra, base, k) + SCM lst; + SCM ra; + sizet base; + sizet k; +{ + register long inc = ARRAY_DIMS(ra)[k].inc; + register long n = (1 + ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd); + int ok = 1; + if (n <= 0) return (EOL==lst); + if (k < ARRAY_NDIM(ra) - 1) { + while (n--) { + if (IMP(lst) || NCONSP(lst)) return 0; + ok = ok && l2ra(CAR(lst), ra, base, k+1); + base += inc; + lst = CDR(lst); + } + if NNULLP(lst) return 0; + } + else { + while (n--) { + if (IMP(lst) || NCONSP(lst)) return 0; + ok = ok && aset(ARRAY_V(ra), CAR(lst), MAKINUM(base)); + base += inc; + lst = CDR(lst); + } + if NNULLP(lst) return 0; + } + return ok; +} + +static void rapr1(ra, j, k, port, writing) + SCM ra; + sizet j; + sizet k; + SCM port; + int writing; +{ + long inc = 1; + long n = LENGTH(ra); + int enclosed = 0; + tail: + switch TYP7(ra) { + case tc7_smob: + if (enclosed++) { + ARRAY_BASE(ra) = j; + if (n-- > 0) iprin1(ra, port, writing); + for (j += inc; n-- > 0; j += inc) { + lputc(' ', port); + ARRAY_BASE(ra) = j; + iprin1(ra, port, writing); + } + break; + } + if (k+1 < ARRAY_NDIM(ra)) { + long i; + inc = ARRAY_DIMS(ra)[k].inc; + for (i = ARRAY_DIMS(ra)[k].lbnd; i < ARRAY_DIMS(ra)[k].ubnd; i++) { + lputc('(', port); + rapr1(ra, j, k+1, port, writing); + lputs(") ", port); + j += inc; + } + if (i==ARRAY_DIMS(ra)[k].ubnd) { /* could be zero size. */ + lputc('(', port); + rapr1(ra, j, k+1, port, writing); + lputc(')', port); + } + break; + } + if ARRAY_NDIM(ra) { /* Could be zero-dimensional */ + inc = ARRAY_DIMS(ra)[k].inc; + n = (ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1); + } + else + n = 1; + ra = ARRAY_V(ra); + goto tail; + default: + if (n-- > 0) iprin1(cvref(ra, j, UNDEFINED), port, writing); + for (j += inc; n-- > 0; j += inc) { + lputc(' ', port); + iprin1(cvref(ra, j, UNDEFINED), port, writing); + } + break; + case tc7_string: + if (n-- > 0) iprin1(MAKICHR(CHARS(ra)[j]), port, writing); + if (writing) + for (j += inc; n-- > 0; j += inc) { + lputc(' ', port); + iprin1(MAKICHR(CHARS(ra)[j]), port, writing); + } + else + for (j += inc; n-- > 0; j += inc) + lputc(CHARS(ra)[j], port); + break; + case tc7_uvect: + if (n-- > 0) iprin1(ulong2num(VELTS(ra)[j]), port, writing); + for (j += inc; n-- > 0; j += inc) { + lputc(' ', port); + iprin1(ulong2num(VELTS(ra)[j]), port, writing); + } + break; + case tc7_ivect: + if (n-- > 0) intprint(VELTS(ra)[j], 10, port); + for (j += inc; n-- > 0; j += inc) { + lputc(' ', port); + intprint(VELTS(ra)[j], 10, port); + } + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: +# endif /*SINGLES*/ + case tc7_dvect: + case tc7_cvect: + if (n-- > 0) { + SCM z = cvref(ra, j, UNDEFINED); + floprint(z, port, writing); + for (j += inc; n-- > 0; j += inc) { + lputc(' ', port); + z = cvref(ra, j, z); + floprint(z, port, writing); + } + } + break; +# endif /*FLOATS*/ + } +} +int raprin1(exp, port, writing) + SCM exp; + SCM port; + int writing; +{ + SCM v = exp; + sizet base = 0; + lputc('#', port); + tail: + switch TYP7(v) { + case tc7_smob: { + long ndim = ARRAY_NDIM(v); + base = ARRAY_BASE(v); + v = ARRAY_V(v); + if ARRAYP(v) { + lputs("', port); + return 1; + } + else { + intprint(ndim, 10, port); + goto tail; + } + } + case tc7_bvect: + if (exp==v) { /* a uve, not an array */ + register long i, j, w; + lputc('*', port); + for(i = 0;i<(LENGTH(exp))/LONG_BIT;i++) { + w = VELTS(exp)[i]; + for(j = LONG_BIT;j;j--) { + lputc(w&1?'1':'0', port); + w >>= 1; + } + } + j = LENGTH(exp)%LONG_BIT; + if (j) { + w = VELTS(exp)[LENGTH(exp)/LONG_BIT]; + for(;j;j--) { + lputc(w&1?'1':'0', port); + w >>= 1; + } + } + return 1; + } + else + lputc('b', port); break; + case tc7_string: + lputc('a', port); break; + case tc7_uvect: + lputc('u', port); break; + case tc7_ivect: + lputc('e', port); break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + lputc('s', port); break; +# endif /*SINGLES*/ + case tc7_dvect: + lputc('i', port); break; + case tc7_cvect: + lputc('c', port); break; +# endif /*FLOATS*/ + } + lputc('(', port); + rapr1(exp, base, 0, port, writing); + lputc(')', port); + return 1; +} + +static char s_array_prot[] = "array-prototype"; +SCM array_prot(ra) + SCM ra; +{ + int enclosed = 0; + ASRTGO(NIMP(ra), badarg); + loop: + switch TYP7(ra) { + default: badarg: wta(ra, (char *)ARG1, s_array_prot); + case tc7_smob: ASRTGO(ARRAYP(ra), badarg); + if (enclosed++) return UNSPECIFIED; + ra = ARRAY_V(ra); + goto loop; + case tc7_vector: return EOL; + case tc7_bvect: return BOOL_T; + case tc7_string: return MAKICHR('a'); + case tc7_uvect: return MAKINUM(1L); + case tc7_ivect: return MAKINUM(-1L); +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: return makflo(1.0); +# endif + case tc7_dvect: return makdbl(1.0/3.0, 0.0); + case tc7_cvect: return makdbl(0.0, 1.0); +# endif + } +} + +static iproc subr3s[] = { + {"uniform-vector-set1!", aset}, + {s_uve_pos, position}, + {s_bit_set, bit_set}, + {s_bit_count, bit_count}, + {s_list2ura, list2ura}, + {0, 0}}; + +static iproc subr2s[] = { + {"uniform-vector-ref", aref}, + {s_resizuve, resizuve}, + {s_count, lcount}, + {s_uve_fill, uve_fill}, + {0, 0}}; + +static iproc subr1s[] = { + {"array-rank", array_rank}, + {s_array_dims, array_dims}, + {s_array2list, array2list}, + {s_uve_len, uve_len}, + {s_bit_inv, bit_inv}, + {s_strdown, strdown}, + {s_strcap, strcap}, + {s_strup, strup}, + {s_array_prot, array_prot}, + {0, 0}}; + +static iproc lsubrs[] = { + {s_aref, scm_array_ref}, + {s_trans_array, trans_array}, + {s_encl_array, encl_array}, + {s_array_inbp, array_inbp}, + {0, 0}}; + +static iproc lsubr2s[] = { + {s_make_sh_array, make_sh_array}, + {s_dims2ura, dims2ura}, + {s_aset, aset}, + {0, 0}}; + +static iproc subr2os[] = { + {"array?", arrayp}, + {s_array_contents, array_contents}, + {s_uve_rd, uve_read}, + {s_uve_wr, uve_write}, + {0, 0}}; + +static SCM markra(ptr) + SCM ptr; +{ + if GC8MARKP(ptr) return BOOL_F; + SETGC8MARK(ptr); + return ARRAY_V(ptr); +} +static sizet freera(ptr) + CELLPTR ptr; +{ + must_free(CHARS(ptr)); + return sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim); +} +static smobfuns rasmob = {markra, freera, raprin1, 0}; + /* 0 replaced by raequal in init_ramap() */ + +/* This must be done after init_scl() */ +void init_unif() +{ + init_iprocs(subr3s, tc7_subr_3); + init_iprocs(subr2s, tc7_subr_2); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(lsubrs, tc7_lsubr); + init_iprocs(lsubr2s, tc7_lsubr_2); + init_iprocs(subr2os, tc7_subr_2o); + tc16_array = newsmob(&rasmob); + add_feature(s_array); + add_feature("string-case"); +} + +#else /* ARRAYS */ + +int raprin1(exp, port, writing) + SCM exp; + SCM port; + int writing; +{ + return 0; +} + +SCM istr2bve(str, len) + char *str; + long len; +{ + return BOOL_F; +} + +SCM array_equal(ra0, ra1) + SCM ra0, ra1; +{ + return BOOL_F; +} + +void init_unif() +{ + make_subr(s_resizuve, tc7_subr_2, resizuve); +} + +#endif /* ARRAYS */ -- cgit v1.2.3