* * eval.c (macro?, macro-type, macro-name, macro-transfomer): New

procedures;
	(prinmacro): Removed.  The code has been moved/merged into print.c
	in order to decrease code redundancy.  We want macros to print in
	a way equivalent to procedures, and it would be silly to duplicate
	the required code.  (We don't want to maintain two places.)
	(macrosmob): Print field is now a NULL pointer.

	* eval.h (scm_macro_p, scm_macro_type, scm_macro_name,
	scm_macro_transformer): New prototypes.
	(scm_tc16_macro): Declared.

*	* print.c (scm_iprin1): Added code for printing of macros.  Macros
	are now printed in a way equivalent to procedures.

libguile/ChangeLog

@@ -1,3 +1,29 @@
+Wed Sep 10 20:52:18 1997  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>
+
+*	* eval.c (macro?, macro-type, macro-name, macro-transfomer): New
+ 	procedures;
+	(prinmacro): Removed.  The code has been moved/merged into print.c
+ 	in order to decrease code redundancy.  We want macros to print in
+ 	a way equivalent to procedures, and it would be silly to duplicate
+ 	the required code.  (We don't want to maintain two places.)
+	(macrosmob): Print field is now a NULL pointer.
+	
+	* eval.h (scm_macro_p, scm_macro_type, scm_macro_name,
+ 	scm_macro_transformer): New prototypes.
+	(scm_tc16_macro): Declared.
+
+*	* print.c (scm_iprin1): Added code for printing of macros.  Macros
+	are now printed in a way equivalent to procedures.
+
+Sat Sep  6 12:20:42 1997  Mikael Djurfeldt  <mdj@kenneth>
+
+	* procs.h (scm_closure_p): Added declaration.
+
+Fri Sep  5 13:36:14 1997  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>
+
+	* gc.c (scm_gc_mark): Fixed "rogue pointer in heap" message:
+	Shouldn't pass "heap" as the subr name.
+
 Tue Sep  2 18:14:30 1997  Jim Blandy  <jimb@totoro.red-bean.com>
 
 	* gh_predicates.c (gh_boolean_p, gh_symbol_p, gh_char_p,

libguile/eval.c

@@ -2925,30 +2925,69 @@ scm_makmmacro (code)
 }
 
 
+SCM_PROC (s_macro_p, "macro?", 1, 0, 0, scm_macro_p);
 
-static int  prinmacro SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+SCM
-
+scm_macro_p (obj)
-static int 
+     SCM obj;
-prinmacro (exp, port, pstate)
-     SCM exp;
-     SCM port;
-     scm_print_state *pstate;
 {
-  int writingp = SCM_WRITINGP (pstate);
+  return (SCM_NIMP (obj) && SCM_TYP16 (obj) == scm_tc16_macro
-  if (SCM_CAR (exp) & (3L << 16))
+	  ? SCM_BOOL_T
-    scm_gen_puts (scm_regular_string, "#<macro", port);
+	  : SCM_BOOL_F);
-  else
-    scm_gen_puts (scm_regular_string, "#<syntax", port);
-  if (SCM_CAR (exp) & (2L << 16))
-    scm_gen_putc ('!', port);
-  scm_gen_putc (' ', port);
-  SCM_SET_WRITINGP (pstate, 1);
-  scm_iprin1 (SCM_CDR (exp), port, pstate);
-  SCM_SET_WRITINGP (pstate, writingp);
-  scm_gen_putc ('>', port);
-  return !0;
 }
 
+
+SCM_SYMBOL (scm_sym_syntax, "syntax");
+SCM_SYMBOL (scm_sym_macro, "macro");
+SCM_SYMBOL (scm_sym_mmacro, "macro!");
+
+SCM_PROC (s_macro_type, "macro-type", 1, 0, 0, scm_macro_type);
+
+SCM
+scm_macro_type (m)
+     SCM m;
+{
+  if (!(SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro))
+    return SCM_BOOL_F;
+  switch ((int) (SCM_CAR (m) >> 16))
+    {
+    case 0: return scm_sym_syntax;
+    case 1: return scm_sym_macro;
+    case 2: return scm_sym_mmacro;
+    default: scm_wrong_type_arg (s_macro_type, 1, m);
+    }
+}
+
+
+SCM_PROC (s_macro_name, "macro-name", 1, 0, 0, scm_macro_name);
+
+SCM
+scm_macro_name (m)
+     SCM m;
+{
+  SCM_ASSERT (SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro,
+	      m,
+	      SCM_ARG1,
+	      s_macro_name);
+  return scm_procedure_name (SCM_CDR (m));
+}
+
+
+SCM_PROC (s_macro_transformer, "macro-transformer", 1, 0, 0, scm_macro_transformer);
+
+SCM
+scm_macro_transformer (m)
+     SCM m;
+{
+  SCM_ASSERT (SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro,
+	      m,
+	      SCM_ARG1,
+	      s_macro_transformer);
+  return SCM_NFALSEP (scm_closure_p (SCM_CDR (m))) ? SCM_CDR (m) : SCM_BOOL_F;
+}
+
+
+
 SCM_PROC(s_force, "force", 1, 0, 0, scm_force);
 
 SCM 
@@ -3100,12 +3139,9 @@ scm_definedp (sym)
       SCM_BOOL_F : SCM_BOOL_T;
 }
 
-static scm_smobfuns promsmob =
+static scm_smobfuns promsmob = {scm_markcdr, scm_free0, prinprom};
-{scm_markcdr, scm_free0, prinprom};
-
-static scm_smobfuns macrosmob =
-{scm_markcdr, scm_free0, prinmacro};
 
+static scm_smobfuns macrosmob = {scm_markcdr, scm_free0};
 
 SCM 
 scm_make_synt (name, macroizer, fcn)

libguile/eval.h

@@ -97,6 +97,7 @@ extern SCM scm_i_unquote;
 extern SCM scm_i_uq_splicing;
 extern SCM scm_i_apply;
 
+extern long scm_tc16_macro;
 
 /* A resolved global variable reference in the CAR position
  * of a list is stored (in code only) as a pointer to a pair with a 
@@ -152,6 +153,10 @@ extern SCM scm_makprom SCM_P ((SCM code));
 extern SCM scm_makacro SCM_P ((SCM code));
 extern SCM scm_makmacro SCM_P ((SCM code));
 extern SCM scm_makmmacro SCM_P ((SCM code));
+extern SCM scm_macro_p SCM_P ((SCM obj));
+extern SCM scm_macro_type SCM_P ((SCM m));
+extern SCM scm_macro_name SCM_P ((SCM m));
+extern SCM scm_macro_transformer SCM_P ((SCM m));
 extern SCM scm_force SCM_P ((SCM x));
 extern SCM scm_promise_p SCM_P ((SCM x));
 extern SCM scm_copy_tree SCM_P ((SCM obj));

libguile/print.c

@@ -347,7 +347,12 @@ taloop:
 	circref:
 	  print_circref (port, pstate, exp);
 	  break;
+	macros:
+	  if (SCM_FALSEP (scm_closure_p (SCM_CDR (exp))))
+	    goto prinmacro;
 	case scm_tcs_closures:
+	  /* The user supplied print closure procedure must handle
+	     macro closures as well. */
 	  if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)))
 	    {
 	      SCM ans = scm_cons2 (exp, port,
@@ -360,16 +365,48 @@ taloop:
 	  else
 	    {
 	      SCM name, code;
-	      name = scm_procedure_property (exp, scm_i_name);
+	      if (SCM_TYP16 (exp) == scm_tc16_macro)
-	      code = SCM_CODE (exp);
+		{
-	      scm_gen_puts (scm_regular_string, "#<procedure ", port);
+		  /* Printing a macro. */
+		prinmacro:
+		  name = scm_procedure_name (SCM_CDR (exp));
+		  if (SCM_FALSEP (scm_closure_p (SCM_CDR (exp))))
+		    {
+		      code = 0;
+		      scm_gen_puts (scm_regular_string, "#<primitive-",
+				    port);
+		    }
+		  else
+		    {
+		      code = SCM_CODE (SCM_CDR (exp));
+		      scm_gen_puts (scm_regular_string, "#<", port);
+		    }
+		  if (SCM_CAR (exp) & (3L << 16))
+		    scm_gen_puts (scm_regular_string, "macro", port);
+		  else
+		    scm_gen_puts (scm_regular_string, "syntax", port);
+		  if (SCM_CAR (exp) & (2L << 16))
+		    scm_gen_putc ('!', port);
+		}
+	      else
+		{
+		  /* Printing a closure. */
+		  name = scm_procedure_name (exp);
+		  code = SCM_CODE (exp);
+		  scm_gen_puts (scm_regular_string, "#<procedure",
+				port);
+		}
 	      if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 		{
-		  scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port);
 		  scm_gen_putc (' ', port);
+		  scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port);
 		}
-	      scm_iprin1 (SCM_CAR (code), port, pstate);
+	      if (code)
-	      if (SCM_PRINT_SOURCE_P)
+		{
+		  scm_gen_putc (' ', port);
+		  scm_iprin1 (SCM_CAR (code), port, pstate);
+		}
+	      if (code && SCM_PRINT_SOURCE_P)
 		{
 		  code = scm_unmemocopy (SCM_CDR (code),
 					 SCM_EXTEND_ENV (SCM_CAR (code),
@@ -583,6 +620,12 @@ taloop:
 	      break;
 	    }
 	  EXIT_NESTED_DATA (pstate);
+	  /* Macros have their print field set to NULL.  They are
+	     handled at the same place as closures in order to achieve
+	     non-redundancy.  Placing the condition here won't slow
+	     down printing of other smobs. */
+	  if (SCM_TYP16 (exp) == scm_tc16_macro)
+	    goto macros;
 	default:
 	punk:
 	  scm_ipruk ("type", exp, port);