diff options
-rw-r--r-- | libguile/ChangeLog | 26 | ||||
-rw-r--r-- | libguile/eval.c | 84 | ||||
-rw-r--r-- | libguile/eval.h | 5 | ||||
-rw-r--r-- | libguile/print.c | 53 |
4 files changed, 139 insertions, 29 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 88223ef94..d25423e91 100644 --- a/libguile/ChangeLog +++ b/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, diff --git a/libguile/eval.c b/libguile/eval.c index 2bb5487df..43dfa8644 100644 --- a/libguile/eval.c +++ b/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) + SCM obj; +{ + return (SCM_NIMP (obj) && SCM_TYP16 (obj) == scm_tc16_macro + ? SCM_BOOL_T + : SCM_BOOL_F); +} -static int -prinmacro (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; + +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; { - int writingp = SCM_WRITINGP (pstate); - 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); - 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; + 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 = -{scm_markcdr, scm_free0, prinprom}; - -static scm_smobfuns macrosmob = -{scm_markcdr, scm_free0, prinmacro}; +static scm_smobfuns promsmob = {scm_markcdr, scm_free0, prinprom}; +static scm_smobfuns macrosmob = {scm_markcdr, scm_free0}; SCM scm_make_synt (name, macroizer, fcn) diff --git a/libguile/eval.h b/libguile/eval.h index 85ca7c267..2ceed646f 100644 --- a/libguile/eval.h +++ b/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)); diff --git a/libguile/print.c b/libguile/print.c index 238862b4b..026718652 100644 --- a/libguile/print.c +++ b/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); - code = SCM_CODE (exp); - scm_gen_puts (scm_regular_string, "#<procedure ", port); + if (SCM_TYP16 (exp) == scm_tc16_macro) + { + /* 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_putc (' ', port); scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port); + } + if (code) + { scm_gen_putc (' ', port); + scm_iprin1 (SCM_CAR (code), port, pstate); } - scm_iprin1 (SCM_CAR (code), port, pstate); - if (SCM_PRINT_SOURCE_P) + 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); |