Implementing @(set) directive for assigning to variables

destructively.

* match.c (dest_set, v_set): New static functions.
(dir_tables_init): Add v_set to vertical directives hash table.

* txr.1: Documented.

3 files changed, 95 insertions, 0 deletions

diff --git a/ChangeLog b/ChangeLog
index 8ae63b4b..086be220 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,15 @@
 2011-10-21  Kaz Kylheku  <kaz@kylheku.com>
 
+	Implementing @(set) directive for assigning to variables
+	destructively.
+
+	* match.c (dest_set, v_set): New static functions.
+	(dir_tables_init): Add v_set to vertical directives hash table.
+
+	* txr.1: Documented.
+
+2011-10-21  Kaz Kylheku  <kaz@kylheku.com>
+
 	* match.c (v_output): When appending output to a variable,
 	flatten the previous contents so we can append to a single
 	string, or to deeply nested list, etc.
diff --git a/match.c b/match.c
index a2bc8eb3..1d415ac5 100644
--- a/match.c
+++ b/match.c
@@ -233,6 +233,37 @@ static val bindable(val obj)
   return (obj && symbolp(obj) && obj != t && !keywordp(obj)) ? t : nil;
 }
 
+static val dest_set(val linenum, val bindings, val pattern, val value)
+{
+  if (symbolp(pattern)) {
+    val existing = assoc(bindings, pattern);
+    if (!bindable(pattern))
+      sem_error(linenum, lit("~s cannot be used as a variable"), pattern, nao);
+    if (!existing)
+      sem_error(linenum, lit("cannot set unbound variable ~s"), pattern, nao);
+    *cdr_l(existing) = value;
+  } else if (consp(pattern)) {
+    if (first(pattern) == var_s) {
+      uw_throwf(query_error_s, 
+                lit("metavariable @~a syntax cannot be used here"),
+                second(pattern), nao);
+    }
+
+    if (first(pattern) == expr_s) {
+      uw_throwf(query_error_s, 
+                lit("the @~s syntax cannot be used here"),
+                rest(pattern), nao);
+    }
+    dest_set(linenum, bindings, car(pattern), car(value));
+    if (cdr(pattern))
+      dest_set(linenum, bindings, cdr(pattern), cdr(value));
+  } else {
+    sem_error(linenum, lit("cannot set ~s: not a variable"), pattern, nao);
+  }
+
+  return nil;
+}
+
 static val dest_bind(val linenum, val bindings, val pattern, val value)
 {
   if (symbolp(pattern)) {
@@ -2095,6 +2126,20 @@ static val v_bind(match_files_ctx c, match_files_ctx *cout)
   return next_spec_k;
 }
 
+static val v_set(match_files_ctx c, match_files_ctx *cout)
+{
+  spec_bind (specline, spec_linenum, first_spec, c.spec);
+  val args = rest(first_spec);
+  val pattern = first(args);
+  val form = second(args);
+  val val = eval_form(spec_linenum, form, c.bindings);
+
+  dest_set(spec_linenum, c.bindings, pattern, cdr(val));
+
+  *cout = c;
+  return next_spec_k;
+}
+
 static val v_cat(match_files_ctx c, match_files_ctx *cout)
 {
   spec_bind (specline, spec_linenum, first_spec, c.spec);
@@ -2692,6 +2737,7 @@ static void dir_tables_init(void)
   sethash(v_directive_table, local_s, cptr((mem_t *) v_forget_local));
   sethash(v_directive_table, merge_s, cptr((mem_t *) v_merge));
   sethash(v_directive_table, bind_s, cptr((mem_t *) v_bind));
+  sethash(v_directive_table, set_s, cptr((mem_t *) v_set));
   sethash(v_directive_table, cat_s, cptr((mem_t *) v_cat));
   sethash(v_directive_table, output_s, cptr((mem_t *) v_output));
   sethash(v_directive_table, define_s, cptr((mem_t *) v_define));
diff --git a/txr.1 b/txr.1
index 8e6ef97d..9b47039c 100644
--- a/txr.1
+++ b/txr.1
@@ -1053,6 +1053,11 @@ Binds one or more variables against another variable using a structural
 pattern. A limited form of unification takes place which can cause a match to
 fail.
 
+.IP @(set)
+Destructively assigns one or more existing variables using a structural
+pattern, using syntax similar to bind. Assignment to unbound
+variables triggers an error.
+
 .IP @(output)
 A directive which encloses an output clause in the query. An output section
 does not match text, but produces text. The directives above are not
@@ -2091,6 +2096,40 @@ They represent themselves.  For example @(bind :foo :bar) fails,
 but @(bind :foo :foo) succeeds since the two sides denote the same
 keyword symbol object.
 
+
+.SS The Set Directive
+
+The @(set) directive resembles bind, but is not a pattern match. It overwrites
+the previous values of variables with new values from the right hand side.
+Each variable that is assigned must have an existing binding.
+
+Examples follow.
+
+Store the value of A back into A, achieving nothing:
+
+  @(set A A)
+
+Exchange the values of A and B:
+
+  @(set (A B) (B A))
+
+Store a string into A:
+
+  @(set A "text")
+
+Store a list into A:
+
+  @(set A ("line1" "line2"))
+
+Destructuring assignment. D assumed to contain the list 
+
+  @(bind D ("A" ("B1" "B2") "C1" "C2"))
+  @(bind (A B C) (() () ()))
+  @(set (A B . C) D)
+
+A ends up with "A", B ends up with ("B1" "B2") and C gets ("C1" and "C2").
+
+
 .SH BLOCKS
 
 .SS Introduction