matcher: back-reference Lisp variables.

* share/txr/stdlib/match.tl (struct var-list): New slot, menv.
(var-list exists): Method now falls back on lexical scope and
dynamic variables.
(get-var-list): New function.
(when-match, if-match, match-case, when-exprs-match): Capture
macro environment and use get-vars-list to convert to a vars
object which carries it as the menv slot. With this, the
compiler framework has access to the lexical environment.

* tests/011/patmatch.tl: Test cases of back-referencing with
Lisp lexicals.

* txr.1: Documented.

1 files changed, 18 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))))