summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--share/txr/stdlib/match.tl27
-rw-r--r--tests/011/patmatch.tl21
-rw-r--r--txr.125
3 files changed, 64 insertions, 9 deletions
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index e269ecc1..f40fbd70 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -118,8 +118,11 @@
(defstruct var-list ()
vars
+ menv
- (:method exists (me sym) (member sym me.vars))
+ (:method exists (me sym) (or (member sym me.vars)
+ (lexical-var-p me.menv sym)
+ (boundp sym)))
(:method record (me sym) (push sym me.vars))
(:method merge (me copy) (each ((v copy.vars)) (pushnew v me.vars))))
@@ -551,14 +554,17 @@
(compile-atom-match pat obj-var var-list)))))
(t (compile-atom-match pat obj-var var-list))))
-(defmacro when-match (:form *match-form* pat obj . body)
- (let ((cm (compile-match pat)))
+(defun get-var-list (env)
+ (new var-list menv env))
+
+(defmacro when-match (:form *match-form* :env e pat obj . body)
+ (let ((cm (compile-match pat : (get-var-list e))))
^(alet ((,cm.obj-var ,obj))
(let ,cm.(get-vars)
,cm.(wrap-guards . body)))))
-(defmacro if-match (:form *match-form* pat obj then : else)
- (let ((cm (compile-match pat))
+(defmacro if-match (:form *match-form* :env e pat obj then : else)
+ (let ((cm (compile-match pat : (get-var-list e)))
(match-p (gensym "match-p-"))
(result (gensym "result-")))
^(alet ((,cm.obj-var ,obj))
@@ -568,13 +574,16 @@
then)))
(if ,match-p ,result ,else)))))
-(defmacro match-case (:form *match-form* obj . clauses)
+(defmacro match-case (:form *match-form* :env e obj . clauses)
(unless [all clauses [andf proper-listp [chain len plusp]]]
(compile-error *match-form* "bad clause syntax"))
(let* ((matched-p-temp (gensym "matched-p-"))
(result-temp (gensym "result-"))
(objvar (gensym "obj-"))
- (clause-matches [mapcar (op compile-match (car @1) objvar) clauses])
+ (var-list (get-var-list e))
+ (clause-matches [mapcar (op compile-match (car @1)
+ objvar (copy var-list))
+ clauses])
(nclauses (len clauses))
(clause-code (collect-each ((cl clauses)
(cm clause-matches)
@@ -593,8 +602,8 @@
,*clause-code
,result-temp))))
-(defmacro when-exprs-match (:form *match-form* pats exprs . forms)
- (let ((em (compile-match ^@(exprs ,*pats) exprs)))
+(defmacro when-exprs-match (:form *match-form* :env e pats exprs . forms)
+ (let ((em (compile-match ^@(exprs ,*pats) exprs (get-var-list e))))
^(let* (,*em.(get-vars))
,em.(wrap-guards . forms))))
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index fe82d28c..870a3a0b 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -241,3 +241,24 @@
(test (ack 1 1) 3)
(test (ack 2 2) 7)
+
+(defun x-x-y (list x)
+ (when-match (@x @x @y) list y))
+
+(test (x-x-y '(1 1 2) 1) 2)
+(test (x-x-y '(1 2 3) 1) nil)
+(test (x-x-y '(1 1 2 r2) 1) nil)
+
+(test (let ((a 3) (x 0))
+ (match-case '(3 2 1)
+ ((@x 2 @b) ^(1 ,b))
+ ((@a 2 @b) ^(2 ,a))))
+ (2 3))
+
+(test
+ (let ((a 3) (x 0))
+ (labels ((local (:match)
+ ((@x 2 @b) ^(1 ,b))
+ ((@a 2 @b) ^(2 ,a))))
+ (local 3 2 1)))
+ (2 3))
diff --git a/txr.1 b/txr.1
index 74359b7c..21c2fd2e 100644
--- a/txr.1
+++ b/txr.1
@@ -39818,6 +39818,31 @@ and binds a to the leftmost
and fails to match a list like
.codn "(1 2)" .
+Pattern variables exist in the same namespace as Lisp variables,
+and are fully integrated in it. Patterns not only bind variables,
+but have visibility to existing variables in scope, including
+lexical variables and special/global variables. When a variable
+is mentioned in a pattern, if it already has a binding as a Lisp variable, then
+it denotes a reference to that variable in exactly the same way that a pattern
+variable back-references itself in a pattern: the Lisp variable
+is require to compare
+.code equal
+to the corresponding object being examined by the pattern. For instance,
+the following function returns the third element of a list, if the
+first two elements are repetitions of the
+.code x
+argument, otherwise
+.codn nil :
+
+.verb
+ (defun x-x-y (list x)
+ (when-match (@x @x @y) list y))
+
+ (x-x-y '(1 1 2) 1) -> 2
+ (x-x-y '(1 2 3) 1) -> nil ;; no @x @x match
+ (x-x-y '(1 1 2 r2) 1) -> nil ;; list too long
+.brev
+
The pattern-matching notation is documented in the following
sections; sections describing the pattern matching macros follow.