Fixed some SCM/scm_bits_t mixups.

diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 19f2ca0..b201111 100644 (file)
--- a/libguile/ChangeLog
+++ b/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

diff --git a/libguile/options.c b/libguile/options.c
index bb63cb2..c59f187 100644 (file)
--- a/libguile/options.c
+++ b/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)
-                && !SCM_NULLP (arg)
-                && (SCM_IMP (arg) || SCM_NCONSP (arg)));
+  int i, docp = (!SCM_UNBNDP (arg) && !SCM_NULLP (arg) && !SCM_CONSP (arg));
   /* Let `arg' GC protect the arguments */
   SCM new_mode = arg, ans = SCM_EOL, ls;
   for (i = 0; i < n; ++i)

diff --git a/libguile/print.c b/libguile/print.c
index e92cd78..8e54806 100644 (file)
--- a/libguile/print.c
+++ b/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)

diff --git a/libguile/print.h b/libguile/print.h
index 1f2702b..f72c628 100644 (file)
--- a/libguile/print.h
+++ b/libguile/print.h
@@ -53,7 +53,7 @@
 \f
 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
 

diff --git a/libguile/ramap.c b/libguile/ramap.c
index 8c2f7ba..853af5b 100644 (file)
--- a/libguile/ramap.c
+++ b/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] :
-               SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2])
+               ((signed long *) SCM_VELTS (ra1))[i1] < ((signed long *) 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 (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0)))
+         if (SCM_EQ_P (v0, ra1) 
+             || (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), "");
 }

diff --git a/libguile/read.c b/libguile/read.c
index 051e755..15924b4 100644 (file)
--- a/libguile/read.c
+++ b/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);

diff --git a/libguile/stacks.c b/libguile/stacks.c
index 8f3ab9b..85c13a6 100644 (file)
--- a/libguile/stacks.c
+++ b/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;

diff --git a/libguile/strings.c b/libguile/strings.c
index 783bfd4..c9c7af4 100644 (file)
--- a/libguile/strings.c
+++ b/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,
-                               "scm_makstr");
+  mem = (scm_bits_t *) scm_must_malloc (sizeof (scm_bits_t) * (slots + 1) 
+                                       + 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);

diff --git a/libguile/struct.h b/libguile/struct.h
index a2c3edb..c7abfc5 100644 (file)
--- a/libguile/struct.h
+++ b/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 */
 

diff --git a/libguile/unif.c b/libguile/unif.c
index f61f4e3..8e27612 100644 (file)
--- a/libguile/unif.c
+++ b/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);