summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--share/txr/stdlib/match.tl269
-rw-r--r--tests/011/patmatch.tl2
2 files changed, 175 insertions, 96 deletions
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 3e254f65..1a86cb9d 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -24,6 +24,8 @@
;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+(defvar *match-form*)
+
(defstruct match-vars ()
vars
var-exprs
@@ -31,7 +33,6 @@
(:method assignments (me)
(mapcar (ret ^(set ,@1 ,@2)) me.vars me.var-exprs)))
-
(defstruct match-guard (match-vars)
temps
pure-temps
@@ -41,25 +42,85 @@
(:method lets (me)
(mapcar (ret ^(,@1 ,@2)) me.pure-temps me.pure-temp-exprs)))
+(defstruct guard-disjunction ()
+ guard-chains
+ sub-patterns
+ all-vars)
+
(defstruct compiled-match (match-vars)
pattern
obj-var
guard-chain
test-expr
+ (:postinit (me)
+ (set me.guard-chain
+ (append me.guard-chain
+ (list
+ (new match-guard
+ vars me.vars
+ var-exprs me.var-exprs)
+ (new match-guard
+ guard-expr me.test-expr))))
+ (set me.vars nil
+ me.var-exprs nil
+ me.test-expr t))
+
(:method get-vars (me)
- (append me.vars (mappend .vars me.guard-chain)))
-
- (:method wrap-guards (me exp)
- (let ((rev-guard-chain (reverse me.guard-chain))
- (out exp))
- (each ((g rev-guard-chain))
- (set out ^(when ,g.guard-expr
- (alet ,g.(lets)
- (let ,g.temps
- ,*g.(assignments)
- ,out)))))
- out)))
+ (append me.vars (get-guard-values me.guard-chain .vars)))
+
+ (:method get-var-exprs (me)
+ (append me.var-exprs (get-guard-values me.guard-chain .var-exprs)))
+
+ (:method wrap-guards (me . forms)
+ (labels ((wrg (rgc exp)
+ (each ((g rgc))
+ (typecase g
+ (match-guard
+ (let ((lets g.(lets))
+ (temps g.temps))
+ (cond
+ ((and lets temps)
+ (set exp ^(alet ,lets
+ (let ,temps
+ ,*g.(assignments)
+ ,exp))))
+ (lets
+ (set exp ^(alet ,lets
+ ,*g.(assignments)
+ ,exp)))
+ (temps
+ (set exp ^(let ,temps
+ ,*g.(assignments)
+ ,exp)))
+ (t
+ (set exp ^(progn ,*g.(assignments)
+ ,exp))))
+ (when (neq t g.guard-expr)
+ (set exp ^(if ,g.guard-expr ,exp)))))
+ (guard-disjunction
+ (let ((branches (collect-each ((gc g.guard-chains))
+ (wrg (reverse gc) t))))
+ (set exp ^(when (or ,*branches)
+ ,exp))))
+ (t (compile-error *match-form*
+ "internal error: bad guard ~s" g))))
+ exp))
+ (wrg (reverse me.guard-chain)
+ ^(progn ,*forms))))
+
+ (:method add-guard-pre (me guard)
+ (push guard me.guard-chain))
+
+ (:method add-guards-pre (me . guards)
+ (set me.guard-chain
+ (append guards
+ me.guard-chain)))
+
+ (:method add-guards-post (me . guards)
+ (set me.guard-chain
+ (append me.guard-chain
+ guards))))
(defstruct var-list ()
vars
@@ -67,7 +128,15 @@
(:method exists (me sym) (member sym me.vars))
(:method record (me sym) (push sym me.vars)))
-(defvar *match-form*)
+(defun get-guard-values (guard-chain fun)
+ (append-each ((g guard-chain))
+ (typecase g
+ (match-guard
+ [fun g])
+ (guard-disjunction
+ (append-each ((gc g.guard-chains))
+ (get-guard-values gc fun)))
+ (t (compile-error *match-form* "internal error: bad guard ~s" g)))))
(defun compile-struct-match (struct-pat obj-var var-list)
(mac-param-bind *match-form* (op required-type . pairs) struct-pat
@@ -116,7 +185,7 @@
obj-var obj-var
guard-chain ^(,*(if guard0 (list guard0)) ,guard1
,*(mappend .guard-chain all-matches))
- test-expr ^(and ,*(mapcar .test-expr all-matches))
+ test-expr t
vars [mappend .vars all-matches]
var-exprs [mappend .var-exprs all-matches]))))
@@ -152,7 +221,7 @@
pattern vec-pat
obj-var obj-var
guard-chain (cons guard (mappend .guard-chain elem-matches))
- test-expr ^(and ,*(mapcar .test-expr elem-matches))
+ test-expr t
vars (mappend .vars elem-matches)
var-exprs (mappend .var-exprs elem-matches))))
@@ -170,7 +239,7 @@
obj-var obj-var
guard-chain (cons guard (append from-match.guard-chain
to-match.guard-chain))
- test-expr ^(and ,from-match.test-expr ,to-match.test-expr)
+ test-expr t
vars (append from-match.vars to-match.vars)
var-exprs (append from-match.var-exprs to-match.var-exprs)))))
@@ -193,7 +262,9 @@
(defun compile-op-match (op-expr obj-var var-list)
(let ((var-match (compile-var-match nil obj-var var-list)))
- (set var-match.test-expr ^(and ,var-match.test-expr [,op-expr ,obj-var]))
+ var-match.(add-guard-pre (new match-guard
+ guard-expr ^(and ,var-match.test-expr
+ [,op-expr ,obj-var])))
var-match))
(defun compile-dwim-predicate-match (pred-expr obj-var var-list)
@@ -213,11 +284,11 @@
pat-match.guard-chain))
vars (append var-match.vars pat-match.vars)
var-exprs (append var-match.var-exprs pat-match.var-exprs)
- test-expr ^(and ,var-match.test-expr
- ,pat-match.test-expr
- ,pat-match.obj-var)))
+ test-expr pat-match.obj-var))
(progn
- (set var-match.test-expr ^(and ,var-match.test-expr [,fun ,obj-var]))
+ var-match.(add-guard-pre (new match-guard
+ guard-expr ^(and ,var-match.test-expr
+ [,fun ,obj-var])))
var-match)))))
(defun compile-predicate-match (pred-expr obj-var var-list)
@@ -225,8 +296,9 @@
(or (null sym) (bindable sym)
(compile-error *match-form* "~s is not a symbol" sym))
(let ((var-match (compile-var-match sym obj-var var-list)))
- (push (new match-guard guard-expr ^(and ,var-match.test-expr (,fun ,obj-var)))
- var-match.guard-chain)
+ var-match.(add-guard-pre (new match-guard
+ guard-expr ^(and ,var-match.test-expr
+ (,fun ,obj-var))))
var-match)))
(defun compile-cons-structure (cons-pat obj-var var-list)
@@ -249,14 +321,15 @@
obj-var obj-var
guard-chain (cons guard (append car-match.guard-chain
cdr-match.guard-chain))
- test-expr ^(and ,car-match.test-expr ,cdr-match.test-expr)
+ test-expr t
vars (append car-match.vars cdr-match.vars)
var-exprs (append car-match.var-exprs cdr-match.var-exprs)))))
(defun compile-require-match (exp obj-var var-list)
(mac-param-bind *match-form* (op match . conditions) exp
(let ((match (compile-match match obj-var var-list)))
- (set match.test-expr ^(and ,match.test-expr ,*conditions))
+ match.(add-guards-post (new match-guard
+ guard-expr ^(and ,*conditions)))
match)))
(defun compile-let-match (exp obj-var var-list)
@@ -268,7 +341,7 @@
obj-var obj-var
guard-chain (append var-match.guard-chain
pat-match.guard-chain)
- test-expr ^(and ,var-match.test-expr ,pat-match.test-expr)
+ test-expr t
vars (append var-match.vars pat-match.vars)
var-exprs (append var-match.var-exprs pat-match.var-exprs)))))
@@ -302,18 +375,17 @@
,matched-p-var
,*(unless some-p cm-vars))
,cm.(wrap-guards
- ^(progn ,*cm.(assignments)
- (if ,cm.test-expr
- (progn
- (set ,matched-p-var t)
- ,*(if no-vac-p
- ^((set ,loop-iterated-var t)))
- ,*(unless some-p
- (mapcar (ret ^(push ,@1 ,@2))
- collect-vars
- collect-gens))))))
- ,(unless coll-p ^(,(if some-p 'when 'unless) ,matched-p-var
- (set ,loop-continue-p-var nil))))))
+ ^(progn
+ (set ,matched-p-var t)
+ ,*(if no-vac-p
+ ^((set ,loop-iterated-var t)))
+ ,*(unless some-p
+ (mapcar (ret ^(push ,@1 ,@2))
+ collect-vars
+ collect-gens))))
+ ,(unless coll-p ^(,(if some-p 'when 'unless)
+ ,matched-p-var
+ (set ,loop-continue-p-var nil))))))
(guard (new match-guard
vars cm-vars
temps (unless some-p collect-gens)
@@ -331,37 +403,49 @@
collect-vars collect-gens)
t))))))
-(defun compile-parallel-match (par-pat obj-var var-list)
+(defun compile-or-match (par-pat obj-var var-list)
(mac-param-bind *match-form* (op . pats) par-pat
(let* ((var-lists (mapcar (ret (copy var-list)) pats))
(par-matches (mapcar (op compile-match @1 obj-var @2)
pats var-lists))
- (all-vars (uniq (mappend .(get-vars) par-matches))))
- (flet ((submatch-fun (pm)
- pm.(wrap-guards
- ^(progn ,*pm.(assignments)
- (when ,pm.test-expr
- ,*(if (eq op 'or)
- (mapcar (ret ^(set ,@1 nil))
- (diff all-vars pm.(get-vars))))
- t)))))
- (let ((guard (new match-guard
- vars all-vars)))
- (new compiled-match
- pattern par-pat
- obj-var obj-var
- guard-chain (list guard)
- test-expr ^(,op ,*[mapcar submatch-fun par-matches])))))))
+ (all-var-exprs [unique [mapcar cons
+ (mappend .(get-vars) par-matches)
+ (mappend .(get-var-exprs) par-matches)]
+ car])
+ (guard (new match-guard
+ vars [mapcar car all-var-exprs]))
+ (dj-guard (new guard-disjunction
+ guard-chains (mapcar .guard-chain par-matches)
+ sub-patterns par-matches)))
+ (new compiled-match
+ pattern par-pat
+ obj-var obj-var
+ guard-chain (list guard dj-guard)
+ test-expr t))))
+
+(defun compile-and-match (par-pat obj-var var-list)
+ (mac-param-bind *match-form* (op . pats) par-pat
+ (let* ((var-lists (mapcar (ret (copy var-list)) pats))
+ (par-matches (mapcar (op compile-match @1 obj-var @2)
+ pats var-lists))
+ (all-var-exprs [unique [mapcar cons
+ (mappend .(get-vars) par-matches)
+ (mappend .(get-var-exprs) par-matches)]
+ car]))
+ (new compiled-match
+ pattern par-pat
+ obj-var obj-var
+ vars [mapcar car all-var-exprs]
+ var-exprs [mapcar cdr all-var-exprs]
+ guard-chain (mappend .guard-chain par-matches)
+ test-expr t))))
(defun compile-not-match (pattern obj-var var-list)
(mac-param-bind *match-form* (op pattern) pattern
(let* ((pm (compile-match pattern obj-var var-list))
(guard (new match-guard
guard-expr ^(not (let ,pm.(get-vars)
- ,pm.(wrap-guards
- ^(progn ,*pm.(assignments)
- (when ,pm.test-expr
- t))))))))
+ ,pm.(wrap-guards t))))))
(new compiled-match
pattern pattern
obj-var obj-var
@@ -384,14 +468,15 @@
((and key-var-sym var-list.(exists key-var-sym))
(let ((vm (compile-match val (gensym "val") var-list))
(val-sym (gensym "val")))
- (push
- (new match-guard
- guard-expr ^(neq ,vm.obj-var ,hash-alt-val))
- vm.guard-chain)
- (push vm.obj-var vm.vars)
- (push ^(gethash ,obj-var ,key-var-sym
- ,hash-alt-val) vm.var-exprs)
- vm))
+ vm.(add-guards-pre
+ (new match-guard
+ vars (list vm.obj-var)
+ var-exprs ^((gethash ,obj-var ,key-var-sym
+ ,hash-alt-val)))
+ (new match-guard
+ guard-expr ^(neq ,vm.obj-var
+ ,hash-alt-val)))
+ vm))
((and key-pat-p val-pat-p)
(set need-alist-p t)
(compile-match ^@(coll (,key . ,val))
@@ -399,23 +484,21 @@
(key-pat-p
(let ((km (compile-match key (gensym "keys")
var-list)))
- (push
- (new match-guard
- pure-temps (list km.obj-var)
- pure-temp-exprs ^((hash-keys-of ,obj-var ',val)))
- km.guard-chain)
+ km.(add-guards-pre
+ (new match-guard
+ pure-temps (list km.obj-var)
+ pure-temp-exprs ^((hash-keys-of ,obj-var
+ ',val))))
km))
(t
(let ((vm (compile-match val (gensym "val") var-list)))
- (push
- (new match-guard
- guard-expr ^(neq ,vm.obj-var ,hash-alt-val))
- vm.guard-chain)
- (push
- (new match-guard
- pure-temps (list vm.obj-var)
- pure-temp-exprs ^((gethash ,obj-var ',key, hash-alt-val)))
- vm.guard-chain)
+ vm.(add-guards-pre
+ (new match-guard
+ pure-temps (list vm.obj-var)
+ pure-temp-exprs ^((gethash ,obj-var ',key,
+ hash-alt-val)))
+ (new match-guard
+ guard-expr ^(neq ,vm.obj-var ,hash-alt-val)))
vm)))))))
(guard (new match-guard
guard-expr ^(hashp ,obj-var)
@@ -427,7 +510,7 @@
pattern hash-expr
obj-var obj-var
guard-chain (cons guard (mappend .guard-chain hash-matches))
- test-expr ^(and ,*(mapcar .test-expr hash-matches))
+ test-expr t
vars (mappend .vars hash-matches)
var-exprs (mappend .var-exprs hash-matches)))))
@@ -446,8 +529,8 @@
(usr:all* (compile-loop-match exp obj-var var-list))
(some (compile-loop-match exp obj-var var-list))
(coll (compile-loop-match exp obj-var var-list))
- (or (compile-parallel-match exp obj-var var-list))
- (and (compile-parallel-match exp obj-var var-list))
+ (or (compile-or-match exp obj-var var-list))
+ (and (compile-and-match exp obj-var var-list))
(not (compile-not-match exp obj-var var-list))
(op (compile-op-match exp obj-var var-list))
(hash (compile-hash-match exp obj-var var-list))
@@ -466,9 +549,7 @@
(let ((cm (compile-match pat)))
^(alet ((,cm.obj-var ,obj))
(let ,cm.(get-vars)
- ,cm.(wrap-guards
- ^(progn ,*cm.(assignments)
- (when ,cm.test-expr ,*body)))))))
+ ,cm.(wrap-guards . body)))))
(defmacro if-match (:form *match-form* pat obj then : else)
(let ((cm (compile-match pat))
@@ -477,10 +558,8 @@
^(alet ((,cm.obj-var ,obj))
(let* (,match-p ,*cm.(get-vars)
(,result ,cm.(wrap-guards
- ^(progn ,*cm.(assignments)
- (when ,cm.test-expr
- (set ,match-p t)
- ,then)))))
+ ^(set ,match-p t)
+ then)))
(if ,match-p ,result ,else)))))
(defmacro match-case (:form *match-form* obj . clauses)
@@ -496,10 +575,8 @@
^(unless ,(unless (zerop i) flag)
(let (,*cm.(get-vars))
(set ,result ,cm.(wrap-guards
- ^(progn ,*cm.(assignments)
- (when ,cm.test-expr
- (set ,flag t)
- ,*forms))))))))))
+ ^(set ,flag t)
+ . forms))))))))
^(let (,flag ,result)
,*clause-code
,result)))
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index 30f57e4b..6a9c6f18 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -77,6 +77,8 @@
(test (when-match (foo @(all @x)) '(bar (1 2 . 3)) x) nil)
+(test (when-match (@(or foo) @(all @x)) '(bar (1 2 . 3)) x) nil)
+
(test (when-match (@(oddp) @(all @x)) '(2 (1 2 . 3)) x) nil)
(test (if-match @(or (@x 3 3) (1 @x 3) (1 2 @x)) '(1 2 3) x) 2)