Import Upstream version 5d2upstream/5d2

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");
 }