* 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.

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

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:

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))
+      if (SCM_REC_PROCNAMES_P && SCM_NIMP (x))
-	scm_set_procedure_property_x (x, scm_i_name, proc);
+	{
+	  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))
+      if (SCM_REC_PROCNAMES_P && SCM_NIMP (x))
-	scm_set_procedure_property_x (x, scm_i_name, proc);
+	{
+	  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;
 }
 
 

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

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));
+		  name = scm_macro_name (exp);
-		  if (SCM_FALSEP (scm_closure_p (SCM_CDR (exp))))
+		  if (!SCM_CLOSUREP (SCM_CDR (exp)))
 		    {
 		      code = 0;
 		      scm_gen_puts (scm_regular_string, "#<primitive-",

libguile/procprop.h

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

libguile/procs.c

@@ -147,14 +147,7 @@ SCM
 scm_closure_p (obj)
      SCM obj;
 {
-  if (SCM_NIMP (obj))
+  return SCM_NIMP (obj) && SCM_CLOSUREP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
-    switch (SCM_TYP7 (obj))
-      {
-      case scm_tcs_closures:
-	return SCM_BOOL_T;
-      default: ;
-      }
-  return SCM_BOOL_F;
 }
 
 SCM_PROC(s_thunk_p, "thunk?", 1, 0, 0, scm_thunk_p);