tree: allow quasiquoting into #T syntax.

* eval.c (tree_lit_s, tree_construct_s): New symbol variables.
(expand_qquote_rec): Handle sys:tree-lit syntax generated by
quasi-quoted #T notaton by expanding and converting to
sys:tree-constuct call.
(eval_init): Initialize tree_lit_s and tree_construct_s.

* eval.h (tree_lit_s, tree_construct_s): Declared.

* parser.y (tree): Produce sys:tree-lit syntax when #T is
quasi-quoted, and unquotes occur inside it.

* tree.c (tree_construct_fname, tree_construct): New static
functions.
(tree_init): Register sys:tree-construct intrinsic function.

4 files changed, 46 insertions, 11 deletions

diff --git a/eval.c b/eval.c
index 7268f893..68cc5d0e 100644
--- a/eval.c
+++ b/eval.c
@@ -96,7 +96,7 @@ val gen_s, gun_s, generate_s, rest_s;
 val promise_s, promise_forced_s, promise_inprogress_s, force_s;
 val op_s, identity_s;
 val hash_lit_s, hash_construct_s, struct_lit_s, qref_s, uref_s;
-val vector_lit_s, vec_list_s;
+val vector_lit_s, vec_list_s, tree_lit_s, tree_construct_s;
 val macro_time_s, macrolet_s;
 val defsymacro_s, symacrolet_s, prof_s, switch_s, struct_s;
 val fbind_s, lbind_s, flet_s, labels_s;
@@ -3502,6 +3502,10 @@ static val expand_qquote_rec(val qquoted_form, val qq, val unq, val spl)
       val args = expand_qquote(second(qquoted_form), qq, unq, spl);
       val pairs = expand_qquote(rest(rest(qquoted_form)), qq, unq, spl);
       return rlcp(list(make_struct_lit_s, args, pairs, nao), qquoted_form);
+    } else if (sym == tree_lit_s) {
+      val opts = expand_qquote(second(qquoted_form), qq, unq, spl);
+      val keys = expand_qquote(rest(rest(qquoted_form)), qq, unq, spl);
+      return rlcp(list(tree_construct_s, opts, keys, nao), qquoted_form);
     } else {
       val f = sym;
       val r = cdr(qquoted_form);
@@ -6238,6 +6242,8 @@ void eval_init(void)
   uref_s = intern(lit("uref"), user_package);
   vector_lit_s = intern(lit("vector-lit"), system_package);
   vec_list_s = intern(lit("vec-list"), user_package);
+  tree_lit_s = intern(lit("tree-lit"), system_package);
+  tree_construct_s = intern(lit("tree-construct"), system_package);
   macro_time_s = intern(lit("macro-time"), user_package);
   macrolet_s = intern(lit("macrolet"), user_package);
   symacrolet_s = intern(lit("symacrolet"), user_package);
diff --git a/eval.h b/eval.h
index 16388691..d10e7f8b 100644
--- a/eval.h
+++ b/eval.h
@@ -27,6 +27,7 @@
 
 extern val dwim_s, lambda_s, progn_s, vector_lit_s, vec_list_s, list_s;
 extern val hash_lit_s, hash_construct_s, struct_lit_s, qref_s, uref_s;
+extern val tree_lit_s, tree_construct_s;
 extern val eval_error_s, if_s, call_s, identity_s;
 extern val eq_s, eql_s, equal_s, less_s;
 extern val car_s, cdr_s;
diff --git a/parser.y b/parser.y
index 4bcb8b8b..c77babc4 100644
--- a/parser.y
+++ b/parser.y
@@ -868,16 +868,19 @@ tnode : HASH_N list             { if (gt(length($2), three))
                                   yybadtok(yychar, lit("tree node literal")); }
       ;
 
-tree : HASH_T list             { val opts = first($2);
-                                 val key_fn_name = pop(&opts);
-                                 val less_fn_name = pop(&opts);
-                                 val equal_fn_name = pop(&opts);
-                                 val key_fn = fname_helper(parser, key_fn_name);
-                                 val less_fn = fname_helper(parser, less_fn_name);
-                                 val equal_fn = fname_helper(parser, equal_fn_name);
-                                 val tr = tree(rest($2), key_fn,
-                                               less_fn, equal_fn);
-                                   $$ = rl(tr, num($1)); }
+tree : HASH_T list             { if (parser->quasi_level > 0 && unquotes_occur($2, 0))
+                                   $$ = rl(cons(tree_lit_s, $2), num($1));
+                                 else
+                                 { val opts = first($2);
+                                   val key_fn_name = pop(&opts);
+                                   val less_fn_name = pop(&opts);
+                                   val equal_fn_name = pop(&opts);
+                                   val key_fn = fname_helper(parser, key_fn_name);
+                                   val less_fn = fname_helper(parser, less_fn_name);
+                                   val equal_fn = fname_helper(parser, equal_fn_name);
+                                   val tr = tree(rest($2), key_fn,
+                                                 less_fn, equal_fn);
+                                     $$ = rl(tr, num($1)); } }
      | HASH_T error            { $$ = nil;
                                  yybadtok(yychar, lit("tree node literal")); }
      ;
diff --git a/tree.c b/tree.c
index 05b87bbb..a9063873 100644
--- a/tree.c
+++ b/tree.c
@@ -564,6 +564,30 @@ val tree(val keys_in, val key_fn, val less_fn, val equal_fn)
   return tree;
 }
 
+static val tree_construct_fname(val name)
+{
+  if (!name) {
+    return nil;
+  } else if (bindable(name)) {
+    val fun = cdr(lookup_fun(nil, name));
+    if (fun)
+      return fun;
+    uw_throwf(error_s, lit("#T: function named ~s doesn't exist"), name, nao);
+  } else if (functionp(name)) {
+    return name;
+  } else {
+    uw_throwf(error_s, lit("#T: ~s isn't a function name"), name, nao);
+  }
+}
+
+static val tree_construct(val opts, val keys)
+{
+  val key_fn = tree_construct_fname(pop(&opts));
+  val less_fn = tree_construct_fname(pop(&opts));
+  val equal_fn = tree_construct_fname(pop(&opts));
+  return tree(keys, key_fn, less_fn, equal_fn);
+}
+
 void tree_init(void)
 {
   tree_s = intern(lit("tree"), user_package);
@@ -573,6 +597,7 @@ void tree_init(void)
   reg_fun(intern(lit("right"), user_package), func_n1(right));
   reg_fun(intern(lit("key"), user_package), func_n1(key));
   reg_fun(tree_s, func_n4o(tree, 0));
+  reg_fun(tree_construct_s, func_n2(tree_construct));
   reg_fun(intern(lit("tree-insert-node"), user_package), func_n2(tree_insert_node));
   reg_fun(intern(lit("tree-insert"), user_package), func_n2(tree_insert));
   reg_fun(intern(lit("tree-lookup-node"), user_package), func_n2(tree_lookup_node));