[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
guile/guile-core/libguile tags.h struct.h struc...
|
From: |
Marius Vollmer |
|
Subject: |
guile/guile-core/libguile tags.h struct.h struc... |
|
Date: |
Thu, 26 Jul 2001 14:40:18 -0700 |
CVSROOT: /cvs
Module name: guile
Changes by: Marius Vollmer <address@hidden> 01/07/26 14:40:18
Modified files:
guile-core/libguile: tags.h struct.h struct.c srcprop.c procs.c
procprop.c print.c objects.c modules.c
goops.c gc.c eval.h eval.c dynwind.c
debug.h debug.c __scm.h
Log message:
* tags.h: Update tag system docs.
(scm_tc3_cons_gloc): Renamed to scm_tc3_struct. Changed all uses.
(scm_tcs_cons_gloc): Renamed to scm_tcs_struct. Changed all uses.
(SCM_ECONSP, SCM_NECONSP): Removed. Changed all uses to SCM_CONSP
or SCM_NCONSP, respectively.
* struct.c, struct.h, srcprop.c, procs.c, procprop.c, print.c,
objects.c. modules.c, goops.c, eval.c, debug.c: Changed all uses
of scm_tc3_cond_gloc and scm_tcs_cons_gloc. See above.
* print.c (scm_iprin1): Remove printing of glocs. Do not try to
tell glocs from structs.
* gc.c (scm_gc_mark, scm_gc_sweep): Remove handling of glocs.
* eval.c (scm_m_atbind): Make a list of variables, not glocs.
(scm_ceval, scm_deval): For SCM_IM_BIND, fiddle with variables
instead of with glocs.
(EVALCAR): Do not test for glocs.
(scm_lookupcar, scm_lookupcar1): Do not handle glocs in race
condition.
(scm_unmemocar): Do not handle glocs.
(scm_m_atfop): Memoize as a variable, not as a gloc.
(scm_eval_args, scm_deval_args): Do not handle glocs.
(scm_ceval, scm_deval): Likewise.
* eval.h (SCM_XEVALCAR): Do not test for glocs.
(SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL, SCM_GLOC_VAL_LOC):
Removed.
* debug.h, debug.c (scm_make_gloc, scm_gloc_p): Removed.
* dynwind.c (scm_swap_bindings): Likewise.
(scm_dowinds): Updated to recognize lists of variables instead of
lists of glocs.
* __scm.h (SCM_CAUTIOS, SCM_RECKLESS): Update comments.
CVSWeb URLs:
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/tags.h.diff?cvsroot=OldCVS&tr1=1.85&tr2=1.86&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/struct.h.diff?cvsroot=OldCVS&tr1=1.40&tr2=1.41&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/struct.c.diff?cvsroot=OldCVS&tr1=1.82&tr2=1.83&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/srcprop.c.diff?cvsroot=OldCVS&tr1=1.51&tr2=1.52&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/procs.c.diff?cvsroot=OldCVS&tr1=1.61&tr2=1.62&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/procprop.c.diff?cvsroot=OldCVS&tr1=1.38&tr2=1.39&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/print.c.diff?cvsroot=OldCVS&tr1=1.131&tr2=1.132&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/objects.c.diff?cvsroot=OldCVS&tr1=1.64&tr2=1.65&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/modules.c.diff?cvsroot=OldCVS&tr1=1.32&tr2=1.33&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/goops.c.diff?cvsroot=OldCVS&tr1=1.40&tr2=1.41&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/gc.c.diff?cvsroot=OldCVS&tr1=1.210&tr2=1.211&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/eval.h.diff?cvsroot=OldCVS&tr1=1.60&tr2=1.61&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/eval.c.diff?cvsroot=OldCVS&tr1=1.237&tr2=1.238&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/dynwind.c.diff?cvsroot=OldCVS&tr1=1.42&tr2=1.43&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/debug.h.diff?cvsroot=OldCVS&tr1=1.42&tr2=1.43&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/debug.c.diff?cvsroot=OldCVS&tr1=1.93&tr2=1.94&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/__scm.h.diff?cvsroot=OldCVS&tr1=1.74&tr2=1.75&r1=text&r2=text
Patches:
Index: guile/guile-core/libguile/__scm.h
diff -u guile/guile-core/libguile/__scm.h:1.74
guile/guile-core/libguile/__scm.h:1.75
--- guile/guile-core/libguile/__scm.h:1.74 Thu Jun 14 10:37:38 2001
+++ guile/guile-core/libguile/__scm.h Thu Jul 26 14:40:18 2001
@@ -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
Index: guile/guile-core/libguile/debug.c
diff -u guile/guile-core/libguile/debug.c:1.93
guile/guile-core/libguile/debug.c:1.94
--- guile/guile-core/libguile/debug.c:1.93 Mon Jul 9 00:36:47 2001
+++ guile/guile-core/libguile/debug.c Thu Jul 26 14:40:18 2001
@@ -196,17 +196,6 @@
* 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 @@
#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 @@
#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);
Index: guile/guile-core/libguile/debug.h
diff -u guile/guile-core/libguile/debug.h:1.42
guile/guile-core/libguile/debug.h:1.43
--- guile/guile-core/libguile/debug.h:1.42 Mon Jul 9 00:36:47 2001
+++ guile/guile-core/libguile/debug.h Thu Jul 26 14:40:18 2001
@@ -209,8 +209,6 @@
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);
Index: guile/guile-core/libguile/dynwind.c
diff -u guile/guile-core/libguile/dynwind.c:1.42
guile/guile-core/libguile/dynwind.c:1.43
--- guile/guile-core/libguile/dynwind.c:1.42 Mon Jul 9 00:36:47 2001
+++ guile/guile-core/libguile/dynwind.c Thu Jul 26 14:40:18 2001
@@ -185,15 +185,15 @@
#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 @@
#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 @@
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)
Index: guile/guile-core/libguile/eval.c
diff -u guile/guile-core/libguile/eval.c:1.237
guile/guile-core/libguile/eval.c:1.238
--- guile/guile-core/libguile/eval.c:1.237 Wed Jul 25 15:01:27 2001
+++ guile/guile-core/libguile/eval.c Thu Jul 26 14:40:18 2001
@@ -156,10 +156,8 @@
: 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 @@
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 @@
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 @@
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 (address@hidden (x 12) x). Now, when the first
- thread completes its lookup, it would replace the address@hidden 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 (address@hidden (x 12) x). Now, when
+ the first thread completes its lookup, it would replace the address@hidden
+ 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 @@
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 address@hidden') we
return NULL and expect the calling function to do the right
thing. For the evaluator, this means going back and redoing
@@ -415,17 +411,9 @@
if (SCM_IMP (form))
return form;
c = SCM_CAR (form);
- if (SCM_ITAG3 (c) == scm_tc3_cons_gloc)
+ if (SCM_VARIABLEP (c))
{
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))
- {
- SCM sym =
scm_module_reverse_lookup (scm_env_module (env), c);
if (SCM_EQ_P (sym, SCM_BOOL_F))
sym = sym_three_question_marks;
@@ -839,7 +827,7 @@
--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 @@
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 @@
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 @@
#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 @@
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_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_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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
#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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
}
}
#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 @@
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 @@
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
Index: guile/guile-core/libguile/eval.h
diff -u guile/guile-core/libguile/eval.h:1.60
guile/guile-core/libguile/eval.h:1.61
--- guile/guile-core/libguile/eval.h:1.60 Tue Jun 26 14:55:45 2001
+++ guile/guile-core/libguile/eval.h Thu Jul 26 14:40:17 2001
@@ -115,9 +115,7 @@
? 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)))
@@ -181,16 +179,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)))
Index: guile/guile-core/libguile/gc.c
diff -u guile/guile-core/libguile/gc.c:1.210
guile/guile-core/libguile/gc.c:1.211
--- guile/guile-core/libguile/gc.c:1.210 Wed Jul 25 08:22:53 2001
+++ guile/guile-core/libguile/gc.c Thu Jul 26 14:40:17 2001
@@ -1257,63 +1257,40 @@
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)
+ {
+ RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure]));
+ RECURSE (SCM_PACK (struct_data[scm_struct_i_setter]));
+ }
+ if (len)
{
- /* 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;
+ 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 @@
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:
Index: guile/guile-core/libguile/goops.c
diff -u guile/guile-core/libguile/goops.c:1.40
guile/guile-core/libguile/goops.c:1.41
--- guile/guile-core/libguile/goops.c:1.40 Wed Jul 18 03:14:29 2001
+++ guile/guile-core/libguile/goops.c Thu Jul 26 14:40:17 2001
@@ -1313,7 +1313,7 @@
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_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;
}
Index: guile/guile-core/libguile/modules.c
diff -u guile/guile-core/libguile/modules.c:1.32
guile/guile-core/libguile/modules.c:1.33
--- guile/guile-core/libguile/modules.c:1.32 Mon Jul 9 00:36:47 2001
+++ guile/guile-core/libguile/modules.c Thu Jul 26 14:40:17 2001
@@ -627,7 +627,7 @@
#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"));
Index: guile/guile-core/libguile/objects.c
diff -u guile/guile-core/libguile/objects.c:1.64
guile/guile-core/libguile/objects.c:1.65
--- guile/guile-core/libguile/objects.c:1.64 Mon Jul 9 00:36:47 2001
+++ guile/guile-core/libguile/objects.c Thu Jul 26 14:40:17 2001
@@ -168,8 +168,7 @@
? 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 @@
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:
Index: guile/guile-core/libguile/print.c
diff -u guile/guile-core/libguile/print.c:1.131
guile/guile-core/libguile/print.c:1.132
--- guile/guile-core/libguile/print.c:1.131 Wed Jul 25 08:22:53 2001
+++ guile/guile-core/libguile/print.c Thu Jul 26 14:40:17 2001
@@ -397,7 +397,6 @@
void
scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
-taloop:
switch (SCM_ITAG3 (exp))
{
case scm_tc3_closure:
@@ -451,39 +450,30 @@
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 @@
}
-/* 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 @@
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 @@
/* 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 @@
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;
Index: guile/guile-core/libguile/procprop.c
diff -u guile/guile-core/libguile/procprop.c:1.38
guile/guile-core/libguile/procprop.c:1.39
--- guile/guile-core/libguile/procprop.c:1.38 Mon Jul 9 00:36:47 2001
+++ guile/guile-core/libguile/procprop.c Thu Jul 26 14:40:17 2001
@@ -137,7 +137,7 @@
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;
Index: guile/guile-core/libguile/procs.c
diff -u guile/guile-core/libguile/procs.c:1.61
guile/guile-core/libguile/procs.c:1.62
--- guile/guile-core/libguile/procs.c:1.61 Mon Jul 9 00:36:47 2001
+++ guile/guile-core/libguile/procs.c Thu Jul 26 14:40:17 2001
@@ -198,7 +198,7 @@
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:
Index: guile/guile-core/libguile/srcprop.c
diff -u guile/guile-core/libguile/srcprop.c:1.51
guile/guile-core/libguile/srcprop.c:1.52
--- guile/guile-core/libguile/srcprop.c:1.51 Mon Jul 9 00:36:47 2001
+++ guile/guile-core/libguile/srcprop.c Thu Jul 26 14:40:17 2001
@@ -218,7 +218,7 @@
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);
Index: guile/guile-core/libguile/struct.c
diff -u guile/guile-core/libguile/struct.c:1.82
guile/guile-core/libguile/struct.c:1.83
--- guile/guile-core/libguile/struct.c:1.82 Mon Jul 9 00:36:47 2001
+++ guile/guile-core/libguile/struct.c Thu Jul 26 14:40:17 2001
@@ -402,8 +402,8 @@
}
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_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_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;
}
Index: guile/guile-core/libguile/struct.h
diff -u guile/guile-core/libguile/struct.h:1.40
guile/guile-core/libguile/struct.h:1.41
--- guile/guile-core/libguile/struct.h:1.40 Mon Jul 9 00:36:47 2001
+++ guile/guile-core/libguile/struct.h Thu Jul 26 14:40:17 2001
@@ -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 @@
#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))
Index: guile/guile-core/libguile/tags.h
diff -u guile/guile-core/libguile/tags.h:1.85
guile/guile-core/libguile/tags.h:1.86
--- guile/guile-core/libguile/tags.h:1.85 Wed Jul 25 08:22:53 2001
+++ guile/guile-core/libguile/tags.h Thu Jul 26 14:40:17 2001
@@ -117,20 +117,24 @@
* 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 @@
*
*
* 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 @@
* 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 @@
#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 @@
/* 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 @@
-/* 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 @@
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
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- guile/guile-core/libguile tags.h struct.h struc...,
Marius Vollmer <=