Allow quasi-quoting over hash table literals,

to express dynamic hash table construction

* eval.c (expand_qquote): Recognize hash-construct
forms: expand the hash arguments and pairs separately,
then rewrite to a new hash-construct form.
(eval-init): hash-construct intrinsic function added.

* hash.c (hash_construct_s): New symbol variable.
(hash_construct): New function.
(hash_init): Initialize hash_construct_s.

* hash.h (hash_construct_s, hash_construct): Declared.

* parser.y (hash): Rule rewritten to emit either a literal
hash table object, or a hash-construct form, based on
whether quasiquote unquotes occur within the syntax.
(hash_from_notation): Function removed.

5 files changed, 50 insertions, 15 deletions

diff --git a/ChangeLog b/ChangeLog
index 772f53ad..a125a84e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,24 @@
+2012-03-14  Kaz Kylheku  <kaz@kylheku.com>
+
+	Allow quasi-quoting over hash table literals,
+	to express dynamic hash table construction
+
+	* eval.c (expand_qquote): Recognize hash-construct
+	forms: expand the hash arguments and pairs separately,
+	then rewrite to a new hash-construct form.
+	(eval-init): hash-construct intrinsic function added.
+
+	* hash.c (hash_construct_s): New symbol variable.
+	(hash_construct): New function.
+	(hash_init): Initialize hash_construct_s.
+
+	* hash.h (hash_construct_s, hash_construct): Declared.
+
+	* parser.y (hash): Rule rewritten to emit either a literal
+	hash table object, or a hash-construct form, based on
+	whether quasiquote unquotes occur within the syntax.
+	(hash_from_notation): Function removed.
+
 2012-03-13  Kaz Kylheku  <kaz@kylheku.com>
 
 	Change: @(block) requires @(end) from now on.
diff --git a/eval.c b/eval.c
index 156e58e2..b87f23c5 100644
--- a/eval.c
+++ b/eval.c
@@ -1383,6 +1383,10 @@ static val expand_qquote(val qquoted_form)
     } else if (sym == qquote_s) {
       return rlcp(expand_qquote(expand_qquote(second(qquoted_form))), 
                   qquoted_form);
+    } else if (sym == hash_construct_s) {
+      val args = expand_qquote(second(qquoted_form));
+      val pairs = expand_qquote(rest(rest(qquoted_form)));
+      return rlcp(list(sym, args, pairs, nao), qquoted_form);
     } else {
       val f = car(qquoted_form);
       val r = cdr(qquoted_form);
@@ -2196,6 +2200,7 @@ void eval_init(void)
 
   reg_fun(intern(lit("make-hash"), user_package), func_n3(make_hash));
   reg_fun(intern(lit("hash"), user_package), func_n0v(hashv));
+  reg_fun(intern(lit("hash-construct"), user_package), func_n2(hash_construct));
   reg_fun(gethash_s, func_n3o(gethash_n, 2));
   reg_fun(intern(lit("sethash"), user_package), func_n3(sethash));
   reg_fun(intern(lit("pushhash"), user_package), func_n3(pushhash));
diff --git a/hash.c b/hash.c
index bc086ae9..713034c7 100644
--- a/hash.c
+++ b/hash.c
@@ -65,6 +65,7 @@ struct hash_iter {
 };
 
 val weak_keys_k, weak_vals_k, equal_based_k;
+val hash_construct_s;
 
 /*
  * Dynamic list built up during gc.
@@ -580,9 +581,22 @@ val hashv(val args)
   return make_hash(wkeys, wvals, equal);
 }
 
+val hash_construct(val hashv_args, val pairs)
+{
+  val hash = hashv(hashv_args);
+
+  for (; pairs; pairs = cdr(pairs)) {
+    val pair = car(pairs);
+    sethash(hash, first(pair), second(pair));
+  }
+
+  return hash;
+}
+
 void hash_init(void)
 {
   weak_keys_k = intern(lit("weak-keys"), keyword_package);
   weak_vals_k = intern(lit("weak-vals"), keyword_package);
   equal_based_k = intern(lit("equal-based"), keyword_package);
+  hash_construct_s = intern(lit("hash-construct"), user_package);
 }
diff --git a/hash.h b/hash.h
index f4c23cb2..72752f72 100644
--- a/hash.h
+++ b/hash.h
@@ -25,6 +25,7 @@
  */
 
 extern val weak_keys_k, weak_vals_k, equal_based_k;
+extern val hash_construct_s;
 
 val make_hash(val weak_keys, val weak_vals, val equal_based);
 val *gethash_l(val hash, val key, val *new_p);
@@ -44,6 +45,7 @@ val hash_next(val *iter);
 val hash_eql(val obj);
 val hash_equal(val obj);
 val hashv(val args);
+val hash_construct(val hashv_args, val pairs);
 
 void hash_process_weak(void);
 
diff --git a/parser.y b/parser.y
index 68fe03f0..a6827a9d 100644
--- a/parser.y
+++ b/parser.y
@@ -51,6 +51,7 @@ static val o_elems_transform(val output_form);
 static val define_transform(val define_form);
 static val lit_char_helper(val litchars);
 static val optimize_text(val text_form);
+static val unquotes_occur(val quoted_form);
 static val choose_quote(val quoted_form);
 static wchar_t char_from_name(wchar_t *name);
 static val hash_from_notation(val notation);
@@ -671,7 +672,13 @@ o_var : IDENT                   { $$ = list(var_s, intern(string_own($1), nil),
 vector : '#' list               { $$ = rlcp(vector_list($2), $2); }
        ;
 
-hash : HASH_H list              { $$ = rlcp(hash_from_notation($2), num($1)); }
+hash : HASH_H list              { if (unquotes_occur($2))
+                                    $$ = rlcp(cons(hash_construct_s, $2),
+                                              num($1));
+                                  else
+                                    $$ = rlcp(hash_construct(first($2),
+                                                             rest($2)),
+                                              num($1)); }
      ;
 
 list : '(' exprs ')'            { $$ = rl($2, num($1)); }
@@ -1074,19 +1081,6 @@ static wchar_t char_from_name(wchar_t *name)
   return L'!'; /* code meaning not found */
 }
 
-static val hash_from_notation(val notation)
-{
-  val hash = hashv(first(notation));
-  val iter = rest(notation);
-
-  for (; iter; iter = cdr(iter)) {
-    val entry = car(iter);
-    sethash(hash, first(entry), second(entry));
-  }
-
-  return hash;
-}
-
 val get_spec(void)
 {
   return parsed_spec;
@@ -1163,4 +1157,3 @@ void yybadtoken(int tok, val context)
       else
         yyerrorf(lit("unexpected ~s"), chr(tok), nao);
 }
-