* Replace SCM_UNPACK_CAR with SCM_CELL_TYPE or SCM_CELL_WORD_0.

* Only access cons cells via SCM_{SET}?C[AD]R.
* Added documentation for scm_force.

diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index c9d7e38..3578be4 100644 (file)
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,13 @@
+2000-05-23  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+       * eval.c (scm_macroexp, SCM_CEVAL, scm_force), tags.h:  Replace
+       SCM_UNPACK_CAR with SCM_CELL_TYPE or SCM_CELL_WORD_0.
+
+       * eval.c (scm_force):  Add documentation.
+
+       * eval.c (scm_force, scm_cons_source):  Don't access cells via
+       SCM_{SET}?C[AD]R unless they are known to be cons cells.
+
 2000-05-23  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
        * strings.h (SCM_NSTRINGP, SCM_NRWSTRINGP), tags.h

diff --git a/libguile/eval.c b/libguile/eval.c
index ebbf5f8..22df064 100644 (file)
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -1250,7 +1250,7 @@ scm_macroexp (SCM x, SCM env)
 
   if (SCM_IMP (proc)
       || scm_tc16_macro != SCM_TYP16 (proc)
-      || (int) (SCM_UNPACK_CAR (proc) >> 16) != 2)
+      || (SCM_CELL_WORD_0 (proc) >> 16) != 2)
     return x;
 
   unmemocar (x, env);
@@ -2539,7 +2539,7 @@ dispatch:
 #ifdef DEVAL
              SCM_CLEAR_MACROEXP (debug);
 #endif
-             switch ((int) (SCM_UNPACK_CAR (proc) >> 16))
+             switch (SCM_CELL_WORD_0 (proc) >> 16)
                {
                case 2:
                  if (scm_ilength (t.arg1) <= 0)
@@ -3697,35 +3697,38 @@ prinprom (SCM exp,SCM port,scm_print_state *pstate)
 
 SCM_DEFINE (scm_force, "force", 1, 0, 0, 
            (SCM x),
-           "")
+           "If the promise X has not been computed yet, compute and return\n"
+           "X, otherwise just return the previously computed value.")
 #define FUNC_NAME s_scm_force
 {
-  SCM_VALIDATE_SMOB (1,x,promise);
-  if (!((1L << 16) & SCM_UNPACK_CAR (x)))
+  SCM_VALIDATE_SMOB (1, x, promise);
+  if (!((1L << 16) & SCM_CELL_WORD_0 (x)))
     {
-      SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL);
-      if (!((1L << 16) & SCM_UNPACK_CAR (x)))
+      SCM ans = scm_apply (SCM_CELL_OBJECT_1 (x), SCM_EOL, SCM_EOL);
+      if (!((1L << 16) & SCM_CELL_WORD_0 (x)))
        {
          SCM_DEFER_INTS;
-         SCM_SETCDR (x, ans);
-         SCM_SETOR_CAR (x, (1L << 16));
+         SCM_SET_CELL_OBJECT_1 (x, ans);
+         SCM_SET_CELL_WORD_0 (x, SCM_CELL_WORD_0 (x) | (1L << 16));
          SCM_ALLOW_INTS;
        }
     }
-  return SCM_CDR (x);
+  return SCM_CELL_OBJECT_1 (x);
 }
 #undef FUNC_NAME
 
+
 SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0, 
             (SCM x),
            "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
            "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
 #define FUNC_NAME s_scm_promise_p
 {
-  return SCM_BOOL(SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise));
+  return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_promise, x));
 }
 #undef FUNC_NAME
 
+
 SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0, 
             (SCM xorig, SCM x, SCM y),
            "")
@@ -3733,16 +3736,17 @@ SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
 {
   SCM p, z;
   SCM_NEWCELL (z);
-  SCM_SETCAR (z, x);
-  SCM_SETCDR (z, y);
+  SCM_SET_CELL_OBJECT_0 (z, x);
+  SCM_SET_CELL_OBJECT_1 (z, y);
   /* Copy source properties possibly associated with xorig. */
   p = scm_whash_lookup (scm_source_whash, xorig);
-  if (SCM_NIMP (p))
+  if (!SCM_IMP (p))
     scm_whash_insert (scm_source_whash, z, p);
   return z;
 }
 #undef FUNC_NAME
 
+
 SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, 
             (SCM obj),
            "Recursively copy the data tree that is bound to @var{obj}, and return a\n"

diff --git a/libguile/tags.h b/libguile/tags.h
index 08a971b..e3d7e51 100644 (file)
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -93,7 +93,7 @@ typedef long scm_bits_t;
 
 
 /* SCM_UNPACK_CAR is a convenience for treating the CAR of X as a word */
-#define SCM_UNPACK_CAR(x) SCM_UNPACK (SCM_CAR (x))
+#define SCM_UNPACK_CAR(x) (SCM_CELL_TYPE (x))
 
 \f
 
@@ -284,18 +284,18 @@ typedef long scm_bits_t;
  * stored in the SCM_CAR of a non-immediate object have a 1 in bit 1:
  */
 
-#define SCM_SLOPPY_NCONSP(x) (1 & SCM_UNPACK_CAR (x))
-#define SCM_SLOPPY_CONSP(x)  (!SCM_SLOPPY_NCONSP (x))
+#define SCM_SLOPPY_CONSP(x)  ((1 & SCM_CELL_TYPE (x)) == 0)
+#define SCM_SLOPPY_NCONSP(x) (!SCM_SLOPPY_CONSP(x))
 
-#define SCM_NCONSP(x) (SCM_IMP (x) || SCM_SLOPPY_NCONSP (x))
-#define SCM_CONSP(x)  (SCM_NIMP (x) && SCM_SLOPPY_CONSP (x))
+#define SCM_CONSP(x)  (!SCM_IMP (x) && SCM_SLOPPY_CONSP (x))
+#define SCM_NCONSP(x) (!SCM_CONSP (x))
 
 
 /* SCM_ECONSP should be used instead of SCM_CONSP at places where GLOCS
  * can be expected to occur.
  */
 #define SCM_ECONSP(x) \
-  (SCM_NIMP (x) \
+  (!SCM_IMP (x) \
    && (SCM_SLOPPY_CONSP (x) \
        || (SCM_TYP3 (x) == 1 \
           && (SCM_STRUCT_VTABLE_DATA (x)[scm_vtable_index_vcell] != 0))))
@@ -303,8 +303,8 @@ typedef long scm_bits_t;
 
 \f
 
-#define SCM_CELLP(x)   (!SCM_NCELLP (x))
-#define SCM_NCELLP(x)  ((sizeof (scm_cell) - 1) & SCM_UNPACK (x))
+#define SCM_CELLP(x)   (((sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0)
+#define SCM_NCELLP(x)  (!SCM_CELLP (x))
 
 #define SCM_DOUBLE_CELLP(x)  (((2 * sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0)
 
@@ -312,7 +312,7 @@ typedef long scm_bits_t;
  */
 
 #define SCM_ITAG3(x)           (7 & SCM_UNPACK (x))
-#define SCM_TYP3(x)            (7 & SCM_UNPACK_CAR (x))
+#define SCM_TYP3(x)            (7 & SCM_CELL_TYPE (x))
 #define scm_tc3_cons           0
 #define scm_tc3_cons_gloc      1
 #define scm_tc3_int_1          2
@@ -328,13 +328,13 @@ typedef long scm_bits_t;
  */
 
 
-#define SCM_TYP7(x)            (0x7f &        SCM_UNPACK_CAR (x))
-#define SCM_TYP7S(x)           ((0x7f & ~2) & SCM_UNPACK_CAR (x))
+#define SCM_TYP7(x)            (0x7f &        SCM_CELL_TYPE (x))
+#define SCM_TYP7S(x)           ((0x7f & ~2) & SCM_CELL_TYPE (x))
 
 
-#define SCM_TYP16(x)           (0xffff & SCM_UNPACK_CAR (x))
-#define SCM_TYP16S(x)          (0xfeff & SCM_UNPACK_CAR (x))
-#define SCM_GCTYP16(x)                 (0xff7f & SCM_UNPACK_CAR (x))
+#define SCM_TYP16(x)           (0xffff & SCM_CELL_TYPE (x))
+#define SCM_TYP16S(x)          (0xfeff & SCM_CELL_TYPE (x))
+#define SCM_GCTYP16(x)                 (0xff7f & SCM_CELL_TYPE (x))
 
 
 
@@ -342,7 +342,7 @@ typedef long scm_bits_t;
  */
 #define SCM_GCCDR(x)           SCM_PACK(~1L & SCM_UNPACK (SCM_CDR (x)))
 #define SCM_GCMARKP(x)                 (1 & SCM_UNPACK (SCM_CDR (x)))
-#define SCM_GC8MARKP(x)        (0x80 & SCM_UNPACK_CAR (x))
+#define SCM_GC8MARKP(x)        (0x80 & SCM_CELL_TYPE (x))
 #define SCM_SETGCMARK(x)       SCM_SETOR_CDR (x, 1)
 #define SCM_CLRGCMARK(x)       SCM_SETAND_CDR (x, ~1L)
 #define SCM_SETGC8MARK(x)      SCM_SETOR_CAR (x, 0x80)