From b7ff83e5a61175a97c6979ea51776d0b2b32d0ce Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 15 Jan 2021 06:42:53 -0800
Subject: matcher: fix semantics of empty @(all ...) match.

* lisplib.c (match_set_entries): Ensure usr:all* is interned.

* share/txr/stdlib/match.tl (compile-all-match): When the
operator is the existing all, we must listp as a guard, not
consp, because an empty list must match vacuously by virtue of
not containing any counterexample to the pattern. For
situations when a vacuous empty match is not desired, we
support the all* alternative operator, which uses consp.
(compile-match): Wire in the all* operator.
---
 lisplib.c                 | 6 ++++++
 share/txr/stdlib/match.tl | 6 ++++--
 2 files changed, 10 insertions(+), 2 deletions(-)

diff --git a/lisplib.c b/lisplib.c
index a77ff015..fa6022de 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -869,11 +869,17 @@ static val match_instantiate(val set_fun)
 
 static val match_set_entries(val dlt, val fun)
 {
+  val name_noload[] = {
+    lit("all*"),
+    nil
+  };
   val name[] = {
     lit("when-match"),
     nil
   };
+
   set_dlt_entries(dlt, name, fun);
+  intern_only(name_noload);
   return nil;
 }
 
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 4fd3ad41..dd917786 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -163,7 +163,8 @@
 
 (defun compile-all-match (exp obj-var)
   (tree-bind (op match) exp
-    (let* ((item-var (gensym "item-"))
+    (let* ((list-test (if (eq op 'all) 'listp 'consp))
+           (item-var (gensym "item-"))
            (cm (compile-match match item-var))
            (all-match-p-var (gensym "all-match-p-"))
            (matched-p-var (gensym "matched-p-"))
@@ -188,7 +189,7 @@
            (guard (new match-guard
                        vars (cons all-match-p-var collect-vars)
                        var-exprs (list loop)
-                       guard-expr ^(consp ,obj-var))))
+                       guard-expr ^(,list-test ,obj-var))))
       (new compiled-match
            pattern exp
            obj-var obj-var
@@ -209,6 +210,7 @@
                  (require (compile-require-match exp obj-var))
                  (let (compile-let-match exp obj-var))
                  (all (compile-all-match exp obj-var))
+                 (usr:all* (compile-all-match exp obj-var))
                  (t (compile-predicate-match exp obj-var)))
                (compile-error *match-form*
                               "unrecognized pattern syntax ~s" pat))))
-- 
cgit v1.2.3