summaryrefslogtreecommitdiffstats
path: root/unif.c
diff options
context:
space:
mode:
Diffstat (limited to 'unif.c')
-rw-r--r--unif.c345
1 files changed, 192 insertions, 153 deletions
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, (k<LENGTH_MAX ? k : LENGTH_MAX), type);
+ v = must_malloc_cell((i ? i : 1L),
+ MAKE_LENGTH((k<LENGTH_MAX ? k : LENGTH_MAX), type),
+ s_vector);
if (tc7_string==type) CHARS(v)[k] = 0;
ALLOW_INTS;
return v;
@@ -205,14 +230,8 @@ SCM uve_len(v)
ASRTGO(NIMP(v), badarg1);
switch TYP7(v) {
default: badarg1: wta(v, (char *)ARG1, s_uve_len);
- 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 tcs_uves:
return MAKINUM(LENGTH(v));
}
}
@@ -220,30 +239,28 @@ SCM uve_len(v)
SCM arrayp(v, prot)
SCM v, prot;
{
- int nprot = UNBNDP(prot), enclosed = 0;
+ int enclosed = 0;
+ long typ;
if IMP(v) return BOOL_F;
+ typ = TYP7(v);
loop:
- switch TYP7(v) {
+ switch (typ) {
case tc7_smob: if (!ARRAYP(v)) return BOOL_F;
- if (nprot) return BOOL_T;
+ if (UNBNDP(prot)) return BOOL_T;
if (enclosed++) return BOOL_F;
v = ARRAY_V(v);
goto loop;
- case tc7_bvect: return nprot || BOOL_T==prot ? BOOL_T : BOOL_F;
- case tc7_string: return nprot || ICHRP(prot) ? BOOL_T : BOOL_F;
+ case tc7_bvect:
+ case tc7_string:
case tc7_uvect:
- return nprot || (INUMP(prot) && INUM(prot)>0) ? 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<<INUM(ibit))));
#ifndef RECKLESS
else wta(obj, (char *)ARG2, s_logaset);
-#endif
+#endif
}
return aset(ra, obj, inds);
}
@@ -2026,15 +2066,13 @@ static iproc subr2os[] = {
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), sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim));
- return sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim);
+ return 0;
}
static smobfuns rasmob = {markra, freera, raprin1, 0};
/* 0 replaced by raequal in init_ramap() */
@@ -2049,6 +2087,7 @@ void init_unif()
init_iprocs(lsubr2s, tc7_lsubr_2);
init_iprocs(subr2os, tc7_subr_2o);
tc16_array = newsmob(&rasmob);
+ i_short = CAR(sysintern("exact-short", UNDEFINED));
add_feature(s_array);
add_feature("string-case");
}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-21 18:59:21 +0000