From a91aff6dfa0d97c4130a3a7c630466b8ec2e247b Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kazkylheku@vtech.ca>
Date: Mon, 18 Jan 2021 19:59:36 -0800
Subject: matcher: add @(not) operator.

* share/txr/stdlib/match.tl (compile-not-match): New function.
(compile-match): Hook in not operator.

* txr.1: Documented.
---
 share/txr/stdlib/match.tl | 17 +++++++++++++++++
 1 file changed, 17 insertions(+)

(limited to 'share')

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 5c6038f5..38145218 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -262,6 +262,22 @@
                test-expr t
                vars (uniq (mappend .vars par-matches))))))))
 
+(defun compile-not-match (pattern obj-var)
+  (tree-bind (op pattern) pattern
+    (let* ((pm (compile-match pattern obj-var))
+           (guard (new match-guard
+                       guard-expr ^(not (let ,pm.(get-vars)
+                                          ,pm.(wrap-guards
+                                                ^(progn ,*pm.(assignments)
+                                                   (when ,pm.test-expr
+                                                     t))))))))
+      (new compiled-match
+           pattern pattern
+           obj-var obj-var
+           guard-chain (list guard)
+           test-expr t
+           vars nil))))
+
 (defun compile-match (pat : (obj-var (gensym)))
   (cond
     ((consp pat)
@@ -278,6 +294,7 @@
                  (some (compile-loop-match exp obj-var))
                  (or (compile-parallel-match exp obj-var))
                  (and (compile-parallel-match exp obj-var))
+                 (not (compile-not-match exp obj-var))
                  (op (compile-op-match exp obj-var))
                  (t (compile-predicate-match exp obj-var)))
                (compile-error *match-form*
-- 
cgit v1.2.3