summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2001-04-19 14:46:01 +0000
committerDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2001-04-19 14:46:01 +0000
commit726d810a75c140442032ddb1daa6422a104e272f (patch)
tree063679caa69ab538ad6624bdada60759f999700f
parente038c04203e77522ba59c8181df4601ed15621a1 (diff)
downloadguile-726d810a75c140442032ddb1daa6422a104e272f.tar.gz
* Fixed scm_thunk_p's results when applied to closures.
* Extracted macro printing code from print.c to macros.c. * Minor cleanups.
-rw-r--r--libguile/ChangeLog28
-rw-r--r--libguile/debug.c2
-rw-r--r--libguile/eval.c36
-rw-r--r--libguile/goops.c6
-rw-r--r--libguile/macros.c50
-rw-r--r--libguile/print.c110
-rw-r--r--libguile/procprop.c8
-rw-r--r--libguile/procs.c7
-rw-r--r--libguile/procs.h1
-rw-r--r--libguile/sort.c4
10 files changed, 132 insertions, 120 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 8da43e204..6d725d8c9 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,5 +1,33 @@
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
non pair cells.
diff --git a/libguile/debug.c b/libguile/debug.c
index 3b4f77fa9..20fa8d7c6 100644
--- a/libguile/debug.c
+++ b/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,
diff --git a/libguile/eval.c b/libguile/eval.c
index 67d90345f..c8136e138 100644
--- a/libguile/eval.c
+++ b/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));
- while (SCM_NIMP (formals))
+ SCM formals = SCM_CLOSURE_FORMALS (closure);
+ 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;
diff --git a/libguile/goops.c b/libguile/goops.c
index f63a4a42f..a32cba7d9 100644
--- a/libguile/goops.c
+++ b/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 */
diff --git a/libguile/macros.c b/libguile/macros.c
index 44eac33d8..734cd6d5d 100644
--- a/libguile/macros.c
+++ b/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
diff --git a/libguile/print.c b/libguile/print.c
index b1f59d249..e686d26dd 100644
--- a/libguile/print.c
+++ b/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),
- "Hook for printing closures." },
+ { SCM_OPTION_SCM, "closure-hook", SCM_UNPACK (SCM_BOOL_F),
+ "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;
- if (SCM_MACROP (exp))
- {
- /* Printing a macro. */
- prinmacro:
- name = scm_macro_name (exp);
- if (!SCM_CLOSUREP (SCM_CDR (exp)))
- {
- code = env = SCM_UNDEFINED;
- scm_puts ("#<primitive-", port);
- }
- else
- {
- code = SCM_CODE (SCM_CDR (exp));
- env = SCM_ENV (SCM_CDR (exp));
- scm_puts ("#<", port);
- }
- 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 formals = SCM_CLOSURE_FORMALS (exp);
+ scm_puts ("#<procedure", port);
+ scm_putc (' ', port);
+ scm_iprin1 (scm_procedure_name (exp), port, pstate);
+ scm_putc (' ', port);
+ if (SCM_PRINT_SOURCE_P)
+ {
+ SCM env = SCM_ENV (exp);
+ SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
+ SCM src = scm_unmemocopy (SCM_CODE (exp), xenv);
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ scm_iprin1 (src, port, pstate);
+ EXIT_NESTED_DATA (pstate);
+ }
+ else
+ scm_iprin1 (formals, port, pstate);
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
- && (scm_smobs[i].print) (exp, port, pstate))
- {
- EXIT_NESTED_DATA (pstate);
- break;
- }
+ if (i < scm_numsmob && scm_smobs[i].print)
+ (scm_smobs[i].print) (exp, port, pstate);
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;
+ break;
}
default:
punk:
diff --git a/libguile/procprop.c b/libguile/procprop.c
index bcd80c25a..7bfc96b3a 100644
--- a/libguile/procprop.c
+++ b/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));
- if (SCM_IMP (proc))
+ proc = SCM_CLOSURE_FORMALS (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:
diff --git a/libguile/procs.c b/libguile/procs.c
index 0e59df8ad..77cd3b9b2 100644
--- a/libguile/procs.c
+++ b/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_T;
+ return SCM_BOOL (!SCM_CONSP (SCM_CLOSURE_FORMALS (obj)));
case scm_tc7_subr_0:
case scm_tc7_subr_1o:
case scm_tc7_lsubr:
diff --git a/libguile/procs.h b/libguile/procs.h
index 7007b3d2b..ca39c918d 100644
--- a/libguile/procs.h
+++ b/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)) \
diff --git a/libguile/sort.c b/libguile/sort.c
index 2d2941aa4..954f75eeb 100644
--- a/libguile/sort.c
+++ b/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));