Import Upstream version 5c3upstream/5c3

1 files changed, 97 insertions, 17 deletions

diff --git a/unif.c b/unif.c
index 6a5fe84..35fc86e 100644
--- a/unif.c
+++ b/unif.c
@@ -107,9 +107,8 @@ SCM resizuve(vect, len)
   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));
+  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;
@@ -144,13 +143,13 @@ SCM make_uve(k, prot)
      SCM prot;
 {
   SCM v;
-  long i, type;
+    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;
+    i = sizeof(char)*(k + 1);
     type = tc7_string;
   }
   else if INUMP(prot) {
@@ -191,11 +190,10 @@ SCM make_uve(k, prot)
     type = tc7_dvect;
   }
 # endif
-
-  NEWCELL(v);
   DEFER_INTS;
-  SETCHARS(v, must_malloc((i ? i : 1L), s_vector));
+  v = must_malloc_cell((i ? i : 1L), s_vector);
   SETLENGTH(v, (k<LENGTH_MAX ? k : LENGTH_MAX), type);
+  if (tc7_string==type) CHARS(v)[k] = 0;
   ALLOW_INTS;
   return v;
 }
@@ -324,10 +322,8 @@ SCM make_ra(ndim)
      int ndim;
 {
   SCM ra;
-  NEWCELL(ra);
   DEFER_INTS;
-  SETCDR(ra, must_malloc((long)(sizeof(array)+ndim*sizeof(array_dim)),
-			 "array"));
+  ra = must_malloc_cell((long)(sizeof(array)+ndim*sizeof(array_dim)), "array");
   CAR(ra) = ((long)ndim << 17) + tc16_array;
   ARRAY_V(ra) = nullvect;
   ALLOW_INTS;
@@ -788,10 +784,10 @@ SCM array_inbp(args)
   args = CDR(args);
   if IMP(v) goto scalar;
   switch TYP7(v) {
-  default:
-  scalar: if NULLP(args) return BOOL_T;
-  badarg1: wta(v, (char *)ARG1, s_array_inbp);
   wna: wta(UNDEFINED, (char *)WNA, s_array_inbp);
+  default: scalar: 
+    if NULLP(args) return BOOL_T;
+    wta(v, (char *)ARG1, s_array_inbp);
   case tc7_smob:
     if (ARRAYP(v)) {
       SCM ret = BOOL_T;
@@ -1765,10 +1761,10 @@ static void rapr1(ra, j, k, port, writing)
        ipruk("uvect", ra, port);
        break;
      }
-     if (n-- > 0) iprin1(ulong2num(VELTS(ra)[j]), port, writing);
+     if (n-- > 0) intprint(VELTS(ra)[j], -10, port);
      for (j += inc; n-- > 0; j += inc) {
        lputc(' ', port);
-       iprin1(ulong2num(VELTS(ra)[j]), port, writing);
+       intprint(VELTS(ra)[j], -10, port);
      }
      break;
    case tc7_ivect:
@@ -1896,6 +1892,88 @@ SCM array_prot(ra)
   }
 }
 
+/* Looks like ARRAY-REF, if just enough indices are provided,
+   If one extra is provided then the last index specifies bit
+   position in an integer element.
+*/
+static char s_logaref[] = "logaref";
+SCM scm_logaref(args)
+     SCM args;
+{
+  SCM ra, inds, ibit;
+  int  i, rank = 1;
+  ASSERT(NIMP(args), UNDEFINED, WNA, s_logaref);
+  ra = CAR(args);
+  ASSERT(NIMP(ra), ra, ARG1, s_logaref);
+  if ARRAYP(ra) rank = ARRAY_NDIM(ra);
+  inds = args = CDR(args);
+  for (i = rank; i; i--) {
+    ASSERT(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaref);
+    args = CDR(args);
+  }
+  if NULLP(args) return aref(ra, inds);
+  ASSERT(NIMP(args) && CONSP(args) && NULLP(CDR(args)),
+	 inds, WNA, s_logaref);
+  ASSERT(INUMP(CAR(args)), CAR(args), ARGn, s_logaref);
+  ibit = CAR(args);
+  if (1==rank)
+    inds = CAR(inds);
+  else {			/* Destructively modify arglist */
+    args = inds;
+    for (i = rank-1; i; i--) {
+      ASSERT(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaref);
+      args = CDR(args);
+    }
+    CDR(args) = EOL;
+  }
+  args = aref(ra, inds);
+  return INUMP(args) ?
+    ((1<<INUM(ibit)) & INUM(args) ? BOOL_T : BOOL_F) :
+    scm_logbitp(ibit, args);
+}
+
+static char s_logaset[] = "logaset!";
+SCM scm_logaset(ra, obj, args)
+     SCM ra, obj, args;
+{
+  SCM oval, inds, ibit;
+  int  i, rank = 1;
+  ASSERT(NIMP(ra), ra, ARG1, s_logaset);
+  if ARRAYP(ra) rank = ARRAY_NDIM(ra);
+  inds = args;
+  for (i = rank; i; i--) {
+    ASSERT(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaset);
+    args = CDR(args);
+  }
+  if NNULLP(args) {
+    ASSERT(NIMP(args) && CONSP(args) && NULLP(CDR(args)),
+	   inds, WNA, s_logaset);
+    ASSERT(INUMP(CAR(args)), CAR(args), ARGn, s_logaset);
+    ibit = CAR(args);
+    if (1==rank) inds = CAR(inds);
+    else {			/* Destructively modify arglist */
+      args = inds;
+      for (i = rank-1; i; i--) {
+	ASSERT(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaset);
+	args = CDR(args);
+      }
+      CDR(args) = EOL;
+    }
+    oval = aref(ra, inds);
+    ASSERT(INUMP(ibit), ibit, ARGn, s_logaset);
+    if (BOOL_T==obj)
+      obj = INUMP(oval) ? MAKINUM(INUM(oval) | (1<<INUM(ibit))) :
+	scm_logior(oval, MAKINUM(1<<INUM(ibit)));
+    else if (BOOL_F==obj)
+      obj = INUMP(oval) ? MAKINUM(INUM(oval) & (~(1<<INUM(ibit)))) :
+	scm_logand(oval, MAKINUM(~(1<<INUM(ibit))));
+#ifndef RECKLESS
+    else wta(obj, (char *)ARG2, s_logaset);
+#endif      
+  }
+  return aset(ra, obj, inds);
+}
+
 static iproc subr3s[] = {
 	{"uniform-vector-set1!", aset},
 	{s_uve_pos, position},
@@ -1928,12 +2006,14 @@ static iproc lsubrs[] = {
   {s_trans_array, trans_array},
   {s_encl_array, encl_array},
   {s_array_inbp, array_inbp},
+  {s_logaref, scm_logaref},
   {0, 0}};
 
 static iproc lsubr2s[] = {
   {s_make_sh_array, make_sh_array},
   {s_dims2ura, dims2ura},
   {s_aset, aset},
+  {s_logaset, scm_logaset},
   {0, 0}};
 
 static iproc subr2os[] = {
@@ -1953,7 +2033,7 @@ static SCM markra(ptr)
 static sizet freera(ptr)
      CELLPTR ptr;
 {
-  must_free(CHARS(ptr));
+  must_free(CHARS(ptr), sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim));
   return sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim);
 }
 static smobfuns rasmob = {markra, freera, raprin1, 0};