Fixed some SCM/scm_bits_t mixups.

libguile/ChangeLog

@@ -1,3 +1,31 @@
+2000-04-18  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* options.c (scm_options), read.c (recsexpr):  Remove redundant
+	SCM_IMP test.
+
+	* print.c (scm_iprin1):  Made the access of the struct vcell
+	element explicit.
+
+	* print.h (SCM_PRINT_CLOSURE):  Added call to SCM_PACK.
+
+	* ramap.c (scm_ra_eqp, ra_compare), unif.c
+	(scm_uniform_vector_ref, scm_cvref, rapr1):  Separated accesses to
+	unsigned long and signed long arrays and clarified the way the
+	access is performed.
+
+	* ramap.c (scm_array_map_x, raeql), read.c (scm_lreadr), stacks.c
+	(narrow_stack), unif.c (scm_cvref, scm_uniform_array_read_x,
+	scm_raprin1):  Use SCM_EQ_P to compare SCM values.
+
+	* strings.c (scm_makstr):  Treat the msymbol slots as a field of
+	scm_bits_t values.
+
+	* struct.h (SCM_SET_VTABLE_DESTRUCTOR):  Treat the struct data as
+	a field of scm_bits_t values.
+
+	* unif.c (l2ra):  Don't test result of scm_array_set_x against
+	zero:  It is always SCM_UNSPECIFIED.
+
 2000-04-18  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>
 
 	* script.c (scm_compile_shell_switches): Also enable

libguile/options.c

@@ -124,9 +124,7 @@ static SCM protected_objects;
 SCM
 scm_options (SCM arg, scm_option options[], int n, const char *s)
 {
-  int i, docp = (!SCM_UNBNDP (arg)
+  int i, docp = (!SCM_UNBNDP (arg) && !SCM_NULLP (arg) && !SCM_CONSP (arg));
-		 && !SCM_NULLP (arg)
-		 && (SCM_IMP (arg) || SCM_NCONSP (arg)));
   /* Let `arg' GC protect the arguments */
   SCM new_mode = arg, ans = SCM_EOL, ls;
   for (i = 0; i < n; ++i)

libguile/print.c

@@ -349,7 +349,7 @@ taloop:
 	{
 	case scm_tcs_cons_gloc:
 
-	  if (SCM_CDR ((SCM) SCM_STRUCT_VTABLE_DATA (exp)) == (SCM) 0)
+	  if (SCM_STRUCT_VTABLE_DATA (exp) [scm_vtable_index_vcell] == 0)
 	    {
 	      ENTER_NESTED_DATA (pstate, exp, circref);
 	      if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)

libguile/print.h

@@ -53,7 +53,7 @@
 
 extern scm_option scm_print_opts[];
 
-#define SCM_PRINT_CLOSURE	((SCM) scm_print_opts[0].val)
+#define SCM_PRINT_CLOSURE	(SCM_PACK (scm_print_opts[0].val))
 #define SCM_PRINT_SOURCE_P	((int) scm_print_opts[1].val)
 #define SCM_N_PRINT_OPTIONS 2
 

libguile/ramap.c

@@ -848,10 +848,15 @@ scm_ra_eqp (SCM ra0, SCM ras)
 	break;
       }
     case scm_tc7_uvect:
+      for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+	if (SCM_BITVEC_REF (ra0, i0))
+	  if (((unsigned long *) SCM_VELTS (ra1))[i1] != ((unsigned long *) SCM_VELTS (ra2))[i2])
+	    SCM_BITVEC_CLR (ra0, i0);
+      break;
     case scm_tc7_ivect:
       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 	if (SCM_BITVEC_REF (ra0, i0))
-	  if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2])
+	  if (((signed long *) SCM_VELTS (ra1))[i1] != ((signed long *) SCM_VELTS (ra2))[i2])
 	    SCM_BITVEC_CLR (ra0, i0);
       break;
     case scm_tc7_fvect:
@@ -904,13 +909,22 @@ ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt)
 	break;
       }
     case scm_tc7_uvect:
+      for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+	{
+	  if (SCM_BITVEC_REF (ra0, i0))
+	    if (opt ?
+		((unsigned long *) SCM_VELTS (ra1))[i1] < ((unsigned long *) SCM_VELTS (ra2))[i2] :
+		((unsigned long *) SCM_VELTS (ra1))[i1] >= ((unsigned long *) SCM_VELTS (ra2))[i2])
+	      SCM_BITVEC_CLR (ra0, i0);
+	}
+      break;
     case scm_tc7_ivect:
       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 	{
 	  if (SCM_BITVEC_REF (ra0, i0))
 	    if (opt ?
-		SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] :
+		((signed long *) SCM_VELTS (ra1))[i1] < ((signed long *) SCM_VELTS (ra2))[i2] :
-		SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2])
+		((signed long *) SCM_VELTS (ra1))[i1] >= ((signed long *) SCM_VELTS (ra2))[i2])
 	      SCM_BITVEC_CLR (ra0, i0);
 	}
       break;
@@ -1511,7 +1525,7 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
 	  goto gencase;
 	scm_array_fill_x (ra0, SCM_BOOL_T);
 	for (p = ra_rpsubrs; p->name; p++)
-	  if (proc == p->sproc)
+	  if (SCM_EQ_P (proc, p->sproc))
 	    {
 	      while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
 		{
@@ -1548,19 +1562,22 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
 	  /* Check to see if order might matter.
 	     This might be an argument for a separate
 	     SERIAL-ARRAY-MAP! */
-	  if (v0 == ra1 || (SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
+	  if (SCM_EQ_P (v0, ra1) 
-	    if (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0)))
+	      || (SCM_ARRAYP (ra1) && SCM_EQ_P (v0, SCM_ARRAY_V (ra1))))
+	    if (!SCM_EQ_P (ra0, ra1) 
+		|| (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0)))
 	      goto gencase;
 	  for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail))
 	    {
 	      ra1 = SCM_CAR (tail);
-	      if (v0 == ra1 || (SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
+	      if (SCM_EQ_P (v0, ra1) 
+		  || (SCM_ARRAYP (ra1) && SCM_EQ_P (v0, SCM_ARRAY_V (ra1))))
 		goto gencase;
 	    }
 	  for (p = ra_asubrs; p->name; p++)
-	    if (proc == p->sproc)
+	    if (SCM_EQ_P (proc, p->sproc))
 	      {
-		if (ra0 != SCM_CAR (lra))
+		if (!SCM_EQ_P (ra0, SCM_CAR (lra)))
 		  scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME);
 		lra = SCM_CDR (lra);
 		while (1)
@@ -1906,7 +1923,7 @@ raeql (SCM ra0,SCM as_equal,SCM ra1)
 	  vlen *= s0[k].ubnd - s1[k].lbnd + 1;
 	}
     }
-  if (unroll && bas0 == bas1 && v0 == v1)
+  if (unroll && bas0 == bas1 && SCM_EQ_P (v0, v1))
     return 1;
   return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
 }

libguile/read.c

@@ -187,9 +187,9 @@ scm_casei_streq (char *s1, char *s2)
 static SCM
 recsexpr (SCM obj,int line,int column,SCM filename)
 {
-  if (SCM_IMP (obj) || SCM_NCONSP(obj))
+  if (!SCM_CONSP(obj)) {
     return obj;
-  {
+  } else {
     SCM tmp = obj, copy;
     /* If this sexpr is visible in the read:sharp source, we want to
        keep that information, so only record non-constant cons cells
@@ -492,7 +492,7 @@ tryagain_no_flush_ws:
       goto tok;
 
     case ':':
-      if (SCM_PACK (SCM_KEYWORD_STYLE) == scm_keyword_prefix)
+      if (SCM_EQ_P (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix))
 	{
 	  j = scm_read_token ('-', tok_buf, port, 0);
 	  p = scm_intern (SCM_CHARS (*tok_buf), j);

libguile/stacks.c

@@ -389,7 +389,7 @@ narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key)
     /* Use standard cutting procedure. */
     {
       for (i = 0; inner; --inner)
-	if (s->frames[i++].proc == inner_key)
+	if (SCM_EQ_P (s->frames[i++].proc, inner_key))
 	  break;
     }
   s->frames = &s->frames[i];
@@ -397,7 +397,7 @@ narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key)
 
   /* Cut outer part. */
   for (; n && outer; --outer)
-    if (s->frames[--n].proc == outer_key)
+    if (SCM_EQ_P (s->frames[--n].proc, outer_key))
       break;
 
   s->length = n;

libguile/strings.c

@@ -117,18 +117,19 @@ SCM
 scm_makstr (long len, int slots)
 {
   SCM s;
-  SCM * mem;
+  scm_bits_t * mem;
+
   SCM_NEWCELL (s);
   --slots;
   SCM_REDEFER_INTS;
-  mem = (SCM *)scm_must_malloc (sizeof (SCM) * (slots + 1) + len + 1,
+  mem = (scm_bits_t *) scm_must_malloc (sizeof (scm_bits_t) * (slots + 1) 
-				"scm_makstr");
+					+ len + 1, "scm_makstr");
   if (slots >= 0)
     {
       int x;
-      mem[slots] = (SCM)mem;
+      mem[slots] = (scm_bits_t) mem;
       for (x = 0; x < slots; ++x)
-	mem[x] = SCM_BOOL_F;
+	mem[x] = SCM_UNPACK (SCM_BOOL_F);
     }
   SCM_SETCHARS (s, (char *) (mem + slots + 1));
   SCM_SETLENGTH (s, len, scm_tc7_string);

libguile/struct.h

@@ -87,7 +87,7 @@ typedef scm_sizet (*scm_struct_free_t) (scm_bits_t * vtable, scm_bits_t * data);
 
 #define SCM_STRUCT_VTABLE(X) 	        (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_vtable]))
 #define SCM_STRUCT_PRINTER(X) 	        (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_printer]))
-#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA(X)[scm_struct_i_free] = (SCM) D)
+#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA (X) [scm_struct_i_free] = (scm_bits_t) (D))
 /* Efficiency is important in the following macro, since it's used in GC */
 #define SCM_LAYOUT_TAILP(X)		(((X) & 32) == 0) /* R, W or O */
 

libguile/unif.c

@@ -1149,9 +1149,9 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
     case scm_tc7_byvect:
       return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]);
   case scm_tc7_uvect:
-    return scm_ulong2num((unsigned long ) SCM_VELTS(v)[pos]);
+    return scm_ulong2num (((unsigned long *) SCM_VELTS (v))[pos]);
   case scm_tc7_ivect:
-    return scm_long2num((long) SCM_VELTS(v)[pos]);
+    return scm_long2num(((signed long *) SCM_VELTS (v))[pos]);
 
     case scm_tc7_svect:
       return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]);
@@ -1194,9 +1194,9 @@ scm_cvref (SCM v, scm_sizet pos, SCM last)
     case scm_tc7_byvect:
       return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]);
     case scm_tc7_uvect:
-      return scm_ulong2num((unsigned long) SCM_VELTS(v)[pos]);
+      return scm_ulong2num(((unsigned long *) SCM_VELTS (v))[pos]);
     case scm_tc7_ivect:
-      return scm_long2num((long) SCM_VELTS(v)[pos]);
+      return scm_long2num(((signed long *) SCM_VELTS (v))[pos]);
     case scm_tc7_svect:
       return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]);
 #ifdef HAVE_LONG_LONGS
@@ -1204,14 +1204,14 @@ scm_cvref (SCM v, scm_sizet pos, SCM last)
       return scm_long_long2num (((long_long *) SCM_CELL_WORD_1 (v))[pos]);
 #endif
     case scm_tc7_fvect:
-      if (SCM_NIMP (last) && last != scm_flo0 && SCM_SLOPPY_REALP (last))
+      if (SCM_NIMP (last) && !SCM_EQ_P (last, scm_flo0) && SCM_SLOPPY_REALP (last))
 	{
 	  SCM_REAL_VALUE (last) = ((float *) SCM_CELL_WORD_1 (v))[pos];
 	  return last;
 	}
       return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]);
     case scm_tc7_dvect:
-      if (SCM_NIMP (last) && last != scm_flo0 && SCM_SLOPPY_REALP (last))
+      if (SCM_NIMP (last) && !SCM_EQ_P (last, scm_flo0) && SCM_SLOPPY_REALP (last))
 	{
 	  SCM_REAL_VALUE (last) = ((double *) SCM_CELL_WORD_1 (v))[pos];
 	  return last;
@@ -1599,7 +1599,7 @@ loop:
   if (SCM_TYP7 (v) == scm_tc7_bvect)
     ans *= SCM_LONG_BIT;
 
-  if (v != ra && cra != ra)
+  if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra))
     scm_array_copy_x (cra, ra);
 
   return SCM_MAKINUM (ans);
@@ -2210,12 +2210,11 @@ l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k)
 	{
 	  if (SCM_IMP (lst) || SCM_NCONSP (lst))
 	    return 0;
-	  ok = ok && scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base));
 	  base += inc;
 	  lst = SCM_CDR (lst);
 	}
       if (SCM_NNULLP (lst))
- return 0;
+	return 0;
     }
   return ok;
 }
@@ -2313,23 +2312,23 @@ tail:
 	if (n-- > 0)
 	  {
 	    /* intprint can't handle >= 2^31.  */
-	    sprintf (str, "%lu", (unsigned long) SCM_VELTS (ra)[j]);
+	    sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
 	    scm_puts (str, port);
 	  }
 	for (j += inc; n-- > 0; j += inc)
 	  {
 	    scm_putc (' ', port);
-	    sprintf (str, "%lu", (unsigned long) SCM_VELTS (ra)[j]);
+	    sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
 	    scm_puts (str, port);
 	  }
       }
     case scm_tc7_ivect:
       if (n-- > 0)
-	scm_intprint ((int)SCM_VELTS (ra)[j], 10, port);
+	scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
       for (j += inc; n-- > 0; j += inc)
 	{
 	  scm_putc (' ', port);
-	  scm_intprint ((int)SCM_VELTS (ra)[j], 10, port);
+	  scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
 	}
       break;
 
@@ -2425,7 +2424,7 @@ tail:
 	  }
       }
     case scm_tc7_bvect:
-      if (exp == v)
+      if (SCM_EQ_P (exp, v))
 	{			/* a uve, not an scm_array */
 	  register long i, j, w;
 	  scm_putc ('*', port);