summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1997-09-11 00:09:57 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1997-09-11 00:09:57 +0000
commit80ea260cdf5ff69b5c9c3a681204bbef63963d54 (patch)
treec197776b7ee1b21800f51ed858482c72092d583b
parent2c6300009875da1b834a0007715a08c47f8bf45d (diff)
downloadguile-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/ChangeLog21
-rw-r--r--libguile/debug.c4
-rw-r--r--libguile/eval.c37
-rw-r--r--libguile/gsubr.c3
-rw-r--r--libguile/print.c6
-rw-r--r--libguile/procprop.h1
-rw-r--r--libguile/procs.c9
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);