Import Upstream version 5d6upstream/5d6

1 files changed, 41 insertions, 74 deletions

diff --git a/unif.c b/unif.c
index 88250c2..ae5c1b7 100644
--- a/unif.c
+++ b/unif.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002 Free Software Foundation, Inc.
  *
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -15,26 +15,26 @@
  * 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.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM library with other files
  * to produce an executable, this does not by itself cause the
  * resulting executable to be covered by the GNU General Public License.
  * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * linking the SCM library code into it.
  *
  * This exception does not however invalidate any other reasons why
  * the executable file might be covered by the GNU General Public License.
  *
  * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE.  If you copy
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, as the General Public License permits, the exception does
  * not apply to the code that you add in this way.  To avoid misleading
  * anyone as to the status of such modified files, you must delete
  * this exception notice from them.
  *
- * If you write modifications of your own for GUILE, it is your choice
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -61,7 +61,6 @@ complex double		cvect
 #endif
 
 long tc16_array = 0;
-static SCM i_short;
 
 char s_resizuve[] = "vector-set-length!";
 SCM resizuve(vect, len)
@@ -112,7 +111,7 @@ 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)ol*sz, (long)siz, s_resizuve);
+  must_realloc_cell(vect, ol*sz, (long)siz, s_resizuve);
   if VECTORP(vect)
     while(l > ol)
       VELTS(vect)[--l] = UNSPECIFIED;
@@ -149,34 +148,22 @@ long scm_prot2type(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 (MAKINUM(32L)==prot) return tc7_uvect;
+  if (MAKINUM(-32L)==prot) return tc7_ivect;
+  if (MAKINUM(-16L)==prot) return tc7_svect;
+  if INUMP(prot) return INUM(prot) > 0 ? tc7_uvect : tc7_ivect;
   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;
+    if (32.0==x) return tc7_fvect;
+    if (64.0==x) return tc7_dvect;
+    return tc7_dvect;
   }
 # endif
+  return tc7_vector;
 }
 
 SCM make_uve(k, prot)
@@ -216,34 +203,21 @@ SCM make_uve(k, prot)
   }
   DEFER_INTS;
   v = must_malloc_cell((i ? i : 1L),
-		       MAKE_LENGTH((k<LENGTH_MAX ? k : LENGTH_MAX), type),
+		       MAKE_LENGTH((k < LENGTH_MAX ? k : LENGTH_MAX), type),
 		       s_vector);
   if (tc7_string==type) CHARS(v)[k] = 0;
   ALLOW_INTS;
   return v;
 }
 
-static char s_uve_len[] = "uniform-vector-length";
-SCM uve_len(v)
-     SCM v;
-{
-  ASRTGO(NIMP(v), badarg1);
-  switch TYP7(v) {
-  default: badarg1: wta(v, (char *)ARG1, s_uve_len);
-  case tc7_vector:
-  case tcs_uves:
-    return MAKINUM(LENGTH(v));
-  }
-}
-
 SCM arrayp(v, prot)
      SCM v, prot;
 {
   int enclosed = 0;
   long typ;
   if IMP(v) return BOOL_F;
-  typ = TYP7(v);
  loop:
+  typ = TYP7(v);
   switch (typ) {
   case tc7_smob: if (!ARRAYP(v)) return BOOL_F;
     if (UNBNDP(prot)) return BOOL_T;
@@ -866,7 +840,7 @@ SCM aref(v, args)
     int k = ARRAY_NDIM(v);
     SCM res = make_ra(k);
     if (!ARRAYP(v)) {
-      ASRTGO(NULLP(args),badarg);
+      ASRTGO(NULLP(args), badarg);
       return v;
     }
     ARRAY_V(res) = ARRAY_V(v);
@@ -1125,7 +1099,7 @@ SCM uve_read(v, port)
   long sz, len, ans;
   long start=0;
   if UNBNDP(port) port = cur_inp;
-  else ASSERT(NIMP(port) && OPINFPORTP(port), port, ARG2, s_uve_rd);
+  ASSERT(NIMP(port) && OPINFPORTP(port), port, ARG2, s_uve_rd);
   ASRTGO(NIMP(v), badarg1);
   len = LENGTH(v);
  loop:
@@ -1190,7 +1164,7 @@ SCM uve_write(v, port)
   long sz, len, ans;
   long start=0;
   if UNBNDP(port) port = cur_outp;
-  else ASSERT(NIMP(port) && OPOUTFPORTP(port), port, ARG2, s_uve_wr);
+  ASSERT(NIMP(port) && OPOUTFPORTP(port), port, ARG2, s_uve_wr);
   ASRTGO(NIMP(v), badarg1);
   len = LENGTH(v);
  loop:
@@ -1233,7 +1207,7 @@ SCM uve_write(v, port)
     break;
 # endif
   }
-  SYSCALL(ans = fwrite(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port)););
+  ans = lfwrite(CHARS(v)+start*sz, (sizet)sz, (sizet)len, port);
   if (TYP7(v)==tc7_bvect) ans *= LONG_BIT;
   return MAKINUM(ans);
 }
@@ -1299,7 +1273,7 @@ SCM lcount(item, seq)
   }
 }
 static char s_uve_pos[] = "bit-position";
-SCM position(item, v, k)
+SCM bit_position(item, v, k)
      SCM item, v, k;
 {
   long i, len, lenw, xbits, pos = INUM(k), offset = 0;
@@ -1669,10 +1643,9 @@ SCM list2ura(ndim, prot, lst)
   SCM shp=EOL;
   SCM row=lst;
   SCM ra;
-  sizet k;
   long n;
+  sizet k = INUM(ndim);
   ASSERT(INUMP(ndim), ndim, ARG1, s_list2ura);
-  k = INUM(ndim);
   for (; k--; NIMP(row) && (row = CAR(row))) {
     n = ilength(row);
     ASSERT(n>=0, lst, ARG2, s_list2ura);
@@ -1879,18 +1852,18 @@ int raprin1(exp, port, writing)
   case tc7_string:
     lputs("A\\", port); break;
   case tc7_uvect:
-    lputs("Au", port); break;
+    lputs("Au32", port); break;
   case tc7_ivect:
-    lputs("Ae", port); break;
+    lputs("As32", port); break;
   case tc7_svect:
-    lputs("Aes", port); break;
+    lputs("As16", port); break;
 # ifdef FLOATS
   case tc7_fvect:
-    lputs("Aif", port); break;
+    lputs("Ar32", port); break;
   case tc7_dvect:
-    lputs("Ai", port); break;
+    lputs("Ar64", port); break;
   case tc7_cvect:
-    lputs("Aic", port); break;
+    lputs("Ac64", port); break;
 # endif /*FLOATS*/
   }
   if ((v != exp) && 0==ARRAY_NDIM(exp)) {
@@ -1921,13 +1894,13 @@ 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);
+  case tc7_uvect: return MAKINUM(32L);
+  case tc7_ivect: return MAKINUM(-32L);
+  case tc7_svect: return MAKINUM(-16L);
 # ifdef FLOATS
-  case tc7_fvect: return makflo(1.0);
-  case tc7_dvect: return makdbl(1.0/3.0, 0.0);
-  case tc7_cvect: return makdbl(0.0, 1.0);
+  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);
 # endif
   }
 }
@@ -2007,23 +1980,21 @@ SCM scm_logaset(ra, obj, args)
     else if (BOOL_F==obj)
       obj = INUMP(oval) ? MAKINUM(INUM(oval) & (~(1<<INUM(ibit)))) :
 	scm_logand(oval, MAKINUM(~(1<<INUM(ibit))));
-#ifndef RECKLESS
+# ifndef RECKLESS
     else wta(obj, (char *)ARG2, s_logaset);
-#endif
+# endif
   }
   return aset(ra, obj, inds);
 }
 
 static iproc subr3s[] = {
-	{"uniform-vector-set1!", aset},
-	{s_uve_pos, position},
+	{s_uve_pos, bit_position},
 	{s_bit_set, bit_set},
 	{s_bit_count, bit_count},
 	{s_list2ura, list2ura},
 	{0, 0}};
 
 static iproc subr2s[] = {
-	{"uniform-vector-ref", aref},
 	{s_resizuve, resizuve},
 	{s_count, lcount},
 	{s_uve_fill, uve_fill},
@@ -2033,7 +2004,6 @@ static iproc subr1s[] = {
 	{"array-rank", array_rank},
 	{s_array_dims, array_dims},
 	{s_array2list, array2list},
-	{s_uve_len, uve_len},
 	{s_bit_inv, bit_inv},
 	{s_strdown, strdown},
 	{s_strcap, strcap},
@@ -2059,8 +2029,6 @@ static iproc lsubr2s[] = {
 static iproc subr2os[] = {
   {"array?", arrayp},
   {s_array_contents, array_contents},
-  {s_uve_rd, uve_read},
-  {s_uve_wr, uve_write},
   {0, 0}};
 
 static SCM markra(ptr)
@@ -2071,7 +2039,8 @@ static SCM markra(ptr)
 static sizet freera(ptr)
      CELLPTR ptr;
 {
-  must_free(CHARS(ptr), sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim));
+  must_free(CHARS((SCM)ptr),
+	    sizeof(array) + ARRAY_NDIM((SCM)ptr)*sizeof(array_dim));
   return 0;
 }
 static smobfuns rasmob = {markra, freera, raprin1, 0};
@@ -2087,9 +2056,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");
 }
 
 #else /* ARRAYS */