summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/__scm.h11
-rw-r--r--libguile/debug.c41
-rw-r--r--libguile/debug.h2
-rw-r--r--libguile/dynwind.c32
-rw-r--r--libguile/eval.c176
-rw-r--r--libguile/eval.h14
-rw-r--r--libguile/gc.c110
-rw-r--r--libguile/goops.c4
-rw-r--r--libguile/modules.c2
-rw-r--r--libguile/objects.c5
-rw-r--r--libguile/print.c64
-rw-r--r--libguile/procprop.c2
-rw-r--r--libguile/procs.c2
-rw-r--r--libguile/srcprop.c2
-rw-r--r--libguile/struct.c9
-rw-r--r--libguile/struct.h7
-rw-r--r--libguile/tags.h113
17 files changed, 203 insertions, 393 deletions
diff --git a/libguile/__scm.h b/libguile/__scm.h
index fd67075af..2e1e3b611 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -100,11 +100,12 @@
/* If the compile FLAG `SCM_CAUTIOUS' is #defined then the number of
* arguments is always checked for application of closures. If the
* compile FLAG `SCM_RECKLESS' is #defined then they are not checked.
- * Otherwise, number of argument checks for closures are made only when
- * the function position (whose value is the closure) of a combination is
- * not an ILOC or GLOC. When the function position of a combination is a
- * symbol it will be checked only the first time it is evaluated because
- * it will then be replaced with an ILOC or GLOC.
+ * Otherwise, number of argument checks for closures are made only
+ * when the function position (whose value is the closure) of a
+ * combination is not an ILOC or a variable (true?). When the
+ * function position of a combination is a symbol it will be checked
+ * only the first time it is evaluated because it will then be
+ * replaced with an ILOC or variable.
*/
#undef SCM_RECKLESS
#define SCM_CAUTIOUS
diff --git a/libguile/debug.c b/libguile/debug.c
index 49cce42c7..d4a97e260 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -196,17 +196,6 @@ scm_make_memoized (SCM exp, SCM env)
* specified, the top-level environment of the current module will
* be assumed. All environments must match.
*
- * - procedure: make-gloc VARIABLE [ENV]
- *
- * Return a gloc, encapsulated in a memoized object.
- *
- * (Glocs can't exist in normal list structures, since they will
- * be mistaken for structs.)
- *
- * - procedure: gloc? OBJECT
- *
- * Return #t if OBJECT is a memoized gloc.
- *
* - procedure: make-iloc FRAME BINDING CDRP
*
* Return an iloc referring to frame no. FRAME, binding
@@ -252,32 +241,6 @@ scm_make_memoized (SCM exp, SCM env)
#include "libguile/variable.h"
#include "libguile/procs.h"
-SCM_DEFINE (scm_make_gloc, "make-gloc", 1, 1, 0,
- (SCM var, SCM env),
- "Create a gloc for variable @var{var} in the environment\n"
- "@var{env}.")
-#define FUNC_NAME s_scm_make_gloc
-{
- SCM_VALIDATE_VARIABLE (1,var);
- if (SCM_UNBNDP (env))
- env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
- else
- SCM_VALIDATE_NULLORCONS (2,env);
- return scm_make_memoized (SCM_PACK (SCM_UNPACK (var) + scm_tc3_cons_gloc), env);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gloc_p, "gloc?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a gloc.")
-#define FUNC_NAME s_scm_gloc_p
-{
- return
- SCM_BOOL (SCM_MEMOIZEDP (obj)
- && ((SCM_UNPACK(SCM_MEMOIZED_EXP(obj))&7) == scm_tc3_cons_gloc));
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_make_iloc, "make-iloc", 3, 0, 0,
(SCM frame, SCM binding, SCM cdrp),
"Return a new iloc with frame offset @var{frame}, binding\n"
@@ -538,8 +501,8 @@ scm_m_start_stack (SCM exp, SCM env)
#define FUNC_NAME s_start_stack
{
exp = SCM_CDR (exp);
- if (!SCM_ECONSP (exp)
- || !SCM_ECONSP (SCM_CDR (exp))
+ if (!SCM_CONSP (exp)
+ || !SCM_CONSP (SCM_CDR (exp))
|| !SCM_NULLP (SCM_CDDR (exp)))
SCM_WRONG_NUM_ARGS ();
return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env);
diff --git a/libguile/debug.h b/libguile/debug.h
index 06a3133cb..c5b54a62c 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -209,8 +209,6 @@ extern SCM scm_make_debugobj (scm_t_debug_frame *debug);
extern void scm_init_debug (void);
#ifdef GUILE_DEBUG
-extern SCM scm_make_gloc (SCM var, SCM env);
-extern SCM scm_gloc_p (SCM obj);
extern SCM scm_make_iloc (SCM frame, SCM binding, SCM cdrp);
extern SCM scm_iloc_p (SCM obj);
extern SCM scm_memcons (SCM car, SCM cdr, SCM env);
diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index 6a32797cc..889c0d4fb 100644
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -185,15 +185,15 @@ SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
#endif
static void
-scm_swap_bindings (SCM glocs, SCM vals)
+scm_swap_bindings (SCM vars, SCM vals)
{
SCM tmp;
while (SCM_NIMP (vals))
{
- tmp = SCM_GLOC_VAL (SCM_CAR (glocs));
- SCM_GLOC_SET_VAL (SCM_CAR (glocs), SCM_CAR (vals));
+ tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
+ SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
SCM_SETCAR (vals, tmp);
- glocs = SCM_CDR (glocs);
+ vars = SCM_CDR (vars);
vals = SCM_CDR (vals);
}
}
@@ -219,13 +219,16 @@ scm_dowinds (SCM to, long delta)
#endif
{
wind_key = SCM_CAR (wind_elt);
- /* key = #t | symbol | thunk | list of glocs | list of fluids */
+ /* key = #t | symbol | thunk | list of variables | list of fluids */
if (SCM_NIMP (wind_key))
{
- if (SCM_TYP3 (wind_key) == scm_tc3_cons_gloc)
- scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
- else if (SCM_TYP3 (wind_key) == scm_tc3_cons)
- scm_swap_fluids (wind_key, SCM_CDR (wind_elt));
+ if (SCM_CONSP (wind_key))
+ {
+ if (SCM_VARIABLEP (SCM_CAR (wind_key)))
+ scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
+ else if (SCM_FLUIDP (SCM_CAR (wind_key)))
+ scm_swap_fluids (wind_key, SCM_CDR (wind_elt));
+ }
else if (SCM_GUARDSP (wind_key))
SCM_BEFORE_GUARD (wind_key) (SCM_GUARD_DATA (wind_key));
else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
@@ -254,10 +257,13 @@ scm_dowinds (SCM to, long delta)
wind_key = SCM_CAR (wind_elt);
if (SCM_NIMP (wind_key))
{
- if (SCM_TYP3 (wind_key) == scm_tc3_cons_gloc)
- scm_swap_bindings (wind_key, from);
- else if (SCM_TYP3 (wind_key) == scm_tc3_cons)
- scm_swap_fluids_reverse (wind_key, from);
+ if (SCM_CONSP (wind_key))
+ {
+ if (SCM_VARIABLEP (SCM_CAR (wind_key)))
+ scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
+ else if (SCM_FLUIDP (SCM_CAR (wind_key)))
+ scm_swap_fluids_reverse (wind_key, SCM_CDR (wind_elt));
+ }
else if (SCM_GUARDSP (wind_key))
SCM_AFTER_GUARD (wind_key) (SCM_GUARD_DATA (wind_key));
else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
diff --git a/libguile/eval.c b/libguile/eval.c
index 1978b2632..ff681d86d 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -156,10 +156,8 @@ char *alloca ();
: SCM_CEVAL (SCM_CAR (x), env))
#define EVALCAR(x, env) (!SCM_CELLP (SCM_CAR (x)) \
- ? (SCM_IMP (SCM_CAR (x)) \
- ? SCM_EVALIM (SCM_CAR (x), env) \
- : SCM_GLOC_VAL (SCM_CAR (x))) \
- : EVALCELLCAR (x, env))
+ ? SCM_EVALIM (SCM_CAR (x), env) \
+ : EVALCELLCAR (x, env))
#define EXTEND_ENV SCM_EXTEND_ENV
@@ -197,7 +195,7 @@ scm_ilookup (SCM iloc, SCM env)
tree-code instructions.
There shouldn't normally be a problem with memoizing local and
- global variable references (into ilocs and glocs), because all
+ global variable references (into ilocs and variables), because all
threads will mutate the code in *exactly* the same way and (if I
read the C code correctly) it is not possible to observe a half-way
mutated cons cell. The lookup procedure can handle this
@@ -205,11 +203,11 @@ scm_ilookup (SCM iloc, SCM env)
It is different with macro expansion, because macro expansion
happens outside of the lookup procedure and can't be
- undone. Therefore it can't cope with it. It has to indicate
- failure when it detects a lost race and hope that the caller can
- handle it. Luckily, it turns out that this is the case.
+ undone. Therefore the lookup procedure can't cope with it. It has
+ to indicate failure when it detects a lost race and hope that the
+ caller can handle it. Luckily, it turns out that this is the case.
- An example to illustrate this: Suppose that the follwing form will
+ An example to illustrate this: Suppose that the following form will
be memoized concurrently by two threads
(let ((x 12)) x)
@@ -226,13 +224,13 @@ scm_ilookup (SCM iloc, SCM env)
But let's see what will happen when the race occurs while looking
up the symbol "let" at the start of the form. It could happen that
the second thread interrupts the lookup of the first thread and not
- only substitutes a gloc for it but goes right ahead and replaces it
- with the compiled form (#@let* (x 12) x). Now, when the first
- thread completes its lookup, it would replace the #@let* with a
- gloc pointing to the "let" binding, effectively reverting the form
- to (let (x 12) x). This is wrong. It has to detect that it has
- lost the race and the evaluator has to reconsider the changed form
- completely.
+ only substitutes a variable for it but goes right ahead and
+ replaces it with the compiled form (#@let* (x 12) x). Now, when
+ the first thread completes its lookup, it would replace the #@let*
+ with a variable containing the "let" binding, effectively reverting
+ the form to (let (x 12) x). This is wrong. It has to detect that
+ it has lost the race and the evaluator has to reconsider the
+ changed form completely.
This race condition could be resolved with some kind of traffic
light (like mutexes) around scm_lookupcar, but I think that it is
@@ -370,15 +368,13 @@ scm_lookupcar (SCM vloc, SCM genv, int check)
completely. */
race:
var = SCM_CAR (vloc);
- if (SCM_ITAG3 (var) == scm_tc3_cons_gloc)
- return SCM_GLOC_VAL_LOC (var);
if (SCM_VARIABLEP (var))
return SCM_VARIABLE_LOC (var);
#ifdef MEMOIZE_LOCALS
if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00))
return scm_ilookup (var, genv);
#endif
- /* We can't cope with anything else than glocs and ilocs. When
+ /* We can't cope with anything else than variables and ilocs. When
a special form has been memoized (i.e. `let' into `#@let') we
return NULL and expect the calling function to do the right
thing. For the evaluator, this means going back and redoing
@@ -415,15 +411,7 @@ scm_unmemocar (SCM form, SCM env)
if (SCM_IMP (form))
return form;
c = SCM_CAR (form);
- if (SCM_ITAG3 (c) == scm_tc3_cons_gloc)
- {
- SCM sym =
- scm_module_reverse_lookup (scm_env_module (env), SCM_GLOC_VAR (c));
- if (SCM_EQ_P (sym, SCM_BOOL_F))
- sym = sym_three_question_marks;
- SCM_SETCAR (form, sym);
- }
- else if (SCM_VARIABLEP (c))
+ if (SCM_VARIABLEP (c))
{
SCM sym =
scm_module_reverse_lookup (scm_env_module (env), c);
@@ -839,7 +827,7 @@ iqq (SCM form, SCM env, long depth)
--depth;
label:
form = SCM_CDR (form);
- SCM_ASSERT (SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)),
+ SCM_ASSERT (SCM_CONSP (form) && SCM_NULLP (SCM_CDR (form)),
form, SCM_ARG1, s_quasiquote);
if (0 == depth)
return evalcar (form, env);
@@ -1120,7 +1108,7 @@ scm_m_atfop (SCM xorig, SCM env SCM_UNUSED)
var = scm_symbol_fref (SCM_CAR (x));
SCM_ASSYNT (SCM_VARIABLEP (var),
"Symbol's function definition is void", NULL);
- SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (var) + scm_tc3_cons_gloc);
+ SCM_SETCAR (x, var);
return x;
}
@@ -1146,7 +1134,7 @@ scm_m_atbind (SCM xorig, SCM env)
x = SCM_CAR (x);
while (SCM_NIMP (x))
{
- SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_sym2var (SCM_CAR (x), env, SCM_BOOL_T)) + scm_tc3_cons_gloc);
+ SCM_SETCAR (x, scm_sym2var (SCM_CAR (x), env, SCM_BOOL_T));
x = SCM_CDR (x);
}
return scm_cons (SCM_IM_BIND, SCM_CDR (xorig));
@@ -1291,7 +1279,7 @@ unmemocopy (SCM x, SCM env)
#ifdef DEBUG_EXTENSIONS
SCM p;
#endif
- if (SCM_NCELLP (x) || SCM_NECONSP (x))
+ if (SCM_NCELLP (x) || SCM_NCONSP (x))
return x;
#ifdef DEBUG_EXTENSIONS
p = scm_whash_lookup (scm_source_whash, x);
@@ -1459,7 +1447,7 @@ unmemocopy (SCM x, SCM env)
env);
}
loop:
- while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x))
+ while (SCM_CELLP (x = SCM_CDR (x)) && SCM_CONSP (x))
{
if (SCM_ISYMP (SCM_CAR (x)))
/* skip body markers */
@@ -1528,40 +1516,17 @@ SCM
scm_eval_args (SCM l, SCM env, SCM proc)
{
SCM results = SCM_EOL, *lloc = &results, res;
- while (!SCM_IMP (l))
+ while (SCM_CONSP (l))
{
-#ifdef SCM_CAUTIOUS
- if (SCM_CONSP (l))
- {
- if (SCM_IMP (SCM_CAR (l)))
- res = SCM_EVALIM (SCM_CAR (l), env);
- else
- res = EVALCELLCAR (l, env);
- }
- else if (SCM_TYP3 (l) == scm_tc3_cons_gloc)
- {
- scm_t_bits vcell =
- SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell];
- if (vcell == 0)
- res = SCM_CAR (l); /* struct planted in code */
- else
- res = SCM_GLOC_VAL (SCM_CAR (l));
- }
- else
- goto wrongnumargs;
-#else
res = EVALCAR (l, env);
-#endif
+
*lloc = scm_cons (res, SCM_EOL);
lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
#ifdef SCM_CAUTIOUS
if (!SCM_NULLP (l))
- {
- wrongnumargs:
- scm_wrong_num_args (proc);
- }
+ scm_wrong_num_args (proc);
#endif
return results;
}
@@ -1758,40 +1723,17 @@ SCM
scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
{
SCM *results = lloc, res;
- while (!SCM_IMP (l))
+ while (SCM_CONSP (l))
{
-#ifdef SCM_CAUTIOUS
- if (SCM_CONSP (l))
- {
- if (SCM_IMP (SCM_CAR (l)))
- res = SCM_EVALIM (SCM_CAR (l), env);
- else
- res = EVALCELLCAR (l, env);
- }
- else if (SCM_TYP3 (l) == scm_tc3_cons_gloc)
- {
- scm_t_bits vcell =
- SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell];
- if (vcell == 0)
- res = SCM_CAR (l); /* struct planted in code */
- else
- res = SCM_GLOC_VAL (SCM_CAR (l));
- }
- else
- goto wrongnumargs;
-#else
res = EVALCAR (l, env);
-#endif
+
*lloc = scm_cons (res, SCM_EOL);
lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
#ifdef SCM_CAUTIOUS
if (!SCM_NULLP (l))
- {
- wrongnumargs:
- scm_wrong_num_args (proc);
- }
+ scm_wrong_num_args (proc);
#endif
return *results;
}
@@ -2014,7 +1956,7 @@ dispatch:
if (!SCM_CELLP (SCM_CAR (x)))
{
x = SCM_CAR (x);
- RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x))
+ RETURN (SCM_EVALIM (x, env))
}
if (SCM_SYMBOLP (SCM_CAR (x)))
@@ -2208,9 +2150,6 @@ dispatch:
else
t.lloc = scm_lookupcar (x, env, 1);
break;
- case scm_tc3_cons_gloc:
- t.lloc = SCM_GLOC_VAL_LOC (proc);
- break;
#ifdef MEMOIZE_LOCALS
case scm_tc3_imm24:
t.lloc = scm_ilookup (proc, env);
@@ -2309,8 +2248,8 @@ dispatch:
arg2 = *scm_ilookup (proc, env);
else if (SCM_NCONSP (proc))
{
- if (SCM_NCELLP (proc))
- arg2 = SCM_GLOC_VAL (proc);
+ if (SCM_VARIABLEP (proc))
+ arg2 = SCM_VARIABLE_REF (proc);
else
arg2 = *scm_lookupcar (SCM_CDR (x), env, 1);
}
@@ -2477,9 +2416,8 @@ dispatch:
arg2 = SCM_CDAR (env);
while (SCM_NIMP (arg2))
{
- proc = SCM_GLOC_VAL (SCM_CAR (t.arg1));
- SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L),
- SCM_CAR (arg2));
+ proc = SCM_VARIABLE_REF (SCM_CAR (t.arg1));
+ SCM_VARIABLE_SET (SCM_CAR (t.arg1), SCM_CAR (arg2));
SCM_SETCAR (arg2, proc);
t.arg1 = SCM_CDR (t.arg1);
arg2 = SCM_CDR (arg2);
@@ -2499,8 +2437,7 @@ dispatch:
arg2 = SCM_CDAR (env);
while (SCM_NIMP (arg2))
{
- SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L),
- SCM_CAR (arg2));
+ SCM_VARIABLE_SET (SCM_CAR (t.arg1), SCM_CAR (arg2));
t.arg1 = SCM_CDR (t.arg1);
arg2 = SCM_CDR (arg2);
}
@@ -2557,6 +2494,7 @@ dispatch:
case scm_tc7_cclo:
case scm_tc7_pws:
case scm_tcs_subrs:
+ case scm_tcs_struct:
RETURN (x);
case scm_tc7_variable:
@@ -2573,25 +2511,7 @@ dispatch:
#endif
break;
#endif /* ifdef MEMOIZE_LOCALS */
-
- case scm_tcs_cons_gloc: {
- scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
- if (vcell == 0) {
- /* This is a struct implanted in the code, not a gloc. */
- RETURN (x);
- } else {
- proc = SCM_GLOC_VAL (SCM_CAR (x));
- SCM_ASRTGO (SCM_NIMP (proc), badfun);
-#ifndef SCM_RECKLESS
-#ifdef SCM_CAUTIOUS
- goto checkargs;
-#endif
-#endif
- }
- break;
- }
-
case scm_tcs_cons_nimcar:
orig_sym = SCM_CAR (x);
if (SCM_SYMBOLP (orig_sym))
@@ -2733,7 +2653,7 @@ evapply:
x = SCM_CODE (proc);
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc));
goto nontoplevel_cdrxbegin;
- case scm_tcs_cons_gloc: /* really structs, not glocs */
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_ENTITY_PROCEDURE (proc);
@@ -2786,14 +2706,6 @@ evapply:
else
t.arg1 = EVALCELLCAR (x, env);
}
- else if (SCM_TYP3 (x) == scm_tc3_cons_gloc)
- {
- scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
- if (vcell == 0)
- t.arg1 = SCM_CAR (x); /* struct planted in code */
- else
- t.arg1 = SCM_GLOC_VAL (SCM_CAR (x));
- }
else
goto wrongnumargs;
#else
@@ -2888,7 +2800,7 @@ evapply:
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
#endif
goto nontoplevel_cdrxbegin;
- case scm_tcs_cons_gloc: /* really structs, not glocs */
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_ENTITY_PROCEDURE (proc);
@@ -2936,14 +2848,6 @@ evapply:
else
arg2 = EVALCELLCAR (x, env);
}
- else if (SCM_TYP3 (x) == scm_tc3_cons_gloc)
- {
- scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
- if (vcell == 0)
- arg2 = SCM_CAR (x); /* struct planted in code */
- else
- arg2 = SCM_GLOC_VAL (SCM_CAR (x));
- }
else
goto wrongnumargs;
#else
@@ -2992,7 +2896,7 @@ evapply:
proc))),
SCM_EOL));
#endif
- case scm_tcs_cons_gloc: /* really structs, not glocs */
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_ENTITY_PROCEDURE (proc);
@@ -3058,7 +2962,7 @@ evapply:
}
}
#ifdef SCM_CAUTIOUS
- if (SCM_IMP (x) || SCM_NECONSP (x))
+ if (SCM_IMP (x) || SCM_NCONSP (x))
goto wrongnumargs;
#endif
#ifdef DEVAL
@@ -3206,7 +3110,7 @@ evapply:
x = SCM_CODE (proc);
goto nontoplevel_cdrxbegin;
#endif /* DEVAL */
- case scm_tcs_cons_gloc: /* really structs, not glocs */
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
#ifdef DEVAL
@@ -3649,7 +3553,7 @@ tail:
debug.vect[0].a.proc = proc;
#endif
goto tail;
- case scm_tcs_cons_gloc: /* really structs, not glocs */
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
#ifdef DEVAL
diff --git a/libguile/eval.h b/libguile/eval.h
index 418844c0a..18e245483 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -115,9 +115,7 @@ extern SCM scm_eval_options_interface (SCM setting);
? SCM_EVALIM2(x) \
: (*scm_ceval_ptr) ((x), (env)))
#define SCM_XEVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
- ? (SCM_IMP (SCM_CAR (x)) \
- ? SCM_EVALIM (SCM_CAR (x), env) \
- : SCM_GLOC_VAL (SCM_CAR (x))) \
+ ? SCM_EVALIM (SCM_CAR (x), env) \
: (SCM_SYMBOLP (SCM_CAR (x)) \
? *scm_lookupcar (x, env, 1) \
: (*scm_ceval_ptr) (SCM_CAR (x), env)))
@@ -182,16 +180,6 @@ extern SCM scm_sym_args;
extern SCM scm_f_apply;
-/* A resolved global variable reference in the CAR position
- * of a list is stored (in code only) as a pointer to a variable with a
- * tag of 1. This is called a "gloc".
- */
-
-#define SCM_GLOC_VAR(x) (SCM_PACK(SCM_UNPACK(x)-scm_tc3_cons_gloc))
-#define SCM_GLOC_VAL(x) (SCM_VARIABLE_REF (SCM_GLOC_VAR (x)))
-#define SCM_GLOC_SET_VAL(x, y) (SCM_VARIABLE_SET (SCM_GLOC_VAR (x), y))
-#define SCM_GLOC_VAL_LOC(x) (SCM_VARIABLE_LOC (SCM_GLOC_VAR (x)))
-
extern SCM * scm_ilookup (SCM iloc, SCM env);
diff --git a/libguile/gc.c b/libguile/gc.c
index 43d532dff..83b9263e6 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1257,63 +1257,40 @@ gc_mark_loop_first_time:
RECURSE (SCM_SETTER (ptr));
ptr = SCM_PROCEDURE (ptr);
goto_gc_mark_loop;
- case scm_tcs_cons_gloc:
+ case scm_tcs_struct:
{
- /* Dirk:FIXME:: The following code is super ugly: ptr may be a
- * struct or a gloc. If it is a gloc, the cell word #0 of ptr
- * is the address of a scm_tc16_variable smob. If it is a
- * struct, the cell word #0 of ptr is a pointer to a struct
- * vtable data region. (The fact that these are accessed in
- * the same way restricts the possibilites to change the data
- * layout of structs or heap cells.) To discriminate between
- * the two, it is guaranteed that the scm_vtable_index_vcell
- * element of the prospective vtable is always zero. For a
- * gloc, this location has the CDR of the variable smob, which
- * is guaranteed to be non-zero.
- */
- scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc;
- scm_t_bits * vtable_data = (scm_t_bits *) word0; /* access as struct */
- if (vtable_data [scm_vtable_index_vcell] != 0)
+ /* XXX - use less explicit code. */
+ scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct;
+ scm_t_bits * vtable_data = (scm_t_bits *) word0;
+ SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
+ long len = SCM_SYMBOL_LENGTH (layout);
+ char * fields_desc = SCM_SYMBOL_CHARS (layout);
+ scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);
+
+ if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
{
- /* ptr is a gloc */
- SCM gloc_car = SCM_PACK (word0);
- RECURSE (gloc_car);
- ptr = SCM_CDR (ptr);
- goto gc_mark_loop;
- }
- else
- {
- /* ptr is a struct */
- SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
- long len = SCM_SYMBOL_LENGTH (layout);
- char * fields_desc = SCM_SYMBOL_CHARS (layout);
- scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);
-
- if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
- {
- RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure]));
- RECURSE (SCM_PACK (struct_data[scm_struct_i_setter]));
- }
- if (len)
- {
- long x;
-
- for (x = 0; x < len - 2; x += 2, ++struct_data)
- if (fields_desc[x] == 'p')
- RECURSE (SCM_PACK (*struct_data));
- if (fields_desc[x] == 'p')
- {
- if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
- for (x = *struct_data++; x; --x, ++struct_data)
- RECURSE (SCM_PACK (*struct_data));
- else
- RECURSE (SCM_PACK (*struct_data));
- }
- }
- /* mark vtable */
- ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
- goto_gc_mark_loop;
+ RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure]));
+ RECURSE (SCM_PACK (struct_data[scm_struct_i_setter]));
+ }
+ if (len)
+ {
+ long x;
+
+ for (x = 0; x < len - 2; x += 2, ++struct_data)
+ if (fields_desc[x] == 'p')
+ RECURSE (SCM_PACK (*struct_data));
+ if (fields_desc[x] == 'p')
+ {
+ if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
+ for (x = *struct_data++; x; --x, ++struct_data)
+ RECURSE (SCM_PACK (*struct_data));
+ else
+ RECURSE (SCM_PACK (*struct_data));
+ }
}
+ /* mark vtable */
+ ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
+ goto_gc_mark_loop;
}
break;
case scm_tcs_closures:
@@ -1748,28 +1725,15 @@ scm_gc_sweep ()
switch SCM_TYP7 (scmptr)
{
- case scm_tcs_cons_gloc:
+ case scm_tcs_struct:
{
- /* Dirk:FIXME:: Again, super ugly code: scmptr may be a
- * struct or a gloc. See the corresponding comment in
- * scm_gc_mark.
+ /* Structs need to be freed in a special order.
+ * This is handled by GC C hooks in struct.c.
*/
- scm_t_bits word0 = (SCM_CELL_WORD_0 (scmptr)
- - scm_tc3_cons_gloc);
- /* access as struct */
- scm_t_bits * vtable_data = (scm_t_bits *) word0;
- if (vtable_data[scm_vtable_index_vcell] == 0)
- {
- /* Structs need to be freed in a special order.
- * This is handled by GC C hooks in struct.c.
- */
- SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free);
- scm_structs_to_free = scmptr;
- continue;
- }
- /* fall through so that scmptr gets collected */
+ SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free);
+ scm_structs_to_free = scmptr;
}
- break;
+ continue;
case scm_tcs_cons_imcar:
case scm_tcs_cons_nimcar:
case scm_tcs_closures:
diff --git a/libguile/goops.c b/libguile/goops.c
index 8e147bea9..94e7d6847 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1313,7 +1313,7 @@ wrap_init (SCM class, SCM *m, long n)
SCM_SET_STRUCT_GC_CHAIN (z, 0);
SCM_SET_CELL_WORD_1 (z, m);
SCM_SET_CELL_WORD_0 (z, (scm_t_bits) SCM_STRUCT_DATA (class)
- | scm_tc3_cons_gloc);
+ | scm_tc3_struct);
return z;
}
@@ -2594,7 +2594,7 @@ scm_wrap_object (SCM class, void *data)
SCM_NEWCELL2 (z);
SCM_SETCDR (z, SCM_PACK ((scm_t_bits) data));
SCM_SET_STRUCT_GC_CHAIN (z, 0);
- SCM_SETCAR (z, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_cons_gloc);
+ SCM_SETCAR (z, SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct);
return z;
}
diff --git a/libguile/modules.c b/libguile/modules.c
index 062e3f9ee..ed8fdfdda 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -627,7 +627,7 @@ scm_post_boot_init_modules ()
#define PERM(x) scm_permanent_object(x)
SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
- scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_cons_gloc);
+ scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
diff --git a/libguile/objects.c b/libguile/objects.c
index e920ac78d..424cd466e 100644
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -168,8 +168,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
: SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
: SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
- case scm_tcs_cons_gloc:
- /* must be a struct */
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
return SCM_CLASS_OF (x);
else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
@@ -204,7 +203,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return scm_class_unknown;
}
- case scm_tc3_cons_gloc:
+ case scm_tc3_struct:
case scm_tc3_tc7_1:
case scm_tc3_tc7_2:
case scm_tc3_closure:
diff --git a/libguile/print.c b/libguile/print.c
index 3873da422..6204a8738 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -397,7 +397,6 @@ SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display);
void
scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
-taloop:
switch (SCM_ITAG3 (exp))
{
case scm_tc3_closure:
@@ -451,39 +450,30 @@ taloop:
scm_ipruk ("immediate", exp, port);
}
break;
- case scm_tc3_cons_gloc:
- /* gloc */
- scm_puts ("#@", port);
- exp = scm_module_reverse_lookup (scm_current_module (),
- SCM_GLOC_VAR (exp));
- goto taloop;
case scm_tc3_cons:
switch (SCM_TYP7 (exp))
{
- case scm_tcs_cons_gloc:
-
- 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)
- {
- SCM pwps, print = pstate->writingp ? g_write : g_display;
- if (!print)
- goto print_struct;
- SCM_NEWSMOB (pwps,
- scm_tc16_port_with_ps,
- SCM_UNPACK (scm_cons (port, pstate->handle)));
- scm_call_generic_2 (print, exp, pwps);
- }
- else
- {
- print_struct:
- scm_print_struct (exp, port, pstate);
- }
- EXIT_NESTED_DATA (pstate);
- break;
- }
-
+ case scm_tcs_struct:
+ {
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
+ {
+ SCM pwps, print = pstate->writingp ? g_write : g_display;
+ if (!print)
+ goto print_struct;
+ SCM_NEWSMOB (pwps,
+ scm_tc16_port_with_ps,
+ SCM_UNPACK (scm_cons (port, pstate->handle)));
+ scm_call_generic_2 (print, exp, pwps);
+ }
+ else
+ {
+ print_struct:
+ scm_print_struct (exp, port, pstate);
+ }
+ EXIT_NESTED_DATA (pstate);
+ }
+ break;
case scm_tcs_cons_imcar:
case scm_tcs_cons_nimcar:
ENTER_NESTED_DATA (pstate, exp, circref);
@@ -754,9 +744,7 @@ scm_ipruk (char *hdr, SCM ptr, SCM port)
}
-/* Print a list. The list may be either a list of ordinary data, or it may be
- a list that represents code. Lists that represent code may contain gloc
- cells.
+/* Print a list.
*/
void
scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate)
@@ -772,12 +760,12 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate)
O(depth * N) instead of O(N^2). */
hare = SCM_CDR (exp);
tortoise = exp;
- while (SCM_ECONSP (hare))
+ while (SCM_CONSP (hare))
{
if (SCM_EQ_P (hare, tortoise))
goto fancy_printing;
hare = SCM_CDR (hare);
- if (SCM_IMP (hare) || SCM_NECONSP (hare))
+ if (SCM_IMP (hare) || SCM_NCONSP (hare))
break;
hare = SCM_CDR (hare);
tortoise = SCM_CDR (tortoise);
@@ -785,7 +773,7 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate)
/* No cdr cycles intrinsic to this list */
scm_iprin1 (SCM_CAR (exp), port, pstate);
- for (exp = SCM_CDR (exp); SCM_ECONSP (exp); exp = SCM_CDR (exp))
+ for (exp = SCM_CDR (exp); SCM_CONSP (exp); exp = SCM_CDR (exp))
{
register long i;
@@ -814,7 +802,7 @@ fancy_printing:
scm_iprin1 (SCM_CAR (exp), port, pstate);
exp = SCM_CDR (exp); --n;
- for (; SCM_ECONSP (exp); exp = SCM_CDR (exp))
+ for (; SCM_CONSP (exp); exp = SCM_CDR (exp))
{
register unsigned long i;
diff --git a/libguile/procprop.c b/libguile/procprop.c
index d3d63a3dd..e6136527d 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -137,7 +137,7 @@ scm_i_procedure_arity (SCM proc)
if (!SCM_NULLP (proc))
r = 1;
break;
- case scm_tcs_cons_gloc:
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
r = 1;
diff --git a/libguile/procs.c b/libguile/procs.c
index 576ca91e6..78b703bca 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -198,7 +198,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
if (SCM_NIMP (obj))
switch (SCM_TYP7 (obj))
{
- case scm_tcs_cons_gloc:
+ case scm_tcs_struct:
if (!SCM_I_OPERATORP (obj))
break;
case scm_tcs_closures:
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index 9f2c89b31..651066135 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -218,7 +218,7 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
if (SCM_MEMOIZEDP (obj))
obj = SCM_MEMOIZED_EXP (obj);
#ifndef SCM_RECKLESS
- else if (SCM_NECONSP (obj))
+ else if (SCM_NCONSP (obj))
SCM_WRONG_TYPE_ARG (1, obj);
#endif
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
diff --git a/libguile/struct.c b/libguile/struct.c
index e4014a9d5..dfc183e42 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -402,8 +402,8 @@ scm_free_structs (void *dummy1 SCM_UNUSED,
}
else
{
- scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_cons_gloc;
- /* access as struct */
+ /* XXX - use less explicit code. */
+ scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_struct;
scm_t_bits * vtable_data = (scm_t_bits *) word0;
scm_t_bits * data = SCM_STRUCT_DATA (obj);
scm_t_struct_free free_struct_data
@@ -470,7 +470,8 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
SCM_SET_CELL_WORD_1 (handle, data);
SCM_SET_STRUCT_GC_CHAIN (handle, 0);
scm_struct_init (handle, layout, data, tail_elts, init);
- SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) SCM_STRUCT_DATA (vtable) + scm_tc3_cons_gloc);
+ SCM_SET_CELL_WORD_0 (handle,
+ (scm_t_bits) SCM_STRUCT_DATA (vtable) + scm_tc3_struct);
SCM_ALLOW_INTS;
return handle;
}
@@ -551,7 +552,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
SCM_SET_STRUCT_GC_CHAIN (handle, 0);
data [scm_vtable_index_layout] = SCM_UNPACK (layout);
scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init));
- SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) data + scm_tc3_cons_gloc);
+ SCM_SET_CELL_WORD_0 (handle, (scm_t_bits) data + scm_tc3_struct);
SCM_ALLOW_INTS;
return handle;
}
diff --git a/libguile/struct.h b/libguile/struct.h
index 659052501..ed330818d 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -63,7 +63,7 @@
#define scm_struct_i_size -1 /* Instance size */
#define scm_struct_i_flags -1 /* Upper 12 bits used as flags */
#define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */
-#define scm_vtable_index_vcell 1 /* An opaque word, managed by the garbage collector. */
+#define scm_vtable_index_vcell 1 /* XXX - remove this, it is unused. */
#define scm_vtable_index_vtable 2 /* A pointer to the handle for this vtable. */
#define scm_vtable_index_printer 3 /* A printer for this struct type. */
#define scm_vtable_offset_user 4 /* Where do user fields start? */
@@ -75,10 +75,9 @@ typedef size_t (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data);
#define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation
(no hidden words) */
-/* Dirk:FIXME:: the SCM_STRUCTP predicate is also fulfilled for glocs */
-#define SCM_STRUCTP(X) (SCM_NIMP(X) && (SCM_TYP3(X) == scm_tc3_cons_gloc))
+#define SCM_STRUCTP(X) (SCM_NIMP(X) && (SCM_TYP3(X) == scm_tc3_struct))
#define SCM_STRUCT_DATA(X) ((scm_t_bits *) SCM_CELL_WORD_1 (X))
-#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_cons_gloc))
+#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_struct))
#define SCM_STRUCT_LAYOUT(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout]))
#define SCM_SET_STRUCT_LAYOUT(X, v) (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout] = SCM_UNPACK (v))
diff --git a/libguile/tags.h b/libguile/tags.h
index b40fbc754..5dec122fb 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -117,20 +117,24 @@ typedef signed long scm_t_signed_bits;
* only (i.e., programmers must keep track of any SCM variables they
* create that don't contain ordinary scheme values).
*
- * All immediates and non-immediates must have a 0 in bit 0. Only
- * non-object values can have a 1 in bit 0. In some cases, bit 0 of a
- * word in the heap is used for the GC tag so during garbage
- * collection, that bit might be 1 even in an immediate or
- * non-immediate value. In other cases, bit 0 of a word in the heap
- * is used to tag a pointer to a GLOC (VM global variable address) or
- * the header of a struct. But whenever an SCM variable holds a
- * normal Scheme value, bit 0 is 0.
- *
- * Immediates and non-immediates are distinguished by bits two and four.
- * Immediate values must have a 1 in at least one of those bits. Does
- * this (or any other detail of tagging) seem arbitrary? Try changing it!
- * (Not always impossible but it is fair to say that many details of tags
- * are mutually dependent). */
+ * All immediates and pointers to cells of non-immediates have a 0 in
+ * bit 0. All non-immediates that are not pairs have a 1 in bit 0 of
+ * the first word of their cell. This is how pairs are distinguished
+ * from other non-immediates; a pair can have a immediate in its car
+ * (thus a 0 in bit 0), or a pointer to the cell of a non-immediate
+ * (again, this pointer has a 0 in bit 0).
+ *
+ * Immediates and non-immediates are distinguished by bits 1 and 2.
+ * Immediate values must have a 1 in at least one of those bits.
+ * Consequently, a pointer to a cell of a non-immediate must have
+ * zeros in bits 1 and 2. Together with the requirement from above
+ * that bit 0 must also be zero, this means that pointers to cells of
+ * non-immediates must have their three low bits all zero. This in
+ * turn means that cells must be aligned on a 8 byte boundary, which
+ * is just right for two 32bit numbers (surprise, surprise). Does
+ * this (or any other detail of tagging) seem arbitrary? Try changing
+ * it! (Not always impossible but it is fair to say that many details
+ * of tags are mutually dependent). */
#define SCM_IMP(x) (6 & SCM_UNPACK (x))
#define SCM_NIMP(x) (!SCM_IMP (x))
@@ -142,17 +146,17 @@ typedef signed long scm_t_signed_bits;
*
*
* 0 Most objects except...
- * 1 ...glocs and structs (this tag valid only in a SCM_CAR or
- * in the header of a struct's data).
+ * 1 ... structs (this tag is valid only in the header
+ * of a struct's data, as with all odd tags).
*
* 00 heap addresses and many immediates (not integers)
- * 01 glocs/structs, some tc7_ codes
+ * 01 structs, some tc7_ codes
* 10 immediate integers
* 11 various tc7_ codes including, tc16_ codes.
*
*
* 000 heap address
- * 001 glocs/structs
+ * 001 structs
* 010 integer
* 011 closure
* 100 immediates
@@ -191,33 +195,35 @@ typedef signed long scm_t_signed_bits;
* with the 13 immediates above being some of the most interesting.
*
* Also noteworthy are the groups of 16 7-bit instructions implied by
- * some of the 3-bit tags. For example, closure references consist
- * of an 8-bit aligned address tagged with 011. There are 16 identical 7-bit
- * instructions, all ending 011, which are invoked by evaluating closures.
+ * some of the 3-bit tags. For example, closure references consist of
+ * an 8-byte aligned address tagged with 011. There are 16 identical
+ * 7-bit instructions, all ending 011, which are invoked by evaluating
+ * closures.
*
* In other words, if you hand the evaluator a closure, the evaluator
- * treats the closure as a graph of virtual machine instructions.
- * A closure is a pair with a pointer to the body of the procedure
- * in the CDR and a pointer to the environment of the closure in the CAR.
+ * treats the closure as a graph of virtual machine instructions. A
+ * closure is a pair with a pointer to the body of the procedure in
+ * the CDR and a pointer to the environment of the closure in the CAR.
* The environment pointer is tagged 011 which implies that the least
- * significant 7 bits of the environment pointer also happen to be
- * a virtual machine instruction we could call "SELF" (for self-evaluating
- * object).
- *
- * A less trivial example are the 16 instructions ending 000. If those
- * bits tag the CAR of a pair, then evidently the pair is an ordinary
- * cons pair and should be evaluated as a procedure application. The sixteen,
- * 7-bit 000 instructions are all "NORMAL-APPLY" (Things get trickier.
- * For example, if the CAR of a procedure application is a symbol, the NORMAL-APPLY
- * instruction will, as a side effect, overwrite that CAR with a new instruction
- * that contains a cached address for the variable named by the symbol.)
+ * significant 7 bits of the environment pointer also happen to be a
+ * virtual machine instruction we could call "SELF" (for
+ * self-evaluating object).
+ *
+ * A less trivial example are the 16 instructions ending 000. If
+ * those bits tag the CAR of a pair, then evidently the pair is an
+ * ordinary cons pair and should be evaluated as a procedure
+ * application. The sixteen, 7-bit 000 instructions are all
+ * "NORMAL-APPLY" (Things get trickier. For example, if the CAR of a
+ * procedure application is a symbol, the NORMAL-APPLY instruction
+ * will, as a side effect, overwrite that CAR with a new instruction
+ * that contains a cached address for the variable named by the
+ * symbol.)
*
* Here is a summary of tags in the CAR of a non-immediate:
*
* HEAP CELL: G=gc_mark; 1 during mark, 0 other times.
*
* cons ..........SCM car..............0 ...........SCM cdr.............G
- * gloc ..........SCM vcell..........001 ...........SCM cdr.............G
* struct ..........void * type........001 ...........void * data.........G
* closure ..........SCM code...........011 ...........SCM env.............G
* tc7 ......24.bits of data...Gxxxx1S1 ..........void *data............
@@ -284,17 +290,6 @@ typedef signed long scm_t_signed_bits;
#define SCM_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))
#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_IMP (x) \
- && (SCM_CONSP (x) \
- || (SCM_TYP3 (x) == 1 \
- && (SCM_STRUCT_VTABLE_DATA (x)[scm_vtable_index_vcell] != 0))))
-#define SCM_NECONSP(x) (!SCM_ECONSP (x))
-
#define SCM_CELLP(x) (((sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0)
@@ -303,11 +298,11 @@ typedef signed long scm_t_signed_bits;
/* See numbers.h for macros relating to immediate integers.
*/
-#define SCM_ITAG3(x) (7 & SCM_UNPACK (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
+#define SCM_ITAG3(x) (7 & SCM_UNPACK (x))
+#define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x))
+#define scm_tc3_cons 0
+#define scm_tc3_struct 1
+#define scm_tc3_int_1 2
#define scm_tc3_closure 3
#define scm_tc3_imm24 4
#define scm_tc3_tc7_1 5
@@ -497,8 +492,10 @@ extern char *scm_isymnames[]; /* defined in print.c */
-/* Dispatching aids: */
+/* Dispatching aids:
+ When switching on SCM_TYP7 of a SCM value, use these fake case
+ labels to catch types that use fewer than 7 bits for tagging. */
/* For cons pairs with immediate values in the CAR
*/
@@ -523,20 +520,22 @@ extern char *scm_isymnames[]; /* defined in print.c */
case 64:case 72:case 80:case 88:\
case 96:case 104:case 112:case 120
-/* A CONS_GLOC occurs in code. It's CAR is a pointer to the
- * CDR of a variable. The low order bits of the CAR are 001.
- * The CDR of the gloc is the code continuation.
+/* For structs
*/
-#define scm_tcs_cons_gloc 1:case 9:case 17:case 25:\
+#define scm_tcs_struct 1:case 9:case 17:case 25:\
case 33:case 41:case 49:case 57:\
case 65:case 73:case 81:case 89:\
case 97:case 105:case 113:case 121
+/* For closures
+ */
#define scm_tcs_closures 3:case 11:case 19:case 27:\
case 35:case 43:case 51:case 59:\
case 67:case 75:case 83:case 91:\
case 99:case 107:case 115:case 123
+/* For subrs
+ */
#define scm_tcs_subrs scm_tc7_asubr:case scm_tc7_subr_0:case scm_tc7_subr_1:case scm_tc7_cxr:\
case scm_tc7_subr_3:case scm_tc7_subr_2:case scm_tc7_rpsubr:case scm_tc7_subr_1o:\
case scm_tc7_subr_2o:case scm_tc7_lsubr_2:case scm_tc7_lsubr