New quasiquote idea: let's have two quasiquote macros sharing one

expander. One macro based on sys:qquote, sys:unquote and sys:splice,
and the other based on qquote, unquote and splice in the user package.
The read syntax puts out the sys: one.

* eval.c (expand_qquote): Takes three additional arguments: the
qquote, unquote and splice symbols to recognize.
The invalid splice diagnostic is adjusted based on which backquote
we are expanding.
(me_qquote): Look at the symbol in the first position of the form
and then expand either the internal quasiquote macro or the public one,
passing the right symbols into expand_qquote.
(eval_init): Register error-throwing stub functions
for the sys_qquote_s, sys_unquote_s and sys_splice_s symbols.
Register a macro for sys_qquote_s.

* lib.c (sys_qquote_s, sys_unquote_s, sys_splice_s): New symbol
variables.
(obj_init): Initialize new variables. Change qquote_s,
unquote_s and splice_s to user package.
(obj_print, obj_pprint): Convert only sys_qquote_s,
sys_unquote_s and sys_splice_s to the read syntax.
The quote_s, unquote_s and splice_s symbols are not
treated specially.

* lib.h (sys_qquote_s, sys_unquote_s, sys_splice_s): Declared.

* parser.y (n_expr): Use sys_qquote_s, sys_unquote_s and
sys_splice_s rather than qquote_s, unquote_s and splice_s.
(unquotes_occur): Likewise.

* txr.1: Documented.

1 files changed, 37 insertions, 21 deletions

diff --git a/eval.c b/eval.c
index dc712b89..e718853a 100644
--- a/eval.c
+++ b/eval.c
@@ -2007,7 +2007,8 @@ static val expand_cond_pairs(val form, val menv)
   }
 }
 
-static val expand_qquote(val qquoted_form, val menv)
+static val expand_qquote(val qquoted_form, val menv,
+                         val qq, val unq, val spl)
 {
   if (nilp(qquoted_form)) {
     return nil;
@@ -2016,44 +2017,50 @@ static val expand_qquote(val qquoted_form, val menv)
   } else {
     val sym = car(qquoted_form);
 
-    if (sym == splice_s) {
-      eval_error(qquoted_form, lit("',*~s syntax is invalid"),
-                 second(qquoted_form), nao);
-    } else if (sym == unquote_s) {
+    if (sym == spl) {
+      val error_msg = if3(spl == sys_splice_s,
+                          lit("the splice ,*~s cannot occur as an atom "
+                              "or in the dotted position of a list"),
+                          lit("(splice ~s) cannot occur as an atom "
+                              "or in the dotted position of a list"));
+        eval_error(qquoted_form, error_msg,
+                   second(qquoted_form), nao);
+    } else if (sym == unq) {
       return expand(second(qquoted_form), menv);
-    } else if (sym == qquote_s) {
+    } else if (sym == qq) {
       return rlcp(expand_qquote(expand_qquote(second(qquoted_form),
-                                              menv),
-                                menv), 
+                                              menv, qq, unq, spl),
+                                menv, qq, unq, spl), 
                   qquoted_form);
     } else if (sym == hash_lit_s) {
-      val args = expand_qquote(second(qquoted_form), menv);
-      val pairs = expand_qquote(rest(rest(qquoted_form)), menv);
+      val args = expand_qquote(second(qquoted_form), menv, qq, unq, spl);
+      val pairs = expand_qquote(rest(rest(qquoted_form)), menv, qq, unq, spl);
       return rlcp(list(hash_construct_s, args, pairs, nao), qquoted_form);
     } else if (sym == vector_lit_s) {
-      val args = expand_qquote(second(qquoted_form), menv);
+      val args = expand_qquote(second(qquoted_form), menv, qq, unq, spl);
       return rlcp(list(vector_list_s, args, nao), qquoted_form);
     } else {
       val f = sym;
       val r = cdr(qquoted_form);
       val f_ex;
-      val r_ex = expand_qquote(r, menv);
+      val r_ex = expand_qquote(r, menv, qq, unq, spl);
 
       if (consp(f)) {
         val qsym = car(f);
-        if (qsym == splice_s) {
+        if (qsym == spl) {
           f_ex = expand(second(f), menv);
-        } else if (qsym == unquote_s) {
+        } else if (qsym == unq) {
           f_ex = cons(list_s, cons(expand(second(f), menv), nil));
-        } else if (qsym == qquote_s) {
+        } else if (qsym == qq) {
           f_ex = cons(list_s, cons(expand_qquote(expand_qquote(second(f),
-                                                               menv),
-                                                 menv), nil));
+                                                               menv, qq,
+                                                               unq, spl),
+                                                 menv, qq, unq, spl), nil));
         } else {
-          f_ex = cons(list_s, cons(expand_qquote(f, menv), nil));
+          f_ex = cons(list_s, cons(expand_qquote(f, menv, qq, unq, spl), nil));
         }
       } else {
-        f_ex = cons(list_s, cons(expand_qquote(f, menv), nil));
+        f_ex = cons(list_s, cons(expand_qquote(f, menv, qq, unq, spl), nil));
       }
 
       if (nilp(r_ex)) {
@@ -2061,7 +2068,7 @@ static val expand_qquote(val qquoted_form, val menv)
       } else if (atom(r_ex)) {
         return rlcp(cons(append_s, cons(f_ex, cons(r_ex, nil))), qquoted_form);
       } else {
-        if (consp(r) && car(r) == unquote_s)
+        if (consp(r) && car(r) == unq)
           r_ex = cons(r_ex, nil);
         else if (car(r_ex) == append_s)
           r_ex = cdr(r_ex);
@@ -2076,7 +2083,12 @@ static val expand_qquote(val qquoted_form, val menv)
 
 static val me_qquote(val form, val menv)
 {
-  return expand_qquote(second(form), menv);
+  if (first(form) == sys_qquote_s)
+    return expand_qquote(second(form), menv,
+                         sys_qquote_s, sys_unquote_s, sys_splice_s);
+  return expand_qquote(second(form), menv,
+                       qquote_s, unquote_s, splice_s);
+                       
 }
 
 static val expand_vars(val vars, val menv, val form,
@@ -3062,8 +3074,11 @@ void eval_init(void)
 
   reg_op(quote_s, op_quote);
   reg_op(qquote_s, op_qquote_error);
+  reg_op(sys_qquote_s, op_qquote_error);
   reg_op(unquote_s, op_unquote_error);
+  reg_op(sys_unquote_s, op_unquote_error);
   reg_op(splice_s, op_unquote_error);
+  reg_op(sys_splice_s, op_unquote_error);
   reg_op(progn_s, op_progn);
   reg_op(prog1_s, op_prog1);
   reg_op(let_s, op_let);
@@ -3112,6 +3127,7 @@ void eval_init(void)
   reg_mac(op_s, me_op);
   reg_mac(do_s, me_op);
   reg_mac(qquote_s, me_qquote);
+  reg_mac(sys_qquote_s, me_qquote);
 
   reg_fun(cons_s, func_n2(cons));
   reg_fun(intern(lit("make-lazy-cons"), user_package), func_n1(make_lazy_cons));