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

* procprop.h: Added declaration of scm_i_inner_name.

Browse source 
* 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.
This commit is contained in:
Mikael Djurfeldt 1997-09-11 00:09:57 +00:00
parent 2c63000098
commit 80ea260cdf
7 changed files with 64 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

21
libguile/ChangeLog
View file

@ -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

4
libguile/debug.c
View file

@ -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:

37
libguile/eval.c
View file

@ -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;
}

3
libguile/gsubr.c
View file

@ -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

6
libguile/print.c
View file

@ -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-",

1
libguile/procprop.h
View file

@ -49,6 +49,7 @@
extern SCM scm_i_name;
extern SCM scm_i_inner_name;

9
libguile/procs.c
View file

@ -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);