diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:34 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:34 -0800 |
commit | 50eb784bfcf15ee3c6b0b53d747db92673395040 (patch) | |
tree | 60f039bb5aa27bc58d92ab0c7bab0d82dbfe7686 /unif.c | |
parent | ae2b295c7deaf2d7c18ad1ed9b6050970e56bae7 (diff) | |
download | scm-50eb784bfcf15ee3c6b0b53d747db92673395040.tar.gz scm-50eb784bfcf15ee3c6b0b53d747db92673395040.zip |
Import Upstream version 5e3upstream/5e3
Diffstat (limited to 'unif.c')
-rw-r--r-- | unif.c | 424 |
1 files changed, 270 insertions, 154 deletions
@@ -45,12 +45,13 @@ 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 +boolean Vbool +signed int VfixZ32 +unsigned int VfixN32 +float VfloR32 +complex float VfloC32 +double VfloR64 +complex double VfloC64 */ #include "scm.h" @@ -85,24 +86,32 @@ SCM resizuve(vect, len) sz = sizeof(SCM); break; #ifdef ARRAYS - case tc7_bvect: + case tc7_Vbool: ol = (ol+LONG_BIT-1)/LONG_BIT; l = (l+LONG_BIT-1)/LONG_BIT; - case tc7_uvect: - case tc7_ivect: + case tc7_VfixN32: + case tc7_VfixZ32: sz = sizeof(long); break; - case tc7_svect: + case tc7_VfixN16: + case tc7_VfixZ16: sz = sizeof(short); break; + case tc7_VfixN8: + case tc7_VfixZ8: + sz = sizeof(char); + break; # ifdef FLOATS - case tc7_fvect: + case tc7_VfloR32: sz = sizeof(float); break; - case tc7_dvect: + case tc7_VfloC32: + sz = 2*sizeof(float); + break; + case tc7_VfloR64: sz = sizeof(double); break; - case tc7_cvect: + case tc7_VfloC64: sz = 2*sizeof(double); break; # endif @@ -150,24 +159,24 @@ long scm_prot2type(prot) { if (ICHRP(prot)) return tc7_string; switch (prot) { - case BOOL_T: return tc7_bvect; - case MAKINUM(8L): - case MAKINUM(16L): - case MAKINUM(32L): return tc7_uvect; - case MAKINUM(-32L): return tc7_ivect; - case MAKINUM(-16L): return tc7_svect; - case MAKINUM(-8L): return tc7_svect; - } - /* if (INUMP(prot)) return INUM(prot) > 0 ? tc7_uvect : tc7_ivect; */ + case BOOL_T: return tc7_Vbool; + case MAKINUM(8L): return tc7_VfixN8; + case MAKINUM(16L): return tc7_VfixN16; + case MAKINUM(32L): return tc7_VfixN32; + case MAKINUM(-32L): return tc7_VfixZ32; + case MAKINUM(-16L): return tc7_VfixZ16; + case MAKINUM(-8L): return tc7_VfixZ8; + } + /* if (INUMP(prot)) return INUM(prot) > 0 ? tc7_VfixN32 : tc7_VfixZ32; */ if (IMP(prot)) return tc7_vector; # ifdef FLOATS if (INEXP(prot)) { double x; - if (CPLXP(prot)) return tc7_cvect; + if (CPLXP(prot)) return (32.0==IMAG(prot)) ? tc7_VfloC32 : tc7_VfloC64; x = REALPART(prot); - if (32.0==x) return tc7_fvect; - if (64.0==x) return tc7_dvect; - return tc7_dvect; + if (32.0==x) return tc7_VfloR32; + if (64.0==x) return tc7_VfloR64; + return tc7_VfloR64; } # endif return tc7_vector; @@ -184,26 +193,35 @@ SCM make_uve(k, prot) default: case tc7_vector: /* Huge non-unif vectors are NOT supported. */ return make_vector(MAKINUM(k), UNDEFINED); /* no special vector */ - case tc7_bvect: + case tc7_Vbool: i = sizeof(long)*((k+LONG_BIT-1)/LONG_BIT); break; case tc7_string: i = sizeof(char)*(k + 1); break; - case tc7_uvect: - case tc7_ivect: + case tc7_VfixN32: + case tc7_VfixZ32: i = sizeof(long)*k; break; - case tc7_svect: + case tc7_VfixN16: + case tc7_VfixZ16: i = sizeof(short)*k; + break; + case tc7_VfixN8: + case tc7_VfixZ8: + i = sizeof(char)*k; + break; # ifdef FLOATS - case tc7_fvect: + case tc7_VfloR32: i = sizeof(float)*k; break; - case tc7_dvect: + case tc7_VfloC32: + i = 2*sizeof(float)*k; + break; + case tc7_VfloR64: i = sizeof(double)*k; break; - case tc7_cvect: + case tc7_VfloC64: i = 2*sizeof(double)*k; break; # endif @@ -232,14 +250,18 @@ SCM arrayp(v, prot) if (enclosed++) return BOOL_F; v = ARRAY_V(v); goto loop; - case tc7_bvect: + case tc7_Vbool: case tc7_string: - case tc7_uvect: - case tc7_ivect: - case tc7_svect: - case tc7_fvect: - case tc7_dvect: - case tc7_cvect: + case tc7_VfixN32: + case tc7_VfixZ32: + case tc7_VfixN16: + case tc7_VfixZ16: + case tc7_VfixN8: + case tc7_VfixZ8: + case tc7_VfloR32: + case tc7_VfloC32: + case tc7_VfloR64: + case tc7_VfloC64: case tc7_vector: if (UNBNDP(prot)) return BOOL_T; if (scm_prot2type(prot)==typ) return BOOL_T; @@ -399,7 +421,7 @@ int rafill(ra, fill, ignore) ve[i] = f; break; } - case tc7_bvect: { + case tc7_Vbool: { long *ve = (long *)VELTS(ra); if (1==inc && (n >= LONG_BIT || n==LENGTH(ra))) { i = base/LONG_BIT; @@ -432,11 +454,11 @@ int rafill(ra, fill, ignore) } break; } - case tc7_uvect: - case tc7_ivect: + case tc7_VfixN32: + case tc7_VfixZ32: { long *ve = VELTS(ra); - long f = (tc7_uvect==TYP7(ra) ? + long f = (tc7_VfixN32==TYP7(ra) ? num2ulong(fill, (char *)ARG2, s_array_fill) : num2long(fill, (char *)ARG2, s_array_fill)); for (i = base; n--; i += inc) @@ -444,21 +466,36 @@ int rafill(ra, fill, ignore) break; } # ifdef FLOATS - case tc7_fvect: { + case tc7_VfloR32: { float *ve = (float *)VELTS(ra); float f = num2dbl(fill, (char *)ARG2, s_array_fill); for (i = base; n--; i += inc) ve[i] = f; break; } - case tc7_dvect: { + case tc7_VfloC32: { + float fr, fi=0.0; + float (*ve)[2] = (float (*)[2])VELTS(ra); + if (NIMP(fill) && CPLXP(fill)) { + fr = REAL(fill); + fi = IMAG(fill); + } + else + fr = num2dbl(fill, (char *)ARG2, s_array_fill); + for (i = base; n--; i += inc) { + ve[i][0] = fr; + ve[i][1] = fi; + } + break; + } + case tc7_VfloR64: { double *ve = (double *)VELTS(ra); double f = num2dbl(fill, (char *)ARG2, s_array_fill); for (i = base; n--; i += inc) ve[i] = f; break; } - case tc7_cvect: { + case tc7_VfloC64: { double fr, fi=0.0; double (*ve)[2] = (double (*)[2])VELTS(ra); if (NIMP(fill) && CPLXP(fill)) { @@ -515,11 +552,12 @@ SCM dims2ura(dims, prot, fill) 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_Vbool: 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; + case tc7_VfloR32: bit = sizeof(float)*CHAR_BIT/sizeof(char); break; + case tc7_VfloC32: bit = 2*sizeof(float)*CHAR_BIT/sizeof(char); break; + case tc7_VfloR64: bit = sizeof(double)*CHAR_BIT/sizeof(char); break; + case tc7_VfloC64: bit = 2*sizeof(double)*CHAR_BIT/sizeof(char); break; } ARRAY_BASE(ra) = (LONG_BIT + bit - 1)/bit; rlen += ARRAY_BASE(ra); @@ -859,30 +897,39 @@ SCM aref(v, args) } return res; } - case tc7_bvect: + case tc7_Vbool: 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]); - case tc7_svect: + case tc7_VfixN8: + return MAKINUM(((unsigned char *)CDR(v))[pos]); + case tc7_VfixZ8: + return MAKINUM(((signed char *)CDR(v))[pos]); + case tc7_VfixN16: + return MAKINUM(((unsigned short *)CDR(v))[pos]); + case tc7_VfixZ16: return MAKINUM(((short *)CDR(v))[pos]); # ifdef INUMS_ONLY - case tc7_uvect: - case tc7_ivect: + case tc7_VfixN32: + case tc7_VfixZ32: return MAKINUM(VELTS(v)[pos]); # else - case tc7_uvect: + case tc7_VfixN32: return ulong2num(VELTS(v)[pos]); - case tc7_ivect: + case tc7_VfixZ32: return long2num(VELTS(v)[pos]); # endif # ifdef FLOATS - case tc7_fvect: + case tc7_VfloR32: return makflo(((float *)CDR(v))[pos]); - case tc7_dvect: + case tc7_VfloC32: + return makdbl(((float *)CDR(v))[2*pos], + ((float *)CDR(v))[2*pos+1]); + case tc7_VfloR64: return makdbl(((double *)CDR(v))[pos], 0.0); - case tc7_cvect: + case tc7_VfloC64: return makdbl(((double *)CDR(v))[2*pos], ((double *)CDR(v))[2*pos+1]); # endif @@ -906,26 +953,58 @@ SCM cvref(v, pos, last) { switch TYP7(v) { default: wta(v, (char *)ARG1, "PROGRAMMING ERROR: cvref"); - case tc7_bvect: + 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); + ARRAY_BASE(last) = pos; + 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; + } + } + return last; + } + case tc7_Vbool: 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]); - case tc7_svect: + case tc7_VfixN8: + return MAKINUM(((unsigned char *)CDR(v))[pos]); + case tc7_VfixZ8: + return MAKINUM(((signed char *)CDR(v))[pos]); + case tc7_VfixN16: + return MAKINUM(((unsigned short *)CDR(v))[pos]); + case tc7_VfixZ16: return MAKINUM(((short *)CDR(v))[pos]); # ifdef INUMS_ONLY - case tc7_uvect: - case tc7_ivect: + case tc7_VfixN32: + case tc7_VfixZ32: return MAKINUM(VELTS(v)[pos]); # else - case tc7_uvect: + case tc7_VfixN32: return ulong2num(VELTS(v)[pos]); - case tc7_ivect: + case tc7_VfixZ32: return long2num(VELTS(v)[pos]); # endif # ifdef FLOATS - case tc7_fvect: + case tc7_VfloC32: + if (0.0 != ((float *)CDR(v))[2*pos+1]) { + if (NIMP(last) && tc_dblc==CAR(last)) { + REAL(last) = ((float *)CDR(v))[2*pos]; + IMAG(last) = ((float *)CDR(v))[2*pos+1]; + return last; + } + return makdbl(((float *)CDR(v))[2*pos], + ((float *)CDR(v))[2*pos+1]); + } + else pos *= 2; + /* Fall through */ + case tc7_VfloR32: # ifdef SINGLES if (NIMP(last) && (last != flo0) && (tc_flo==CAR(last))) { FLO(last) = ((float *)CDR(v))[pos]; @@ -939,7 +1018,7 @@ SCM cvref(v, pos, last) } return makdbl((double)((float *)CDR(v))[pos], 0.0); # endif - case tc7_cvect: + case tc7_VfloC64: if (0.0!=((double *)CDR(v))[2*pos+1]) { if (NIMP(last) && tc_dblc==CAR(last)) { REAL(last) = ((double *)CDR(v))[2*pos]; @@ -951,7 +1030,7 @@ SCM cvref(v, pos, last) } else pos *= 2; /* Fall through */ - case tc7_dvect: + case tc7_VfloR64: # ifdef CDR_DOUBLES if (NIMP(last) && (last != flo0) && (tc_flo==CAR(last))) { FLO(last) = ((double *)CDR(v))[pos]; @@ -961,31 +1040,17 @@ SCM cvref(v, pos, last) # ifdef SINGLES if (NIMP(last) && tc_dblr==CAR(last)) # else - if (NIMP(last) && (last != flo0) && (tc_dblr==CAR(last))) + if (NIMP(last) && (last != flo0) && (tc_dblr==CAR(last))) # endif - { - REAL(last) = ((double *)CDR(v))[pos]; - return last; - } + { + 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; - } } } @@ -1017,7 +1082,7 @@ SCM aset(v, obj, args) wna: wta(UNDEFINED, (char *)WNA, s_aset); case tc7_smob: /* enclosed */ goto badarg1; - case tc7_bvect: + case tc7_Vbool: if (BOOL_F==obj) VELTS(v)[pos/LONG_BIT] &= ~(1L<<(pos%LONG_BIT)); else if (BOOL_T==obj) @@ -1027,25 +1092,41 @@ SCM aset(v, obj, args) case tc7_string: ASRTGO(ICHRP(obj), badarg2); CHARS(v)[pos] = ICHR(obj); break; - case tc7_svect: + case tc7_VfixN8: + ((unsigned char *)VELTS(v))[pos] = num2uchar(obj, (char *)ARG2, s_aset); break; + case tc7_VfixZ8: + ((signed char *)VELTS(v))[pos] = num2char(obj, (char *)ARG2, s_aset); break; + case tc7_VfixN16: + ((unsigned short *)VELTS(v))[pos] = num2ushort(obj, (char *)ARG2, s_aset); break; + case tc7_VfixZ16: ((short *)VELTS(v))[pos] = num2short(obj, (char *)ARG2, s_aset); break; # ifdef INUMS_ONLY - case tc7_uvect: + case tc7_VfixN32: ASRTGO(INUM(obj) >= 0, badarg2); - case tc7_ivect: + case tc7_VfixZ32: ASRTGO(INUMP(obj), badarg2); VELTS(v)[pos] = INUM(obj); break; # else - case tc7_uvect: + case tc7_VfixN32: VELTS(v)[pos] = num2ulong(obj, (char *)ARG2, s_aset); break; - case tc7_ivect: + case tc7_VfixZ32: VELTS(v)[pos] = num2long(obj, (char *)ARG2, s_aset); break; # endif # ifdef FLOATS - case tc7_fvect: + case tc7_VfloR32: ((float*)VELTS(v))[pos] = (float)num2dbl(obj, (char *)ARG2, s_aset); break; - case tc7_dvect: + case tc7_VfloC32: + if (NIMP(obj) && CPLXP(obj)) { + ((float *)CDR(v))[2*pos] = REALPART(obj); + ((float *)CDR(v))[2*pos+1] = IMAG(obj); + } + else { + ((float *)CDR(v))[2*pos] = num2dbl(obj, (char *)ARG2, s_aset); + ((float *)CDR(v))[2*pos+1] = 0.0; + } + break; + case tc7_VfloR64: ((double*)VELTS(v))[pos] = num2dbl(obj, (char *)ARG2, s_aset); break; - case tc7_cvect: + case tc7_VfloC64: if (NIMP(obj) && CPLXP(obj)) { ((double *)CDR(v))[2*pos] = REALPART(obj); ((double *)CDR(v))[2*pos+1] = IMAG(obj); @@ -1081,7 +1162,7 @@ SCM array_contents(ra, strict) 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 (tc7_Vbool==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; } @@ -1127,24 +1208,32 @@ SCM uve_read(v, port) case tc7_string: sz = sizeof(char); break; - case tc7_bvect: + case tc7_Vbool: len = (len+LONG_BIT-1)/LONG_BIT; start /= LONG_BIT; - case tc7_uvect: - case tc7_ivect: + case tc7_VfixN32: + case tc7_VfixZ32: sz = sizeof(long); break; - case tc7_svect: + case tc7_VfixN16: + case tc7_VfixZ16: sz = sizeof(short); break; + case tc7_VfixN8: + case tc7_VfixZ8: + sz = sizeof(char); + break; # ifdef FLOATS - case tc7_fvect: + case tc7_VfloR32: sz = sizeof(float); break; - case tc7_dvect: + case tc7_VfloC32: + sz = 2*sizeof(float); + break; + case tc7_VfloR64: sz = sizeof(double); break; - case tc7_cvect: + case tc7_VfloC64: sz = 2*sizeof(double); break; # endif @@ -1160,7 +1249,7 @@ SCM uve_read(v, port) len -= 1; } SYSCALL(ans = fread(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port));); - if (TYP7(v)==tc7_bvect) ans *= LONG_BIT; + if (TYP7(v)==tc7_Vbool) ans *= LONG_BIT; return MAKINUM(ans); } @@ -1192,30 +1281,38 @@ SCM uve_write(v, port) case tc7_string: sz = sizeof(char); break; - case tc7_bvect: + case tc7_Vbool: len = (len+LONG_BIT-1)/LONG_BIT; start /= LONG_BIT; - case tc7_uvect: - case tc7_ivect: + case tc7_VfixN32: + case tc7_VfixZ32: sz = sizeof(long); break; - case tc7_svect: + case tc7_VfixN16: + case tc7_VfixZ16: sz = sizeof(short); break; + case tc7_VfixN8: + case tc7_VfixZ8: + sz = sizeof(char); + break; # ifdef FLOATS - case tc7_fvect: + case tc7_VfloR32: sz = sizeof(float); break; - case tc7_dvect: + case tc7_VfloC32: + sz = 2*sizeof(float); + break; + case tc7_VfloR64: sz = sizeof(double); break; - case tc7_cvect: + case tc7_VfloC64: sz = 2*sizeof(double); break; # endif } ans = lfwrite(CHARS(v)+start*sz, (sizet)sz, (sizet)len, port); - if (TYP7(v)==tc7_bvect) ans *= LONG_BIT; + if (TYP7(v)==tc7_Vbool) ans *= LONG_BIT; return MAKINUM(ans); } @@ -1232,7 +1329,7 @@ SCM lcount(item, seq) tail: switch TYP7(seq) { default: badarg2: wta(seq, (char *)ARG2, s_count); - case tc7_bvect: + case tc7_Vbool: if (lbnd>ubnd) return INUM0; i = ubnd/LONG_BIT; imin = lbnd/LONG_BIT; @@ -1293,7 +1390,7 @@ SCM bit_position(item, v, k) tail: switch TYP7(v) { default: badarg2: wta(v, (char *)ARG2, s_uve_pos); - case tc7_bvect: + case tc7_Vbool: ASRTER((pos <= len) && (pos >= 0), k, OUTOFRANGE, s_uve_pos); if (pos==len) return BOOL_F; if (0==len) return MAKINUM(-1L); @@ -1358,10 +1455,10 @@ SCM bit_set(v, kv, obj) ASRTGO(NIMP(kv), badarg2); switch TYP7(kv) { default: badarg2: wta(kv, (char *)ARG2, s_bit_set); - case tc7_uvect: + case tc7_VfixN32: switch TYP7(v) { default: badarg1: wta(v, (char *)ARG1, s_bit_set); - case tc7_bvect: + case tc7_Vbool: vlen = LENGTH(v); if (BOOL_F==obj) for (i = LENGTH(kv);i;) { k = VELTS(kv)[--i]; @@ -1377,8 +1474,8 @@ SCM bit_set(v, kv, obj) badarg3: wta(obj, (char *)ARG3, s_bit_set); } break; - case tc7_bvect: - ASRTGO(TYP7(v)==tc7_bvect && LENGTH(v)==LENGTH(kv), badarg1); + case tc7_Vbool: + ASRTGO(TYP7(v)==tc7_Vbool && 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]); @@ -1401,10 +1498,10 @@ SCM bit_count(v, kv, obj) ASRTGO(NIMP(kv), badarg2); switch TYP7(kv) { default: badarg2: wta(kv, (char *)ARG2, s_bit_count); - case tc7_uvect: + case tc7_VfixN32: switch TYP7(v) { default: badarg1: wta(v, (char *)ARG1, s_bit_count); - case tc7_bvect: + case tc7_Vbool: vlen = LENGTH(v); if (BOOL_F==obj) for (i = LENGTH(kv);i;) { k = VELTS(kv)[--i]; @@ -1420,8 +1517,8 @@ SCM bit_count(v, kv, obj) badarg3: wta(obj, (char *)ARG3, s_bit_count); } break; - case tc7_bvect: - ASRTGO(TYP7(v)==tc7_bvect && LENGTH(v)==LENGTH(kv), badarg1); + case tc7_Vbool: + ASRTGO(TYP7(v)==tc7_Vbool && LENGTH(v)==LENGTH(kv), badarg1); if (0==LENGTH(v)) return INUM0; ASRTGO(BOOL_T==obj || BOOL_F==obj, badarg3); obj = (BOOL_T==obj); @@ -1445,7 +1542,7 @@ SCM bit_inv(v) ASRTGO(NIMP(v), badarg1); k = LENGTH(v); switch TYP7(v) { - case tc7_bvect: + case tc7_Vbool: for (k = (k+LONG_BIT-1)/LONG_BIT;k--;) VELTS(v)[k] = ~VELTS(v)[k]; break; @@ -1585,7 +1682,7 @@ SCM array2list(v) return ra2l(v, ARRAY_BASE(v), 0); case tc7_vector: return vector2list(v); case tc7_string: return string2list(v); - case tc7_bvect: { + case tc7_Vbool: { long *data = (long *)VELTS(v); register unsigned long mask; for (k = (LENGTH(v)-1)/LONG_BIT; k > 0; k--) @@ -1596,21 +1693,21 @@ SCM array2list(v) return res; } # ifdef INUMS_ONLY - case tc7_uvect: - case tc7_ivect: { + case tc7_VfixN32: + case tc7_VfixZ32: { 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: { + case tc7_VfixN32: { long *data = (long *)VELTS(v); for (k = LENGTH(v) - 1; k >= 0; k--) res = cons(ulong2num(data[k]), res); return res; } - case tc7_ivect: { + case tc7_VfixZ32: { long *data = (long *)VELTS(v); for (k = LENGTH(v) - 1; k >= 0; k--) res = cons(long2num(data[k]), res); @@ -1618,19 +1715,25 @@ SCM array2list(v) } # endif # ifdef FLOATS - case tc7_fvect: { + case tc7_VfloR32: { float *data = (float *)VELTS(v); for (k = LENGTH(v) - 1; k >= 0; k--) res = cons(makflo(data[k]), res); return res; } - case tc7_dvect: { + case tc7_VfloC32: { + float (*data)[2] = (float (*)[2])VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(makdbl(data[k][0], data[k][1]), res); + return res; + } + case tc7_VfloR64: { 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: { + case tc7_VfloC64: { 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); @@ -1772,9 +1875,9 @@ static void rapr1(ra, j, k, port, writing) for (j += inc; n-- > 0; j += inc) lputc(CHARS(ra)[j], port); break; - case tc7_uvect: + case tc7_VfixN32: if (errjmp_bad) { - ipruk("uvect", ra, port); + ipruk("VfixN32", ra, port); break; } if (n-- > 0) intprint(VELTS(ra)[j], -10, port); @@ -1783,7 +1886,7 @@ static void rapr1(ra, j, k, port, writing) intprint(VELTS(ra)[j], -10, port); } break; - case tc7_ivect: + case tc7_VfixZ32: if (n-- > 0) intprint(VELTS(ra)[j], 10, port); for (j += inc; n-- > 0; j += inc) { lputc(' ', port); @@ -1791,9 +1894,10 @@ static void rapr1(ra, j, k, port, writing) } break; # ifdef FLOATS - case tc7_fvect: - case tc7_dvect: - case tc7_cvect: + case tc7_VfloR32: + case tc7_VfloC32: + case tc7_VfloR64: + case tc7_VfloC64: if (n-- > 0) { SCM z = cvref(ra, j, UNDEFINED); floprint(z, port, writing); @@ -1832,7 +1936,7 @@ int raprin1(exp, port, writing) goto tail; } } - case tc7_bvect: + case tc7_Vbool: if (exp==v) { /* a uve, not an array */ register long i, j, w; lputc('*', port); @@ -1856,24 +1960,32 @@ int raprin1(exp, port, writing) default: if (exp==v) lputc('1', port); switch TYP7(v) { - case tc7_bvect: + case tc7_Vbool: lputs("A:bool", port); break; case tc7_vector: lputc('A', port); break; case tc7_string: lputs("A:char", port); break; - case tc7_uvect: + case tc7_VfixN32: lputs("A:fixN32b", port); break; - case tc7_ivect: + case tc7_VfixZ32: lputs("A:fixZ32b", port); break; - case tc7_svect: + case tc7_VfixN16: + lputs("A:fixN16b", port); break; + case tc7_VfixZ16: lputs("A:fixZ16b", port); break; + case tc7_VfixN8: + lputs("A:fixN8b", port); break; + case tc7_VfixZ8: + lputs("A:fixZ8b", port); break; # ifdef FLOATS - case tc7_fvect: + case tc7_VfloR32: lputs("A:floR32b", port); break; - case tc7_dvect: + case tc7_VfloC32: + lputs("A:floC32b", port); break; + case tc7_VfloR64: lputs("A:floR64b", port); break; - case tc7_cvect: + case tc7_VfloC64: lputs("A:floC64b", port); break; # endif /*FLOATS*/ } @@ -1904,15 +2016,19 @@ SCM array_prot(ra) ra = ARRAY_V(ra); goto loop; case tc7_vector: return EOL; - case tc7_bvect: return BOOL_T; + case tc7_Vbool: return BOOL_T; case tc7_string: return MAKICHR('a'); - case tc7_uvect: return MAKINUM(32L); - case tc7_ivect: return MAKINUM(-32L); - case tc7_svect: return MAKINUM(-16L); + case tc7_VfixN32: return MAKINUM(32L); + case tc7_VfixZ32: return MAKINUM(-32L); + case tc7_VfixN16: return MAKINUM(16L); + case tc7_VfixZ16: return MAKINUM(-16L); + case tc7_VfixN8: return MAKINUM(8L); + case tc7_VfixZ8: return MAKINUM(-8L); # ifdef FLOATS - case tc7_fvect: return makflo(32.0); - case tc7_dvect: return makdbl(64.0, 0.0); - case tc7_cvect: return makdbl(0.0, 64.0); + case tc7_VfloR32: return makflo(32.0); + case tc7_VfloC32: return makdbl(0.0, 32.0); + case tc7_VfloR64: return makdbl(64.0, 0.0); + case tc7_VfloC64: return makdbl(0.0, 64.0); # endif } } |