Resurrect quasisyntax support.

* mes.c (the_unsyntaxers): New symbol.
  (mes_builtins)[QUASISYNTAX]: Initialize it, add to environment.
* quasiquote.c (add_unsyntaxers): Use it.
  (vm_eval_quasisyntax): New function.
  (eval_quasisyntax): Use it.

diff --git a/mes.c b/mes.c
index 67c7fcba97b118a9f5b4944ebefc0a3bc380f670..4226eb983457f0c7777eaaba734c726cb8978614 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -122,6 +122,7 @@ scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"};
 scm scm_symbol_read_input_file = {SYMBOL, "read-input-file"};
 
 scm scm_symbol_the_unquoters = {SYMBOL, "*the-unquoters*"};
+scm scm_symbol_the_unsyntaxers = {SYMBOL, "*the-unsyntaxers*"};
 
 scm scm_symbol_car = {SYMBOL, "car"};
 scm scm_symbol_cdr = {SYMBOL, "cdr"};
@@ -445,7 +446,7 @@ vm_eval_env ()
 #endif // FIXED_PRIMITIVES
           case cell_symbol_quote: return cadr (r1);
 #if QUASISYNTAX
-          case cell_symbol_syntax: return r1;
+          case cell_symbol_syntax: return cadr (r1);
 #endif
           case cell_symbol_begin: return begin_env (r1, r0);
           case cell_symbol_lambda:
@@ -1129,6 +1130,14 @@ mes_builtins (SCM a)
                                   cell_nil));
   a = acons (cell_symbol_the_unquoters, the_unquoters, a);
 #endif
+#if QUASISYNTAX
+  SCM cell_unsyntax = assq_ref_cache (cell_symbol_unsyntax, a);
+  SCM cell_unsyntax_splicing = assq_ref_cache (cell_symbol_unsyntax_splicing, a);
+  SCM the_unsyntaxers = cons (cons (cell_symbol_unsyntax, cell_unsyntax),
+                              cons (cons (cell_symbol_unsyntax_splicing, cell_unsyntax_splicing),
+                                  cell_nil));
+  a = acons (cell_symbol_the_unsyntaxers, the_unsyntaxers, a);
+#endif
 
   a = add_environment (a, "*dot*", cell_dot);
   a = add_environment (a, "*foo-bar-baz*", cell_nil); // FIXME: some off-by one?

diff --git a/quasiquote.c b/quasiquote.c
index 6a7cb5bcd063ba449f6ace2f6aa1ba800e229872..2188c433b42b8349ab124923cb02504e83c6ae3b 100644 (file)
--- a/quasiquote.c
+++ b/quasiquote.c
@@ -93,22 +93,31 @@ unsyntax_splicing (SCM x) ///((no-environment))
 SCM
 eval_quasisyntax (SCM e, SCM a)
 {
-  if (e == cell_nil) return e;
-  else if (atom_p (e) == cell_t) return e;
-  else if (eq_p (car (e), cell_symbol_unsyntax) == cell_t)
-    return eval_env (cadr (e), a);
-  else if (TYPE (e) == PAIR && TYPE (car (e)) == PAIR
-           && eq_p (caar (e), cell_symbol_unsyntax_splicing) == cell_t)
-      return append2 (eval_env (cadar (e), a), eval_quasisyntax (cdr (e), a));
-  return cons (eval_quasisyntax (car (e), a), eval_quasisyntax (cdr (e), a));
+  return vm_call (vm_eval_quasisyntax, e, cell_undefined, a);
+}
+
+SCM
+vm_eval_quasisyntax ()
+{
+  if (r1 == cell_nil) return r1;
+  else if (atom_p (r1) == cell_t) return r1;
+  else if (eq_p (car (r1), cell_symbol_unsyntax) == cell_t)
+    return eval_env (cadr (r1), r0);
+  else if (TYPE (r1) == PAIR && TYPE (car (r1)) == PAIR
+           && eq_p (caar (r1), cell_symbol_unsyntax_splicing) == cell_t)
+    {
+      r2 = eval_env (cadar (r1), r0);
+      return append2 (r2, eval_quasisyntax (cdr (r1), r0));
+    }
+  r2 = eval_quasisyntax (car (r1), r0);
+  return cons (r2, eval_quasisyntax (cdr (r1), r0));
 }
 
 SCM
 add_unsyntaxers (SCM a)
 {
-  a = cons (cons (cell_symbol_unsyntax, cell_unsyntax), a);
-  a = cons (cons (cell_symbol_unsyntax_splicing, cell_unsyntax_splicing), a);
-  return a;
+  SCM q = assq_ref_cache (cell_symbol_the_unsyntaxers, a);
+  return append2 (q, a);
 }
 
 #else // !QUASISYNTAX
@@ -117,5 +126,6 @@ SCM unsyntax (SCM x){}
 SCM unsyntax_splicing (SCM x){}
 SCM add_unsyntaxers (SCM a){}
 SCM eval_quasisyntax (SCM e, SCM a){}
+SCM vm_eval_quasisyntax () {}
 
 #endif // !QUASISYNTAX