diff options
-rw-r--r-- | libguile/ChangeLog | 28 | ||||
-rw-r--r-- | libguile/debug.c | 2 | ||||
-rw-r--r-- | libguile/eval.c | 36 | ||||
-rw-r--r-- | libguile/goops.c | 6 | ||||
-rw-r--r-- | libguile/macros.c | 50 | ||||
-rw-r--r-- | libguile/print.c | 110 | ||||
-rw-r--r-- | libguile/procprop.c | 8 | ||||
-rw-r--r-- | libguile/procs.c | 7 | ||||
-rw-r--r-- | libguile/procs.h | 1 | ||||
-rw-r--r-- | libguile/sort.c | 4 |
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)); |