* Fixed scm_thunk_p's results when applied to closures.

* Extracted macro printing code from print.c to macros.c.
* Minor cleanups.

libguile/ChangeLog

@@ -1,3 +1,31 @@
+2001-04-19  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* procs.h (SCM_CLOSURE_FORMALS):  New macro.
+
+	* debug.c (scm_procedure_source), eval.c (scm_badformalsp,
+	SCM_CEVAL, SCM_APPLY), goops.c (get_slot_value, set_slot_value),
+	procprop.c (scm_i_procedure_arity), sort.c (closureless):  Use 
+	SCM_CLOSURE_FORMALS.
+
+	* eval.c (scm_badformalsp, SCM_CEVAL), procprop.c
+	(scm_i_procedure_arity):  Prefer stronger predicates like
+	SCM_NULLP or SCM_FALSEP over SCM_IMP.
+
+	* macros.c (macro_print):  Extracted macro printing code from
+	print.c and simplified it.
+
+	(scm_macro_type):  Use SCM_MACRO_TYPE;
+
+	(scm_init_macros):  Use macro_print for printing macros.
+
+	* print.c (scm_print_opts):  Improved option documentation.
+
+	(scm_iprin1):  Extracted printing of macros to macros.c.
+	Simplified printing of ordinary closures.
+
+	* procs.c (scm_thunk_p):  Fixed handling of closures.  Thanks to
+	Martin Grabmueller for the bug report.
+
 2001-04-19  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
 	This patch eliminates some further applications of SCM_C[AD]R to

libguile/debug.c

@@ -429,7 +429,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
       SCM src;
       src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_sym_copy);
       if (! SCM_FALSEP (src))
-	return scm_cons2 (scm_sym_lambda, SCM_CAR (SCM_CODE (proc)), src);
+	return scm_cons2 (scm_sym_lambda, SCM_CLOSURE_FORMALS (proc), src);
       src = SCM_CODE (proc);
       return scm_cons (scm_sym_lambda,
 		       scm_unmemocopy (src,

libguile/eval.c

@@ -1489,10 +1489,10 @@ scm_badargsp (SCM formals, SCM args)
 static int 
 scm_badformalsp (SCM closure, int n)
 {
-  SCM formals = SCM_CAR (SCM_CODE (closure));
+  SCM formals = SCM_CLOSURE_FORMALS (closure);
-  while (SCM_NIMP (formals))
+  while (!SCM_NULLP (formals))
     {
-      if (SCM_NCONSP (formals)) 
+      if (!SCM_CONSP (formals)) 
         return 0;
       if (n == 0) 
         return 1;
@@ -2218,7 +2218,7 @@ dispatch:
 	      debug.info->a.args = t.arg1;
 #endif
 #ifndef SCM_RECKLESS
-	      if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1))
+	      if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), t.arg1))
 		goto wrongnumargs;
 #endif
 	      ENTER_APPLY;
@@ -2238,7 +2238,7 @@ dispatch:
 		  SCM_SETCDR (tl, t.arg1);
 		}
 	      
-	      env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), argl, SCM_ENV (proc));
+	      env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), argl, SCM_ENV (proc));
 	      x = SCM_CODE (proc);
 	      goto nontoplevel_cdrxbegin;
 	    }
@@ -2630,9 +2630,9 @@ dispatch:
 #endif
       if (SCM_CLOSUREP (proc))
 	{
-	  arg2 = SCM_CAR (SCM_CODE (proc));
+	  arg2 = SCM_CLOSURE_FORMALS (proc);
 	  t.arg1 = SCM_CDR (x);
-	  while (!SCM_IMP (arg2))
+	  while (!SCM_NULLP (arg2))
 	    {
 	      if (!SCM_CONSP (arg2))
 		goto evapply;
@@ -2690,7 +2690,7 @@ evapply:
 	  goto umwrongnumargs;
       case scm_tcs_closures:
 	x = SCM_CODE (proc);
-	env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
+	env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc));
 	goto nontoplevel_cdrxbegin;
       case scm_tcs_cons_gloc:
 	if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
@@ -2842,9 +2842,9 @@ evapply:
 	  /* clos1: */
 	  x = SCM_CODE (proc);
 #ifdef DEVAL
-	  env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
+	  env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc));
 #else
-	  env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
+	  env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
 #endif
 	  goto nontoplevel_cdrxbegin;
 	case scm_tcs_cons_gloc:
@@ -3005,11 +3005,11 @@ evapply:
 	case scm_tcs_closures:
 	  /* clos2: */
 #ifdef DEVAL
-	  env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+	  env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
 			    debug.info->a.args,
 			    SCM_ENV (proc));
 #else
-	  env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+	  env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
 			    scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
 #endif
 	  x = SCM_CODE (proc);
@@ -3083,11 +3083,11 @@ evapply:
 	debug.info->a.proc = proc;
 	if (!SCM_CLOSUREP (proc))
 	  goto evap3;
-	if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), debug.info->a.args))
+	if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args))
 	  goto umwrongnumargs;
       case scm_tcs_closures:
 	SCM_SET_ARGSREADY (debug);
-	env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+	env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
 			      debug.info->a.args,
 			      SCM_ENV (proc));
 	x = SCM_CODE (proc);
@@ -3145,7 +3145,7 @@ evapply:
 	if (!SCM_CLOSUREP (proc))
 	  goto evap3;
 	{
-	  SCM formals = SCM_CAR (SCM_CODE (proc));
+	  SCM formals = SCM_CLOSURE_FORMALS (proc);
 	  if (SCM_NULLP (formals)
 	      || (SCM_CONSP (formals)
 		  && (SCM_NULLP (SCM_CDR (formals))
@@ -3157,7 +3157,7 @@ evapply:
 #ifdef DEVAL
 	SCM_SET_ARGSREADY (debug);
 #endif
-	env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+	env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
 			      scm_cons2 (t.arg1,
 					 arg2,
 					 scm_eval_args (x, env, proc)),
@@ -3471,7 +3471,7 @@ tail:
       arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
 #endif
 #ifndef SCM_RECKLESS
-      if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1))
+      if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1))
 	goto wrongnumargs;
 #endif
       
@@ -3490,7 +3490,7 @@ tail:
 	  SCM_SETCDR (tl, arg1);
 	}
       
-      args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), args, SCM_ENV (proc));
+      args = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), args, SCM_ENV (proc));
       proc = SCM_CDR (SCM_CODE (proc));
     again:
       arg1 = proc;

libguile/goops.c

@@ -1,4 +1,4 @@
-/*	Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -1065,7 +1065,7 @@ get_slot_value (SCM class, SCM obj, SCM slotdef)
       code = SCM_CAR (access);
       if (!SCM_CLOSUREP (code))
 	return SCM_SUBRF (code) (obj);
-      env  = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)),
+      env  = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
 			     SCM_LIST1 (obj),
 			     SCM_ENV (code));
       /* Evaluate the closure body */
@@ -1104,7 +1104,7 @@ set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value)
 	SCM_SUBRF (code) (obj, value);
       else
 	{
-	  env  = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)),
+	  env  = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
 				 SCM_LIST2 (obj, value),
 				 SCM_ENV (code));
 	  /* Evaluate the closure body */

libguile/macros.c

@@ -1,4 +1,4 @@
-/*	Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -45,6 +45,10 @@
 
 
 #include "libguile/_scm.h"
+#include "libguile/alist.h" /* for SCM_EXTEND_ENV (well...) */
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+#include "libguile/print.h"
 #include "libguile/root.h"
 #include "libguile/smob.h"
 
@@ -53,6 +57,47 @@
 
 scm_bits_t scm_tc16_macro;
 
+
+static int
+macro_print (SCM macro, SCM port, scm_print_state *pstate)
+{
+  SCM code = SCM_MACRO_CODE (macro);
+  if (!SCM_CLOSUREP (code)
+      || SCM_FALSEP (scm_procedure_p (SCM_PRINT_CLOSURE))
+      || SCM_FALSEP (scm_printer_apply (SCM_PRINT_CLOSURE,
+					macro, port, pstate)))
+    {
+      if (!SCM_CLOSUREP (code))
+	scm_puts ("#<primitive-", port);
+      else
+	scm_puts ("#<", port);
+
+      if (SCM_MACRO_TYPE (macro) == 0)
+	scm_puts ("syntax", port);
+      else if (SCM_MACRO_TYPE (macro) == 1)
+	scm_puts ("macro", port);
+      if (SCM_MACRO_TYPE (macro) == 2)
+	scm_puts ("macro!", port);
+      scm_putc (' ', port);
+      scm_iprin1 (scm_macro_name (macro), port, pstate);
+
+      if (SCM_CLOSUREP (code) && SCM_PRINT_SOURCE_P)
+	{
+	  SCM formals = SCM_CLOSURE_FORMALS (code);
+	  SCM env = SCM_ENV (code);
+	  SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
+	  SCM src = scm_unmemocopy (SCM_CODE (code), xenv);
+	  scm_putc (' ', port);
+	  scm_iprin1 (src, port, pstate);
+	}
+
+      scm_putc ('>', port);
+    }
+
+  return 1;
+}
+
+
 SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0,
             (SCM code),
 	    "Return a @dfn{macro} which, when a symbol defined to this value\n"
@@ -139,7 +184,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
 {
   if (!SCM_TYP16_PREDICATE (scm_tc16_macro, m))
     return SCM_BOOL_F;
-  switch (SCM_CELL_WORD_0 (m) >> 16)
+  switch (SCM_MACRO_TYPE (m))
     {
     case 0: return scm_sym_syntax;
     case 1: return scm_sym_macro;
@@ -186,6 +231,7 @@ scm_init_macros ()
 {
   scm_tc16_macro = scm_make_smob_type ("macro", 0);
   scm_set_smob_mark (scm_tc16_macro, scm_markcdr);
+  scm_set_smob_print (scm_tc16_macro, macro_print);
 #ifndef SCM_MAGIC_SNARFER
 #include "libguile/macros.x"
 #endif

libguile/print.c

@@ -128,8 +128,8 @@ char *scm_isymnames[] =
 };
 
 scm_option scm_print_opts[] = {
-  { SCM_OPTION_SCM, "closure-hook", SCM_UNPACK(SCM_BOOL_F),
+  { SCM_OPTION_SCM, "closure-hook", SCM_UNPACK (SCM_BOOL_F),
-    "Hook for printing closures." },
+    "Hook for printing closures (should handle macros as well)." },
   { SCM_OPTION_BOOLEAN, "source", 0,
     "Print closures with source." }
 };
@@ -310,6 +310,7 @@ print_circref (SCM port,scm_print_state *pstate,SCM ref)
 SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write);
 SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display);
 
+
 void 
 scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 {
@@ -408,83 +409,29 @@ taloop:
 	circref:
 	  print_circref (port, pstate, exp);
 	  break;
-	macros:
-	  if (!SCM_CLOSUREP (SCM_CDR (exp)))
-	    goto prinmacro;
 	case scm_tcs_closures:
-	  /* The user supplied print closure procedure must handle
-	     macro closures as well. */
 	  if (SCM_FALSEP (scm_procedure_p (SCM_PRINT_CLOSURE))
 	      || SCM_FALSEP (scm_printer_apply (SCM_PRINT_CLOSURE,
 						exp, port, pstate)))
-	  {
+	    {
-	    SCM name, code, env;
+	      SCM formals = SCM_CLOSURE_FORMALS (exp);
-	    if (SCM_MACROP (exp))
+	      scm_puts ("#<procedure", port);
-	      {
+	      scm_putc (' ', port);
-		/* Printing a macro. */
+	      scm_iprin1 (scm_procedure_name (exp), port, pstate);
-	      prinmacro:
+	      scm_putc (' ', port);
-		name = scm_macro_name (exp);
+	      if (SCM_PRINT_SOURCE_P)
-		if (!SCM_CLOSUREP (SCM_CDR (exp)))
+		{
-		  {
+		  SCM env = SCM_ENV (exp);
-		    code = env = SCM_UNDEFINED;
+		  SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
-		    scm_puts ("#<primitive-", port);
+		  SCM src = scm_unmemocopy (SCM_CODE (exp), xenv);
-		  }
+		  ENTER_NESTED_DATA (pstate, exp, circref);
-		else
+		  scm_iprin1 (src, port, pstate);
-		  {
+		  EXIT_NESTED_DATA (pstate);
-		    code = SCM_CODE (SCM_CDR (exp));
+		}
-		    env = SCM_ENV (SCM_CDR (exp));
+	      else
-		    scm_puts ("#<", port);
+		scm_iprin1 (formals, port, pstate);
-		  }
-		if (SCM_CELL_WORD_0 (exp) & (3L << 16))
-		  scm_puts ("macro", port);
-		else
-		  scm_puts ("syntax", port);
-		if (SCM_CELL_WORD_0 (exp) & (2L << 16))
-		  scm_putc ('!', port);
-	      }
-	    else
-	      {
-		/* Printing a closure. */
-		name = scm_procedure_name (exp);
-		code = SCM_CODE (exp);
-		env = SCM_ENV (exp);
-		scm_puts ("#<procedure", port);
-	      }
-	    if (SCM_SYMBOLP (name))
-	      {
-		scm_putc (' ', port);
-		scm_lfwrite (SCM_SYMBOL_CHARS (name), SCM_SYMBOL_LENGTH (name), port);
-	      }
-	    else if (SCM_STRINGP (name))
-	      {
-		scm_putc (' ', port);
-		scm_lfwrite (SCM_STRING_CHARS (name), SCM_STRING_LENGTH (name), port);
-	      }
-	    if (!SCM_UNBNDP (code))
-	      {
-		if (SCM_PRINT_SOURCE_P)
-		  {
-		    code = scm_unmemocopy (code,
-					   SCM_EXTEND_ENV (SCM_CAR (code),
-							   SCM_EOL,
-							   env));
-		    ENTER_NESTED_DATA (pstate, exp, circref);
-		    scm_iprlist (" ", code, '>', port, pstate);
-		    EXIT_NESTED_DATA (pstate);
-		  }
-		else
-		  {
-		    if (SCM_TYP16 (exp) != scm_tc16_macro)
-		      {
-			scm_putc (' ', port);
-			scm_iprin1 (SCM_CAR (code), port, pstate);
-		      }
-		    scm_putc ('>', port);
-		  }
-	      }
-	    else
 	      scm_putc ('>', port);
-	  }
+	    }
 	  break;
 	case scm_tc7_substring:
 	case scm_tc7_string:
@@ -698,19 +645,10 @@ taloop:
 	    register long i;
 	    ENTER_NESTED_DATA (pstate, exp, circref);
 	    i = SCM_SMOBNUM (exp);
-	    if (i < scm_numsmob && scm_smobs[i].print
+	    if (i < scm_numsmob && scm_smobs[i].print)
-		&& (scm_smobs[i].print) (exp, port, pstate))
+	      (scm_smobs[i].print) (exp, port, pstate);
-	      {
-		EXIT_NESTED_DATA (pstate);
-		break;
-	      }
 	    EXIT_NESTED_DATA (pstate);
-	    /* Macros have their print field set to NULL.  They are
+	    break;
-	       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:

libguile/procprop.c

@@ -1,4 +1,4 @@
-/*	Copyright (C) 1995,1996,1998, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001 Free Software Foundation, Inc.
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -128,15 +128,15 @@ scm_i_procedure_arity (SCM proc)
       proc = SCM_PROCEDURE (proc);
       goto loop;
     case scm_tcs_closures:
-      proc = SCM_CAR (SCM_CODE (proc));
+      proc = SCM_CLOSURE_FORMALS (proc);
-      if (SCM_IMP (proc))
+      if (SCM_NULLP (proc))
 	break;
       while (SCM_CONSP (proc))
 	{
 	  ++a;
 	  proc = SCM_CDR (proc);
 	}
-      if (SCM_NIMP (proc))
+      if (!SCM_NULLP (proc))
 	r = 1;
       break;
     case scm_tcs_cons_gloc:

libguile/procs.c

@@ -1,4 +1,4 @@
-/*	Copyright (C) 1995, 1996, 1997, 1999, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1999,2000,2001 Free Software Foundation, Inc.
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -223,7 +223,7 @@ SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0,
 	    "Return @code{#t} if @var{obj} is a closure.")
 #define FUNC_NAME s_scm_closure_p
 {
-  return SCM_BOOL(SCM_CLOSUREP (obj));
+  return SCM_BOOL (SCM_CLOSUREP (obj));
 }
 #undef FUNC_NAME
 
@@ -238,8 +238,7 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
       switch (SCM_TYP7 (obj))
 	{
 	case scm_tcs_closures:
-	  if (SCM_NULLP (SCM_CAR (SCM_CODE (obj))))
+	  return SCM_BOOL (!SCM_CONSP (SCM_CLOSURE_FORMALS (obj)));
-	    return SCM_BOOL_T;
 	case scm_tc7_subr_0:
 	case scm_tc7_subr_1o:
 	case scm_tc7_lsubr:

libguile/procs.h

@@ -93,6 +93,7 @@ typedef struct
 #define SCM_CLOSUREP(x) (SCM_NIMP(x) && (SCM_TYP3 (x) == scm_tc3_closure))
 #define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure)
 #define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x))
+#define SCM_CLOSURE_FORMALS(x) SCM_CAR (SCM_CODE (x))
 #define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x))
 #define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p)
 #define SCM_SETCODE(x, e) (SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_cons ((e), SCM_EOL)) \

libguile/sort.c

@@ -1,4 +1,4 @@
-/*      Copyright (C) 1999, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001 Free Software Foundation, Inc.
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
  * the Free Software Foundation; either version 2, or (at your option)
@@ -374,7 +374,7 @@ lsubrless (SCM less, const void *a, const void *b)
 static int 
 closureless (SCM code, const void *a, const void *b)
 {
-  SCM env = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)),
+  SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
 			    scm_cons (*(SCM *) a,
 				      scm_cons (*(SCM *) b, SCM_EOL)),
 			    SCM_ENV (code));