diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 1997-09-11 00:09:57 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 1997-09-11 00:09:57 +0000 |
commit | 80ea260cdf5ff69b5c9c3a681204bbef63963d54 (patch) | |
tree | c197776b7ee1b21800f51ed858482c72092d583b | |
parent | 2c6300009875da1b834a0007715a08c47f8bf45d (diff) | |
download | guile-80ea260cdf5ff69b5c9c3a681204bbef63963d54.tar.gz |
* procprop.h: Added declaration of scm_i_inner_name.
* gsubr.c: New global symbol scm_i_inner_name.
* debug.c (scm_procedure_name): Try procedure property
`inner-name' if `name' fails.
* print.c (scm_iprin1): Use scm_macro_name.
* eval.c (scm_m_define): Give names to macros as well; Only the
first top-level definition gives a procedure/macro a name.
Otherwise confusing names can turn up in backtraces.
(SCM_CEVAL): SCM_IM_DEFINE: Set `inner-name' property instead of
`name'; Give names to macros as well.
* procs.c (scm_closure_p), print.c (scm_iprin1), eval.c
(scm_macro_transformer): Use SCM_CLOSUREP instead of
scm_closure_p.
-rw-r--r-- | libguile/ChangeLog | 21 | ||||
-rw-r--r-- | libguile/debug.c | 4 | ||||
-rw-r--r-- | libguile/eval.c | 37 | ||||
-rw-r--r-- | libguile/gsubr.c | 3 | ||||
-rw-r--r-- | libguile/print.c | 6 | ||||
-rw-r--r-- | libguile/procprop.h | 1 | ||||
-rw-r--r-- | libguile/procs.c | 9 |
7 files changed, 64 insertions, 17 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d25423e91..71ae4c884 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,24 @@ +Thu Sep 11 00:59:17 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se> + + * procprop.h: Added declaration of scm_i_inner_name. + + * gsubr.c: New global symbol scm_i_inner_name. + + * debug.c (scm_procedure_name): Try procedure property + `inner-name' if `name' fails. + + * print.c (scm_iprin1): Use scm_macro_name. + + * eval.c (scm_m_define): Give names to macros as well; Only the + first top-level definition gives a procedure/macro a name. + Otherwise confusing names can turn up in backtraces. + (SCM_CEVAL): SCM_IM_DEFINE: Set `inner-name' property instead of + `name'; Give names to macros as well. + + * procs.c (scm_closure_p), print.c (scm_iprin1), eval.c + (scm_macro_transformer): Use SCM_CLOSUREP instead of + scm_closure_p. + Wed Sep 10 20:52:18 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se> * * eval.c (macro?, macro-type, macro-name, macro-transfomer): New diff --git a/libguile/debug.c b/libguile/debug.c index 9ffe23d82..7014e6ef0 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -214,11 +214,13 @@ scm_procedure_name (proc) { SCM name = scm_procedure_property (proc, scm_i_name); #if 0 - /* Procedure property scm_i_procname not implemented yet... */ + /* Source property scm_i_procname not implemented yet... */ SCM name = scm_source_property (SCM_CAR (SCM_CDR (SCM_CODE (proc))), scm_i_procname); if (SCM_FALSEP (name)) name = scm_procedure_property (proc, scm_i_name); #endif + if (SCM_FALSEP (name)) + name = scm_procedure_property (proc, scm_i_inner_name); return name; } case scm_tcs_subrs: diff --git a/libguile/eval.c b/libguile/eval.c index 43dfa8644..c3d567a35 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -879,8 +879,21 @@ scm_m_define (x, env) { x = evalcar (x, env); #ifdef DEBUG_EXTENSIONS - if (SCM_REC_PROCNAMES_P && SCM_NIMP (x) && SCM_CLOSUREP (x)) - scm_set_procedure_property_x (x, scm_i_name, proc); + if (SCM_REC_PROCNAMES_P && SCM_NIMP (x)) + { + arg1 = x; + proc: + if (SCM_CLOSUREP (arg1) + /* Only the first definition determines the name. */ + && scm_procedure_property (arg1, scm_i_name) == SCM_BOOL_F) + scm_set_procedure_property_x (arg1, scm_i_name, proc); + else if (SCM_TYP16 (arg1) == scm_tc16_macro + && SCM_CDR (arg1) != arg1) + { + arg1 = SCM_CDR (arg1); + goto proc; + } + } #endif arg1 = scm_sym2vcell (proc, env_top_level (env), SCM_BOOL_T); #if 0 @@ -1818,8 +1831,22 @@ dispatch: x = SCM_CDR (x); x = evalcar (x, env); #ifdef DEBUG_EXTENSIONS - if (SCM_REC_PROCNAMES_P && SCM_NIMP (x) && SCM_CLOSUREP (x)) - scm_set_procedure_property_x (x, scm_i_name, proc); + if (SCM_REC_PROCNAMES_P && SCM_NIMP (x)) + { + t.arg1 = x; + proc: + if (SCM_CLOSUREP (t.arg1) + /* Only the first definition determines the name. */ + && (scm_procedure_property (t.arg1, scm_i_inner_name) + == SCM_BOOL_F)) + scm_set_procedure_property_x (t.arg1, scm_i_inner_name, proc); + else if (SCM_TYP16 (t.arg1) == scm_tc16_macro + && SCM_CDR (t.arg1) != t.arg1) + { + t.arg1 = SCM_CDR (t.arg1); + goto proc; + } + } #endif env = SCM_CAR (env); SCM_DEFER_INTS; @@ -2983,7 +3010,7 @@ scm_macro_transformer (m) m, SCM_ARG1, s_macro_transformer); - return SCM_NFALSEP (scm_closure_p (SCM_CDR (m))) ? SCM_CDR (m) : SCM_BOOL_F; + return SCM_CLOSUREP (SCM_CDR (m)) ? SCM_CDR (m) : SCM_BOOL_F; } diff --git a/libguile/gsubr.c b/libguile/gsubr.c index c3e865dd2..c42661e15 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -67,6 +67,7 @@ #define GSUBR_PROC(cclo) (SCM_VELTS(cclo)[2]) SCM scm_i_name; +SCM scm_i_inner_name; static SCM f_gsubr_apply; SCM @@ -192,6 +193,8 @@ scm_init_gsubr() f_gsubr_apply = scm_make_subr(s_gsubr_apply, scm_tc7_lsubr, scm_gsubr_apply); scm_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED)); scm_permanent_object (scm_i_name); + scm_i_inner_name = SCM_CAR (scm_sysintern ("inner-name", SCM_UNDEFINED)); + scm_permanent_object (scm_i_inner_name); #ifdef GSUBR_TEST scm_make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */ #endif diff --git a/libguile/print.c b/libguile/print.c index 026718652..7603ad9d9 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -348,7 +348,7 @@ taloop: print_circref (port, pstate, exp); break; macros: - if (SCM_FALSEP (scm_closure_p (SCM_CDR (exp)))) + if (!SCM_CLOSUREP (SCM_CDR (exp))) goto prinmacro; case scm_tcs_closures: /* The user supplied print closure procedure must handle @@ -369,8 +369,8 @@ taloop: { /* Printing a macro. */ prinmacro: - name = scm_procedure_name (SCM_CDR (exp)); - if (SCM_FALSEP (scm_closure_p (SCM_CDR (exp)))) + name = scm_macro_name (exp); + if (!SCM_CLOSUREP (SCM_CDR (exp))) { code = 0; scm_gen_puts (scm_regular_string, "#<primitive-", diff --git a/libguile/procprop.h b/libguile/procprop.h index d4d38ac54..8464aa550 100644 --- a/libguile/procprop.h +++ b/libguile/procprop.h @@ -49,6 +49,7 @@ extern SCM scm_i_name; +extern SCM scm_i_inner_name; diff --git a/libguile/procs.c b/libguile/procs.c index a7e09fe29..bfb9288bd 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -147,14 +147,7 @@ SCM scm_closure_p (obj) SCM obj; { - if (SCM_NIMP (obj)) - switch (SCM_TYP7 (obj)) - { - case scm_tcs_closures: - return SCM_BOOL_T; - default: ; - } - return SCM_BOOL_F; + return SCM_NIMP (obj) && SCM_CLOSUREP (obj) ? SCM_BOOL_T : SCM_BOOL_F; } SCM_PROC(s_thunk_p, "thunk?", 1, 0, 0, scm_thunk_p); |