Task #11474

* filter.c (filter_equal): Takes two filters instead of one.
(lfilt_k, rfilt_k): New keyword variables.
(filter_init): New keyword variables initialized.

* filter.h (filter_equal): Declaration updated.
(lfilt_k, rfilt_k): Declared.

* lib.c (funcall4): New function.
(do_curry_1234_34): New static function.
(curry_1234_34): New function.
(do_swap_12_21): New static function.
(swap_12_21): New function.

* lib.h (funcall4, curry_1234_34, swap_12_21): Declared.

* match.c (dest_bind): Swap use the function argument swapping
combinator when calling tree find such that the value
being searched is on the left and pattern material is on the right.
(v_bind): Implemented :lfilt and :rfilt.

* txr.1: Documented :lfilt and :rfilt.

7 files changed, 135 insertions, 29 deletions

diff --git a/ChangeLog b/ChangeLog
index 5ce31148..e2bb7ce1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,31 @@
 2011-10-22  Kaz Kylheku  <kaz@kylheku.com>
 
+	Task #11474
+
+	* filter.c (filter_equal): Takes two filters instead of one.
+	(lfilt_k, rfilt_k): New keyword variables.
+	(filter_init): New keyword variables initialized.
+
+	* filter.h (filter_equal): Declaration updated.
+	(lfilt_k, rfilt_k): Declared.
+
+	* lib.c (funcall4): New function.
+	(do_curry_1234_34): New static function.
+	(curry_1234_34): New function.
+	(do_swap_12_21): New static function.
+	(swap_12_21): New function.
+
+	* lib.h (funcall4, curry_1234_34, swap_12_21): Declared.
+
+	* match.c (dest_bind): Swap use the function argument swapping
+	combinator when calling tree find such that the value
+	being searched is on the left and pattern material is on the right.
+	(v_bind): Implemented :lfilt and :rfilt.
+
+	* txr.1: Documented :lfilt and :rfilt.
+
+2011-10-22  Kaz Kylheku  <kaz@kylheku.com>
+
 	* filter.c (get_filter_trie): Function renamed to get_filter. A filter
 	is not necessarily a trie.
 	(string_filter, compound_filter): New functions.
diff --git a/filter.c b/filter.c
index 4c787955..3ba2e9a0 100644
--- a/filter.c
+++ b/filter.c
@@ -231,10 +231,10 @@ val filter_string(val filter, val str)
   uw_throwf(error_s, lit("filter_string: invalid filter ~a"), filter, nao);
 }
 
-val filter_equal(val filter, val left, val right)
+val filter_equal(val lfilt, val rfilt, val left, val right)
 {
   if (stringp(left) && stringp(right))
-    return equal(filter_string(filter, left), filter_string(filter, right));
+    return equal(filter_string(lfilt, left), filter_string(rfilt, right));
   return equal(left, right);
 }
 
@@ -565,7 +565,7 @@ static val html_numeric_handler(val ch)
 }
 
 val filters;
-val filter_k, to_html_k, from_html_k;
+val filter_k, lfilt_k, rfilt_k, to_html_k, from_html_k;
 val upcase_k, downcase_k;
 
 void filter_init(void)
@@ -574,6 +574,8 @@ void filter_init(void)
 
   filters = make_hash(nil, nil);
   filter_k = intern(lit("filter"), keyword_package);
+  lfilt_k = intern(lit("lfilt"), keyword_package);
+  rfilt_k = intern(lit("rfilt"), keyword_package);
   to_html_k = intern(lit("to_html"), keyword_package);
   from_html_k = intern(lit("from_html"), keyword_package);
   upcase_k = intern(lit("upcase"), keyword_package);
diff --git a/filter.h b/filter.h
index d0d7d34b..136bb67b 100644
--- a/filter.h
+++ b/filter.h
@@ -25,14 +25,14 @@
  */
 
 extern val filters;
-extern val filter_k, to_html_k, from_html_k;
+extern val filter_k, lfilt_k, rfilt_k, to_html_k, from_html_k;
 
 val trie_lookup_begin(val trie);
 val trie_value_at(val node);
 val trie_lookup_feed_char(val node, val ch);
 val get_filter(val sym);
 val filter_string(val trie, val str);
-val filter_equal(val filter, val left, val right);
+val filter_equal(val lfilt, val rfilt, val left, val right);
 val register_filter(val sym, val table);
 
 void filter_init(void);
diff --git a/lib.c b/lib.c
index 98a9a056..064cb8ee 100644
--- a/lib.c
+++ b/lib.c
@@ -1541,6 +1541,22 @@ val funcall3(val fun, val arg1, val arg2, val arg3)
   }
 }
 
+val funcall4(val fun, val arg1, val arg2, val arg3, val arg4)
+{
+  type_check(fun, FUN);
+
+  switch (fun->f.functype) {
+  case F4:
+    return fun->f.f.f4(fun->f.env, arg1, arg2, arg3, arg4);
+  case N4:
+    return fun->f.f.n4(arg1, arg2, arg3, arg4);
+  default:
+    uw_throwf(error_s, lit("funcall4: wrong number of arguments"));
+  }
+}
+
+
+
 
 val reduce_left(val fun, val list, val init, val key)
 {
@@ -1593,6 +1609,16 @@ val curry_123_23(val fun3, val arg1)
   return func_f2(cons(fun3, arg1), do_curry_123_23);
 }
 
+static val do_curry_1234_34(val fcons, val arg3, val arg4)
+{
+  return funcall4(car(fcons), car(cdr(fcons)), cdr(cdr(fcons)), arg3, arg4);
+}
+
+val curry_1234_34(val fun4, val arg1, val arg2)
+{
+  return func_f2(cons(fun4, cons(arg1, arg2)), do_curry_1234_34);
+}
+
 static val do_chain(val fun1_list, val arg)
 {
   for (; fun1_list; fun1_list = cdr(fun1_list))
@@ -1648,6 +1674,16 @@ val andf(val first_fun, ...)
   return func_f1(out, do_and);
 }
 
+static val do_swap_12_21(val fun, val left, val right)
+{
+  return funcall2(fun, right, left);
+}
+
+val swap_12_21(val fun)
+{
+  return func_f2(fun, do_swap_12_21);
+}
+
 val vector(val alloc)
 {
   cnum alloc_plus = c_num(alloc) + 2;
diff --git a/lib.h b/lib.h
index 8cbeb8e5..76ff65df 100644
--- a/lib.h
+++ b/lib.h
@@ -383,6 +383,7 @@ val funcall(val fun);
 val funcall1(val fun, val arg);
 val funcall2(val fun, val arg1, val arg2);
 val funcall3(val fun, val arg1, val arg2, val arg3);
+val funcall4(val fun, val arg1, val arg2, val arg3, val arg4);
 val reduce_left(val fun, val list, val init, val key);
 /* The notation curry_12_2 means take some function f(arg1, arg2) and
    fix a value for argument 1 to create a g(arg2).
@@ -391,8 +392,10 @@ val curry_12_2(val fun2, val arg);
 val curry_12_1(val fun2, val arg2);
 val curry_123_2(val fun3, val arg1, val arg3);
 val curry_123_23(val fun3, val arg1);
+val curry_1234_34(val fun3, val arg1, val arg2);
 val chain(val first_fun, ...);
 val andf(val first_fun, ...);
+val swap_12_21(val fun);
 val vector(val alloc);
 val vec_get_fill(val vec);
 val vec_set_fill(val vec, val fill);
diff --git a/match.c b/match.c
index 9c8def60..b6578a7f 100644
--- a/match.c
+++ b/match.c
@@ -271,7 +271,7 @@ static val dest_bind(val linenum, val bindings, val pattern,
     if (bindable(pattern)) {
       val existing = assoc(bindings, pattern);
       if (existing) {
-        if (tree_find(value, cdr(existing), testfun))
+        if (tree_find(value, cdr(existing), swap_12_21(testfun)))
           return bindings;
         if (tree_find(cdr(existing), value, testfun))
           return bindings;
@@ -315,7 +315,7 @@ static val dest_bind(val linenum, val bindings, val pattern,
       return funcall2(testfun, piter, viter) ? bindings : t;
     }
     return bindings;
-  } else if (tree_find(value, pattern, testfun)) {
+  } else if (tree_find(value, pattern, swap_12_21(testfun))) {
     return bindings;
   }
 
@@ -2141,17 +2141,37 @@ static val v_bind(match_files_ctx c, match_files_ctx *cout)
   val keywords = rest(rest(args));
   val value = eval_form(spec_linenum, form, c.bindings);
   val testfun = equal_f;
-  val filter_sym = getplist(keywords, filter_k);
+  val filter_spec = getplist(keywords, filter_k);
+  val lfilt_spec = getplist(keywords, lfilt_k);
+  val rfilt_spec = getplist(keywords, rfilt_k);
 
-  if (filter_sym) {
-    val filter = get_filter(filter_sym);
+  if (filter_spec && (rfilt_spec || lfilt_spec))
+    uw_throwf(query_error_s, lit("bind: cannot use :filter with :lfilt or :rfilt"), nao);
+
+  if (filter_spec) {
+    val filter = get_filter(filter_spec);
 
     if (!filter) {
       uw_throwf(query_error_s, lit("bind: ~s specifies unknown filter"),
-                filter_sym, nao);
+                filter_spec, nao);
+    }
+
+    testfun = curry_1234_34(func_n4(filter_equal), filter, filter);
+  } else if (rfilt_spec || lfilt_spec) {
+    val rfilt = if3(rfilt_spec, get_filter(rfilt_spec), identity_f);
+    val lfilt = if3(lfilt_spec, get_filter(lfilt_spec), identity_f);
+
+    if (!rfilt) {
+      uw_throwf(query_error_s, lit("bind: ~s specifies unknown filter"),
+                rfilt_spec, nao);
+    }
+
+    if (!lfilt) {
+      uw_throwf(query_error_s, lit("bind: ~s specifies unknown filter"),
+                lfilt_spec, nao);
     }
 
-    testfun = curry_123_23(func_n3(filter_equal), filter);
+    testfun = curry_1234_34(func_n4(filter_equal), lfilt, rfilt);
   }
   
 
diff --git a/txr.1 b/txr.1
index dbfffd86..49ea719c 100644
--- a/txr.1
+++ b/txr.1
@@ -2049,8 +2049,7 @@ Example:
 
 The syntax of the @(bind) directive is:
 
-  @(bind pattern form { keyword value }*)
-
+  @(bind pattern expression { keyword value }*)
 
 The @(bind) directive is a kind of pattern match, which matches one or more
 variables on in the left hand side pattern to the value of a variable on the
@@ -2124,27 +2123,47 @@ keyword symbol object.
 
 .SS Keyword in The Bind Directive
 
-The Bind directive accepts the :filter keyword parameter. This specifies a
-filter for performing a more loose match between the left and right hand side
-objects. In the absence of a filter specification, text is compared verbatim,
-in a case-insensitive manner. If a filter is specified, it is applied to the
-left and right hand side. This has no effect if the left side is an unbound
-variable: no filtering takes place in the stablishment of a binding. It is for
-comparison purposes only.
+The Bind directive accepts these keywords
 
-Example: suppose A contains "abc" and B contains "ABC". The following directive will fail:
+.IP :lfilt
+The argument to :lfilt is a filter specification. When the left side pattern
+contains a binding which is therefore matched against its counterpart from the
+right side expression, the left side is filtered through the filter specified
+by :lfilt for the purposes of the comparison. For example:
 
-  @(bind A B)
+  @(bind "a" "A" :lfilt :upcase)
+
+produces a match, since the left side is the same as the right after
+filtering through the :upcase filter.
+
+.IP :rfilt
+The argument to :rfilt is a filter specification. The specified filter is
+applied to the right hand side material prior to matching it against
+the left side. The filter is not applied if the left side is a variable
+with no binding. It is only applied to determine a match. Binding takes
+place the unmodified right hand side object.
+
+Example, the following produces a match:
 
-However, the following will succeed:
+  @(bind "A" "a" :rfilt :upcase)
 
-  @(bind A B :filter :upcase)
 
-Bind will see that A and B have bindings already, and so compare their
-contents. Since the :upcase filter is specified, both their contents will be
-reduced through it for the purposes of the comparison, rendering them equal.
+.IP :filter
+This keyword is a shorthand to specify both filters to the same value.
+So for instance :filter :upcase is equivalent to :lfilt :upcase :rfilt :upcase.
+
+Of course, compound filters like (:from_html :upcase) are supported with
+all these keywords. The filters apply across arbitrary patterns and nested data.
+
+Example:
+
+  @(bind (a b c) ("A" "B" "C"))
+  @(bind (a b c) (("z" "a") "b" "c") :rfilt :upcase)
 
-Of course, compound filters are supported like (:from_html :upcase).
+Here, the first bind establishes the values for a, b and c, and the second bind
+succeeds, because the value of a matches the second element of the list ("z"
+"a") if it is upcased, and likewise b matches "b" and c matches "c" if these
+are upcased.
 
 .SS The Set Directive