From 165f289b0a028906e574281286bc0e8f98346b6b Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 15 Jan 2021 22:01:49 -0800
Subject: matcher: add if-match and match-case.

* lisplib.c (match_set_entries): Add match-case and if-match
autoload trigger symbols.

* share/txr/stdlib/match.tl (if-match, match-case): New
macros.
---
 lisplib.c                 |  2 +-
 share/txr/stdlib/match.tl | 34 ++++++++++++++++++++++++++++++++++
 2 files changed, 35 insertions(+), 1 deletion(-)

diff --git a/lisplib.c b/lisplib.c
index fa6022de..38fa4e35 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -874,7 +874,7 @@ static val match_set_entries(val dlt, val fun)
     nil
   };
   val name[] = {
-    lit("when-match"),
+    lit("when-match"), lit("match-case"), lit("if-match"),
     nil
   };
 
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 423cbc9c..695a0310 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -260,3 +260,37 @@
        ,cm.(wrap-guards
              ^(progn ,*cm.(assignments)
                 (if ,cm.test-expr ,*body))))))
+
+(defmacro if-match (:form *match-form* pat obj then : else)
+  (let ((cm (compile-match pat))
+        (match-p (gensym "match-p-"))
+        (result (gensym "result-")))
+    ^(let ((,cm.obj-var ,obj)
+           ,match-p
+           ,*cm.(get-vars))
+       (let ((,result ,cm.(wrap-guards
+                            ^(progn ,*cm.(assignments)
+                               (when ,cm.test-expr
+                                 (set ,match-p t)
+                                 ,then)))))
+         (if ,match-p ,result ,else)))))
+
+(defmacro match-case (:form *match-form* obj . clauses)
+  (unless [all clauses [andf proper-listp [chain len plusp]]]
+    (compile-error *match-form* "bad clause syntax"))
+  (let* ((flag (gensym "flag-"))
+         (result (gensym "result-"))
+         (clause-matches [mapcar (op compile-match (car @1) obj) clauses])
+         (clause-code (collect-each ((cl clauses)
+                                     (cm clause-matches))
+                        (tree-bind (match . forms) cl
+                          ^(unless ,flag
+                             (let (,*cm.(get-vars))
+                               (set ,result ,cm.(wrap-guards
+                                                  ^(progn ,*cm.(assignments)
+                                                     (when ,cm.test-expr
+                                                       (set ,flag t)
+                                                       ,*forms))))))))))
+    ^(let (,flag ,result)
+       ,*clause-code
+       ,result)))
-- 
cgit v1.2.3