From 3278b75942bdbe706f7a0fba87729bb1e935b68b Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 5d2 --- unif.c | 345 ++++++++++++++++++++++++++++++++++++----------------------------- 1 file changed, 192 insertions(+), 153 deletions(-) (limited to 'unif.c') diff --git a/unif.c b/unif.c index 35fc86e..88250c2 100644 --- a/unif.c +++ b/unif.c @@ -9,10 +9,10 @@ * 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. + * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. @@ -36,7 +36,7 @@ * * 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. + * If you do not wish that, delete this exception notice. */ /* "unif.c" Uniform vectors and arrays @@ -61,19 +61,22 @@ complex double cvect #endif long tc16_array = 0; +static SCM i_short; char s_resizuve[] = "vector-set-length!"; SCM resizuve(vect, len) SCM vect, len; { - long l = INUM(len); + long ol, l = INUM(len); sizet siz, sz; ASRTGO(NIMP(vect), badarg1); + ol = LENGTH(vect); switch TYP7(vect) { default: badarg1: wta(vect, (char *)ARG1, s_resizuve); case tc7_string: ASRTGO(vect != nullstr, badarg1); sz = sizeof(char); + ol++; l++; break; case tc7_vector: @@ -82,17 +85,19 @@ SCM resizuve(vect, len) break; #ifdef ARRAYS case tc7_bvect: + ol = (ol+LONG_BIT-1)/LONG_BIT; l = (l+LONG_BIT-1)/LONG_BIT; case tc7_uvect: case tc7_ivect: sz = sizeof(long); break; + case tc7_svect: + sz = sizeof(short); + break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: sz = sizeof(float); break; -# endif case tc7_dvect: sz = sizeof(double); break; @@ -107,13 +112,12 @@ SCM resizuve(vect, len) siz = l * sz; if (siz != l * sz) wta(MAKINUM(l * sz), (char *) NALLOC, s_resizuve); DEFER_INTS; - must_realloc_cell(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; + must_realloc_cell(vect, (long)ol*sz, (long)siz, s_resizuve); + if VECTORP(vect) + while(l > ol) + VELTS(vect)[--l] = UNSPECIFIED; + else if STRINGP(vect) + CHARS(vect)[l-1] = 0; SETLENGTH(vect, INUM(len), TYP7(vect)); ALLOW_INTS; return vect; @@ -135,64 +139,85 @@ SCM makflo (x) ALLOW_INTS; return z; } +# else +# define makflo(x) makdbl((double)(x), 0.0) # endif # endif +long scm_prot2type(prot) + SCM prot; +{ + if (BOOL_T==prot) return tc7_bvect; + if ICHRP(prot) return tc7_string; + if INUMP(prot) + return INUM(prot)>0 ? tc7_uvect : tc7_ivect; + if (i_short==prot) return tc7_svect; + if IMP(prot) return tc7_vector; +# ifdef FLOATS + if INEXP(prot) { + double x; + float fx; + if CPLXP(prot) return tc7_cvect; + x = REALPART(prot); + fx = x; + return (x == fx) ? tc7_fvect : tc7_dvect; + } +# endif +# ifdef BIGDIG + if (TYP16(prot)==tc16_bigpos) { + if (DIGSPERLONG < NUMDIGS(prot)) return tc7_vector; + return tc7_uvect; + } + if (TYP16(prot)==tc16_bigneg) { + long res = 0; + sizet l = NUMDIGS(prot); + if (DIGSPERLONG < l) return tc7_vector; + for(;l--;) res = BIGUP(res) + BDIGITS(prot)[l]; + if (0>=res) return tc7_vector; + return tc7_ivect; + } +# endif +} + SCM make_uve(k, prot) long k; SCM prot; { SCM v; - long i, type; - if (BOOL_T==prot) { + long i; + long type = scm_prot2type(prot); + switch (type) { + default: + case tc7_vector: /* Huge non-unif vectors are NOT supported. */ + return make_vector(MAKINUM(k), UNDEFINED); /* no special vector */ + case tc7_bvect: i = sizeof(long)*((k+LONG_BIT-1)/LONG_BIT); - type = tc7_bvect; - } - else if ICHRP(prot) { + break; + case tc7_string: i = sizeof(char)*(k + 1); - type = tc7_string; - } - else if INUMP(prot) { + break; + case tc7_uvect: + case tc7_ivect: 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 */ + break; + case tc7_svect: + i = sizeof(short)*k; # 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 { + case tc7_fvect: + i = sizeof(float)*k; + break; + case tc7_dvect: i = sizeof(double)*k; - type = tc7_dvect; - } + break; + case tc7_cvect: + i = 2*sizeof(double)*k; + break; # endif + } DEFER_INTS; - v = must_malloc_cell((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:; + case tc7_svect: + case tc7_fvect: + case tc7_dvect: + case tc7_cvect: + case tc7_vector: + if (UNBNDP(prot)) return BOOL_T; + if (scm_prot2type(prot)==typ) return BOOL_T; } return BOOL_F; } @@ -253,9 +270,8 @@ SCM array_rank(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: + case tc7_vector: + case tcs_uves: return MAKINUM(1L); case tc7_smob: if ARRAYP(ra) return MAKINUM(ARRAY_NDIM(ra)); @@ -272,9 +288,8 @@ SCM array_dims(ra) 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: + case tc7_vector: + case tcs_uves: return cons(MAKINUM(LENGTH(ra)), EOL); case tc7_smob: if (!ARRAYP(ra)) return BOOL_F; @@ -323,8 +338,9 @@ SCM make_ra(ndim) { SCM ra; DEFER_INTS; - ra = must_malloc_cell((long)(sizeof(array)+ndim*sizeof(array_dim)), "array"); - CAR(ra) = ((long)ndim << 17) + tc16_array; + ra = must_malloc_cell(sizeof(array)+((long)ndim)*sizeof(array_dim), + (((long)ndim) << 17) + tc16_array, + "array"); ARRAY_V(ra) = nullvect; ALLOW_INTS; return ra; @@ -355,7 +371,7 @@ SCM shap2ra(args, what) 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)), + ASSERT(NIMP(sp) && INUMP(CAR(sp)) && NULLP(CDR(sp)), spec, s_bad_spec, what); s->ubnd = INUM(CAR(sp)); s->inc = 1; @@ -444,7 +460,6 @@ int rafill(ra, fill, ignore) break; } # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: { float *ve = (float *)VELTS(ra); float f = num2dbl(fill, (char *)ARG2, s_uve_fill); @@ -452,7 +467,6 @@ int rafill(ra, fill, ignore) ve[i] = f; break; } -# endif /* SINGLES */ case tc7_dvect: { double *ve = (double *)VELTS(ra); double f = num2dbl(fill, (char *)ARG2, s_uve_fill); @@ -564,9 +578,8 @@ SCM make_sh_array(oldra, mapfunc, dims) SCM mapfunc; SCM dims; { - SCM ra; - SCM inds, indptr; - SCM imap; + SCM ra, imap, auto_indv[5], hp_indv; + SCM *indv = auto_indv; sizet i, k; long old_min, new_min, old_max, new_max; array_dim *s; @@ -590,10 +603,14 @@ SCM make_sh_array(oldra, mapfunc, dims) old_min = 0; old_max = (long)LENGTH(oldra) - 1; } - inds = EOL; + if (ARRAY_NDIM(ra) > 5) { + scm_protect_temp(&hp_indv); + hp_indv = make_vector(MAKINUM(ARRAY_NDIM(ra)), BOOL_F); + indv = VELTS(hp_indv); + } s = ARRAY_DIMS(ra); for (k = 0; k < ARRAY_NDIM(ra); k++) { - inds = cons(MAKINUM(s[k].lbnd), inds); + indv[k] = MAKINUM(s[k].lbnd); if (s[k].ubnd < s[k].lbnd) { if (1==ARRAY_NDIM(ra)) ra = make_uve(0L, array_prot(ra)); @@ -602,7 +619,7 @@ SCM make_sh_array(oldra, mapfunc, dims) return ra; } } - imap = apply(mapfunc, reverse(inds), EOL); + imap = scm_cvapply(mapfunc, ARRAY_NDIM(ra), indv); if ARRAYP(oldra) i = (sizet)aind(oldra, imap, s_make_sh_array); else { @@ -614,12 +631,13 @@ SCM make_sh_array(oldra, mapfunc, dims) 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); + /* CAR(indptr) = MAKINUM(INUM(CAR(indptr))+1); + imap = apply(mapfunc, reverse(inds), EOL); */ + indv[k] = MAKINUM(INUM(indv[k]) + 1); + imap = scm_cvapply(mapfunc, ARRAY_NDIM(ra), indv); if ARRAYP(oldra) s[k].inc = aind(oldra, imap, s_make_sh_array) - i; else { @@ -638,7 +656,6 @@ SCM make_sh_array(oldra, mapfunc, dims) } 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); @@ -664,8 +681,8 @@ SCM trans_array(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: + case tc7_vector: + case tcs_uves: ASSERT(NIMP(args) && NULLP(CDR(args)), UNDEFINED, WNA, s_trans_array); ASSERT(INUM0==CAR(args), CAR(args), ARG1, s_trans_array); return ra; @@ -732,8 +749,8 @@ SCM encl_array(axes) 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: + case tc7_vector: + case tcs_uves: s->lbnd = 0; s->ubnd = LENGTH(ra) - 1; s->inc = 1; @@ -785,7 +802,7 @@ SCM array_inbp(args) if IMP(v) goto scalar; switch TYP7(v) { wna: wta(UNDEFINED, (char *)WNA, s_array_inbp); - default: scalar: + default: scalar: if NULLP(args) return BOOL_T; wta(v, (char *)ARG1, s_array_inbp); case tc7_smob: @@ -806,8 +823,8 @@ SCM array_inbp(args) 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: + case tc7_vector: + case tcs_uves: ASRTGO(NIMP(args) && NULLP(CDR(args)), wna); ind = CAR(args); ASSERT(INUMP(ind), ind, s_bad_ind, s_array_inbp); @@ -867,6 +884,8 @@ SCM aref(v, args) else return BOOL_F; case tc7_string: return MAKICHR(CHARS(v)[pos]); + case tc7_svect: + return MAKINUM(((short *)CDR(v))[pos]); # ifdef INUMS_ONLY case tc7_uvect: case tc7_ivect: @@ -878,10 +897,8 @@ SCM aref(v, args) 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: @@ -914,6 +931,8 @@ SCM cvref(v, pos, last) else return BOOL_F; case tc7_string: return MAKICHR(CHARS(v)[pos]); + case tc7_svect: + return MAKINUM(((short *)CDR(v))[pos]); # ifdef INUMS_ONLY case tc7_uvect: case tc7_ivect: @@ -925,13 +944,19 @@ SCM cvref(v, pos, last) return long2num(VELTS(v)[pos]); # endif # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: +# ifdef SINGLES if (NIMP(last) && (last != flo0) && (tc_flo==CAR(last))) { FLO(last) = ((float *)CDR(v))[pos]; return last; } return makflo(((float *)CDR(v))[pos]); +# else /* ndef SINGLES */ + if (NIMP(last) && (last != flo0) && (tc_dblr==CAR(last))) { + REAL(last) = ((float *)CDR(v))[pos]; + return last; + } + return makdbl((double)((float *)CDR(v))[pos], 0.0); # endif case tc7_cvect: if (0.0!=((double *)CDR(v))[2*pos+1]) { @@ -1021,6 +1046,8 @@ SCM aset(v, obj, args) case tc7_string: ASRTGO(ICHRP(obj), badarg2); CHARS(v)[pos] = ICHR(obj); break; + case tc7_svect: + ((short *)VELTS(v))[pos] = num2short(obj, (char *)ARG2, s_aset); break; # ifdef INUMS_ONLY case tc7_uvect: ASRTGO(INUM(obj) >= 0, badarg2); @@ -1033,10 +1060,8 @@ SCM aset(v, obj, args) 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: @@ -1065,8 +1090,8 @@ SCM array_contents(ra, strict) 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: + case tc7_vector: + case tcs_uves: return ra; case tc7_smob: { sizet k, ndim = ARRAY_NDIM(ra), len = 1; @@ -1128,12 +1153,13 @@ SCM uve_read(v, port) case tc7_ivect: sz = sizeof(long); break; + case tc7_svect: + sz = sizeof(short); + break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: sz = sizeof(float); break; -# endif case tc7_dvect: sz = sizeof(double); break; @@ -1142,11 +1168,15 @@ SCM uve_read(v, port) 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 */ + if (0==len) return INUM0; + /* An ungetc before an fread will not work on some systems if setbuf(0), + so we read one element char by char. */ + if CRDYP(port) { + int i; + for (i = 0; i < sz; i++) + CHARS(v)[start*sz + i] = lgetc(port); + start += 1; + len -= 1; } SYSCALL(ans = fread(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port));); if (TYP7(v)==tc7_bvect) ans *= LONG_BIT; @@ -1188,12 +1218,13 @@ SCM uve_write(v, port) case tc7_ivect: sz = sizeof(long); break; + case tc7_svect: + sz = sizeof(short); + break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: sz = sizeof(float); break; -# endif case tc7_dvect: sz = sizeof(double); break; @@ -1321,7 +1352,7 @@ SCM position(item, v, k) else { long inc = ARRAY_DIMS(v)->inc; long ubnd = ARRAY_DIMS(v)->ubnd; - if (ubnd < ARRAY_DIMS(v)->lbnd) + 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); @@ -1560,8 +1591,15 @@ SCM array2list(v) register long k; ASRTGO(NIMP(v), badarg1); switch TYP7(v) { - default: badarg1: wta(v, (char *)ARG1, s_array2list); + default: + if (BOOL_T==arrayp(v, UNDEFINED)) { + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(cvref(v, k, UNDEFINED), res); + return res; + } + badarg1: wta(v, (char *)ARG1, s_array2list); case tc7_smob: ASRTGO(ARRAYP(v), badarg1); + if (0==ARRAY_NDIM(v)) return aref(v, EOL); return ra2l(v, ARRAY_BASE(v), 0); case tc7_vector: return vector2list(v); case tc7_string: return string2list(v); @@ -1598,14 +1636,12 @@ SCM array2list(v) } # 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--) @@ -1643,20 +1679,19 @@ SCM list2ura(ndim, prot, lst) 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 NULLP(shp) { + aset(ra, lst, EOL); + return ra; + } if (l2ra(lst, ra, ARRAY_BASE(ra), 0)) return ra; else - badlst: wta(lst, s_bad_ralst, s_list2ura); + wta(lst, s_bad_ralst, s_list2ura); return BOOL_F; } @@ -1775,9 +1810,7 @@ static void rapr1(ra, j, k, port, writing) } break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: -# endif /*SINGLES*/ case tc7_dvect: case tc7_cvect: if (n-- > 0) { @@ -1840,27 +1873,35 @@ int raprin1(exp, port, writing) return 1; } else - lputc('b', port); break; + lputs("At", port); break; + case tc7_vector: + lputc('A', port); break; case tc7_string: - lputc('a', port); break; + lputs("A\\", port); break; case tc7_uvect: - lputc('u', port); break; + lputs("Au", port); break; case tc7_ivect: - lputc('e', port); break; + lputs("Ae", port); break; + case tc7_svect: + lputs("Aes", port); break; # ifdef FLOATS -# ifdef SINGLES case tc7_fvect: - lputc('s', port); break; -# endif /*SINGLES*/ + lputs("Aif", port); break; case tc7_dvect: - lputc('i', port); break; + lputs("Ai", port); break; case tc7_cvect: - lputc('c', port); break; + lputs("Aic", port); break; # endif /*FLOATS*/ } - lputc('(', port); - rapr1(exp, base, 0, port, writing); - lputc(')', port); + if ((v != exp) && 0==ARRAY_NDIM(exp)) { + lputc(' ', port); + iprin1(aref(exp, EOL), port, writing); + } + else { + lputc('(', port); + rapr1(exp, base, 0, port, writing); + lputc(')', port); + } return 1; } @@ -1880,12 +1921,11 @@ SCM array_prot(ra) case tc7_vector: return EOL; case tc7_bvect: return BOOL_T; case tc7_string: return MAKICHR('a'); + case tc7_svect: return i_short; 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 @@ -1969,7 +2009,7 @@ SCM scm_logaset(ra, obj, args) scm_logand(oval, MAKINUM(~(1<