From 2d9d10ad41490e7bb58cc74af357a52373c0ed5e Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 15 Jan 2021 07:39:10 -0800
Subject: matcher: support @(some pat) operator.

This is the existential quantifier to accompany @(all).

* share/txr/stdlib/match.tl (compile-loop-match): Check for
the some symbol in a few places and adjust the output.
We don't need a local binding of the patter's variables,
only the temps. The values go directly to the outer binding of
the variables which are not shadowed now. We also don't need
the nreverse logic to set the outer variables: var-exprs
is nil at the outer level. The polarity of the loop
termination test is reversed: we quit the loop on the first
match, as is the polarity of the return value: if the loop is
aborted early t is returned instead of nil.
(compile-match): Wire in the some operator.
---
 share/txr/stdlib/match.tl | 12 ++++++++----
 1 file changed, 8 insertions(+), 4 deletions(-)

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 57206c0a..3af557e6 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -174,11 +174,13 @@
            (loop ^(for ((,iter-var ,obj-var)
                         (,loop-continue-p-var t))
                        ((and ,loop-continue-p-var ,iter-var)
-                        ,loop-continue-p-var)
+                        ,(if (eq op 'some)
+                           ^(not ,loop-continue-p-var)
+                           loop-continue-p-var))
                        ((set ,iter-var (cdr ,iter-var)))
                     (let ((,cm.obj-var (car ,iter-var))
                           ,matched-p-var
-                          ,*cm.(get-vars))
+                          ,*(if (eq op 'some) cm.(get-temps) cm.(get-vars)))
                       ,cm.(wrap-guards
                             ^(progn ,*cm.(assignments)
                                (if ,cm.test-expr
@@ -187,7 +189,7 @@
                                    ,*(mapcar (ret ^(push ,@1 ,@2))
                                              cm.vars
                                              collect-vars)))))
-                      (unless ,matched-p-var
+                      (,(if (eq op 'some) 'when 'unless) ,matched-p-var
                         (set ,loop-continue-p-var nil)))))
            (guard (new match-guard
                        vars (cons loop-success-p-var collect-vars)
@@ -199,7 +201,8 @@
            guard-chain (list guard)
            test-expr loop-success-p-var
            vars cm.vars
-           var-exprs (mapcar (ret ^(nreverse ,@1)) collect-vars)))))
+           var-exprs (unless (eq op 'some)
+                       (mapcar (ret ^(nreverse ,@1)) collect-vars))))))
 
 (defun compile-match (pat : (obj-var (gensym)))
   (cond
@@ -214,6 +217,7 @@
                  (let (compile-let-match exp obj-var))
                  (all (compile-loop-match exp obj-var))
                  (usr:all* (compile-loop-match exp obj-var))
+                 (some (compile-loop-match exp obj-var))
                  (t (compile-predicate-match exp obj-var)))
                (compile-error *match-form*
                               "unrecognized pattern syntax ~s" pat))))
-- 
cgit v1.2.3