mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 16:50:21 +02:00
Code Activity

* procs.h (SCM_CLOSURE_BODY): New Macro.

Browse source 
* debug.c (scm_procedure_name, scm_procedure_source), eval.c
(SCM_CEVAL, SCM_APPLY), goops.c (scm_sys_initialize_object,
get_slot_value, set_slot_value), procs.c
(scm_procedure_documentation), sort.c (closureless), stacks.c
(get_applybody): Replace SCM_CDR (SCM_CODE (...)) by
SCM_CLOSURE_BODY.

* sort.c (closureless): Prefer !SCM_FOOP over SCM_NFOOP.
This commit is contained in:
Dirk Herrmann 2002-01-10 20:52:45 +00:00
parent 5b156bcd25
commit f9450cdb14
8 changed files with 35 additions and 22 deletions
Download patch file Download diff file Expand all files Collapse all files

13
libguile/ChangeLog
View file

@ -1,3 +1,16 @@
2002-01-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
* procs.h (SCM_CLOSURE_BODY): New Macro.
* debug.c (scm_procedure_name, scm_procedure_source), eval.c
(SCM_CEVAL, SCM_APPLY), goops.c (scm_sys_initialize_object,
get_slot_value, set_slot_value), procs.c
(scm_procedure_documentation), sort.c (closureless), stacks.c
(get_applybody): Replace SCM_CDR (SCM_CODE (...)) by
SCM_CLOSURE_BODY.
* sort.c (closureless): Prefer !SCM_FOOP over SCM_NFOOP.
2001-12-26 Marius Vollmer <mvo@zagadka.ping.de> 2001-12-26 Marius Vollmer <mvo@zagadka.ping.de>
* Makefile.am (guile-procedures.txt): When we don't have makeinfo, * Makefile.am (guile-procedures.txt): When we don't have makeinfo,

4
libguile/debug.c
View file

@ -362,7 +362,7 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
SCM name = scm_procedure_property (proc, scm_sym_name); SCM name = scm_procedure_property (proc, scm_sym_name);
#if 0 #if 0
/* Source property scm_sym_procname not implemented yet... */ /* Source property scm_sym_procname not implemented yet... */
SCM name = scm_source_property (SCM_CADR (SCM_CODE (proc)), scm_sym_procname); SCM name = scm_source_property (SCM_CAR (SCM_CLOSURE_BODY (proc)), scm_sym_procname);
if (SCM_FALSEP (name)) if (SCM_FALSEP (name))
name = scm_procedure_property (proc, scm_sym_name); name = scm_procedure_property (proc, scm_sym_name);
#endif #endif
@ -384,7 +384,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
case scm_tcs_closures: case scm_tcs_closures:
{ {
SCM formals = SCM_CLOSURE_FORMALS (proc); SCM formals = SCM_CLOSURE_FORMALS (proc);
SCM src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_sym_copy); SCM src = scm_source_property (SCM_CLOSURE_BODY (proc), scm_sym_copy);
if (!SCM_FALSEP (src)) if (!SCM_FALSEP (src))
return scm_cons2 (scm_sym_lambda, formals, src); return scm_cons2 (scm_sym_lambda, formals, src);
return scm_cons (scm_sym_lambda, return scm_cons (scm_sym_lambda,

26
libguile/eval.c
View file

@ -2320,8 +2320,8 @@ dispatch:
} }
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), argl, SCM_ENV (proc)); env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), argl, SCM_ENV (proc));
x = SCM_CODE (proc); x = SCM_CLOSURE_BODY (proc);
goto nontoplevel_cdrxbegin; goto nontoplevel_begin;
} }
proc = scm_f_apply; proc = scm_f_apply;
goto evapply; goto evapply;
@ -2754,9 +2754,9 @@ evapply:
if (scm_badformalsp (proc, 0)) if (scm_badformalsp (proc, 0))
goto umwrongnumargs; goto umwrongnumargs;
case scm_tcs_closures: case scm_tcs_closures:
x = SCM_CODE (proc); x = SCM_CLOSURE_BODY (proc);
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc)); env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc));
goto nontoplevel_cdrxbegin; goto nontoplevel_begin;
case scm_tcs_struct: case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{ {
@ -2895,13 +2895,13 @@ evapply:
goto umwrongnumargs; goto umwrongnumargs;
case scm_tcs_closures: case scm_tcs_closures:
/* clos1: */ /* clos1: */
x = SCM_CODE (proc); x = SCM_CLOSURE_BODY (proc);
#ifdef DEVAL #ifdef DEVAL
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc)); env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc));
#else #else
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (t.arg1), SCM_ENV (proc)); env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (t.arg1), SCM_ENV (proc));
#endif #endif
goto nontoplevel_cdrxbegin; goto nontoplevel_begin;
case scm_tcs_struct: case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{ {
@ -3059,8 +3059,8 @@ evapply:
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
scm_list_2 (t.arg1, arg2), SCM_ENV (proc)); scm_list_2 (t.arg1, arg2), SCM_ENV (proc));
#endif #endif
x = SCM_CODE (proc); x = SCM_CLOSURE_BODY (proc);
goto nontoplevel_cdrxbegin; goto nontoplevel_begin;
} }
} }
#ifdef SCM_CAUTIOUS #ifdef SCM_CAUTIOUS
@ -3137,8 +3137,8 @@ evapply:
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
debug.info->a.args, debug.info->a.args,
SCM_ENV (proc)); SCM_ENV (proc));
x = SCM_CODE (proc); x = SCM_CLOSURE_BODY (proc);
goto nontoplevel_cdrxbegin; goto nontoplevel_begin;
#else /* DEVAL */ #else /* DEVAL */
case scm_tc7_subr_3: case scm_tc7_subr_3:
SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
@ -3209,8 +3209,8 @@ evapply:
arg2, arg2,
scm_eval_args (x, env, proc)), scm_eval_args (x, env, proc)),
SCM_ENV (proc)); SCM_ENV (proc));
x = SCM_CODE (proc); x = SCM_CLOSURE_BODY (proc);
goto nontoplevel_cdrxbegin; goto nontoplevel_begin;
#endif /* DEVAL */ #endif /* DEVAL */
case scm_tcs_struct: case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
@ -3603,7 +3603,7 @@ tail:
} }
args = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), args, SCM_ENV (proc)); args = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), args, SCM_ENV (proc));
proc = SCM_CDR (SCM_CODE (proc)); proc = SCM_CLOSURE_BODY (proc);
again: again:
arg1 = proc; arg1 = proc;
while (!SCM_NULLP (arg1 = SCM_CDR (arg1))) while (!SCM_NULLP (arg1 = SCM_CDR (arg1)))

7
libguile/goops.c
View file

@ -461,8 +461,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
set_slot_value (class, set_slot_value (class,
obj, obj,
SCM_CAR (get_n_set), SCM_CAR (get_n_set),
scm_eval_body (SCM_CDR (SCM_CODE (tmp)), scm_eval_body (SCM_CLOSURE_BODY (tmp), env));
env));
} }
} }
} }
@ -1089,7 +1088,7 @@ get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
scm_list_1 (obj), scm_list_1 (obj),
SCM_ENV (code)); SCM_ENV (code));
/* Evaluate the closure body */ /* Evaluate the closure body */
return scm_eval_body (SCM_CDR (SCM_CODE (code)), env); return scm_eval_body (SCM_CLOSURE_BODY (code), env);
} }
} }
@ -1128,7 +1127,7 @@ set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
scm_list_2 (obj, value), scm_list_2 (obj, value),
SCM_ENV (code)); SCM_ENV (code));
/* Evaluate the closure body */ /* Evaluate the closure body */
scm_eval_body (SCM_CDR (SCM_CODE (code)), env); scm_eval_body (SCM_CLOSURE_BODY (code), env);
} }
} }
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;

2
libguile/procs.c
View file

@ -279,7 +279,7 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
switch (SCM_TYP7 (proc)) switch (SCM_TYP7 (proc))
{ {
case scm_tcs_closures: case scm_tcs_closures:
code = SCM_CDR (SCM_CODE (proc)); code = SCM_CLOSURE_BODY (proc);
if (SCM_IMP (SCM_CDR (code))) if (SCM_IMP (SCM_CDR (code)))
return SCM_BOOL_F; return SCM_BOOL_F;
code = SCM_CAR (code); code = SCM_CAR (code);

1
libguile/procs.h
View file

@ -94,6 +94,7 @@ typedef struct
#define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure) #define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure)
#define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x)) #define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x))
#define SCM_CLOSURE_FORMALS(x) SCM_CAR (SCM_CODE (x)) #define SCM_CLOSURE_FORMALS(x) SCM_CAR (SCM_CODE (x))
#define SCM_CLOSURE_BODY(x) SCM_CDR (SCM_CODE (x))
#define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x)) #define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x))
#define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p) #define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p)
#define SCM_SETCODE(x, e) (SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_cons ((e), SCM_EOL)) \ #define SCM_SETCODE(x, e) (SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_cons ((e), SCM_EOL)) \

2
libguile/sort.c
View file

@ -378,7 +378,7 @@ closureless (SCM code, const void *a, const void *b)
scm_cons (*(SCM *) b, SCM_EOL)), scm_cons (*(SCM *) b, SCM_EOL)),
SCM_ENV (code)); SCM_ENV (code));
/* Evaluate the closure body */ /* Evaluate the closure body */
return SCM_NFALSEP (scm_eval_body (SCM_CDR (SCM_CODE (code)), env)); return !SCM_FALSEP (scm_eval_body (SCM_CLOSURE_BODY (code), env));
} /* closureless */ } /* closureless */
static int static int

2
libguile/stacks.c
View file

@ -221,7 +221,7 @@ get_applybody ()
{ {
SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F); SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F);
if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var))) if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var)))
return SCM_CADR (SCM_CODE (SCM_VARIABLE_REF (var))); return SCM_CAR (SCM_CLOSURE_BODY (SCM_VARIABLE_REF (var)));
else else
return SCM_UNDEFINED; return SCM_UNDEFINED;
} }