summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1997-09-10 20:05:28 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1997-09-10 20:05:28 +0000
commit7332df664494f9a206b2460524f95e8dffe240a4 (patch)
tree86d87b07daa396ccd0425aacfe25cbc2031a49e5
parent87688f5f1282080e4fff755c4ba544f19ed418fb (diff)
downloadguile-7332df664494f9a206b2460524f95e8dffe240a4.tar.gz
* * 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.
-rw-r--r--libguile/ChangeLog26
-rw-r--r--libguile/eval.c84
-rw-r--r--libguile/eval.h5
-rw-r--r--libguile/print.c53
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);