summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-01-28 08:25:13 -0800
committerKaz Kylheku <kaz@kylheku.com>2021-01-28 08:25:13 -0800
commit9da4f521318c011c5f3569e7bc36cb9af734c72a (patch)
treee41404521c5fb4a441771330eceb649e34f43423
parent83d294fe8651643b7064dfea1402e24629853452 (diff)
downloadtxr-9da4f521318c011c5f3569e7bc36cb9af734c72a.tar.gz
txr-9da4f521318c011c5f3569e7bc36cb9af734c72a.tar.bz2
txr-9da4f521318c011c5f3569e7bc36cb9af734c72a.zip
matcher: restructuring to fix new broken case.
This one test case requires restructuring. The handling for the @(or ...) operator is now very different. To support @(or ...), there is now a new variant of the match-guard object called guard disjunction, which contains multiple match-guard chains. Furthermore, the separation between both guard-chain lists and compiled-match having a test expression and variables is being obliterated. For now, what we do is in a :postinit handler on compiled-match, we immediately convert the test-expr, vars and var-exprs slots into a match-guard object, which is placed into the guard-chain, and then we clear these slots. They are now vestigial only and will be removed. * tests/011/patmatch.tl: New test case which shows that (@(or foo bar) ...) does not short immediately short circuit to a failure when the corresponding element is neither foo nor bar. Matching proceeds to the right, wasting cycles and possibly causing errors. * share/txr/stdlib/match.tl (*match-var*): Move to top, above structs. There are some methods which refer to this variable now for throwing internal errors. (guard-disjunction): New object that is compatible with a match-guard, and placed into guard-lists as if it were a match-guard. This handles the bifurcation logic of an OR match. (compiled-match): New :postinit handler converts local vars, var-exprs and test-expr into a match-guard placed into the chain, and then clears these values. The compilation of code is done purely from the guard-chain. (compiled-match get-vars): This method is now complicated due to the guard-disjunction objects, and so uses a helper function called get-guard-values. (compiled-match get-var-exprs): New method accompanying get-vars to get the accompanying init expressions. (compiled-match wrap-guards): Two changes are going on here. One is that the funccion takes on more of the responsibility which was previously carried out by the callers. The callers were interpolating the test-expr and vars from a compiled-match into a piece of code, which was then passed to wrap-guards. Hence the naming: the job was just to wrap some guards. Now, wrap-guards is called just with the body forms, and does all of the work. Secondly, wrap-guards is complicated due to the handling of the guard-disjunction items. Also, there is some case handling to generate better code; we avoid generating an empty (let () ...) and (alet () ...). (compiled-match add-guard-pre, compiled-match add-guards-pre, compiled-match add-guards-post): New methods for adding guards after construction. These interfaces replace hacks of pushing new variables, tweaking the test-expr, or explicitly pushing guards onto the list. (get-guard-values): New function for iterating over a guard-chain, including match-guard and guard-disjunction items, retrieving a particular list-valued slot from each one using the fun argument, and returning a list of all those lists catenated together. (compile-struct-match, compile-vec-match, compile-range-match): Eliminate test-expr, replacing it with the harmless t. (compile-op-match): We don't try to extend the test-expr of the compiled var. Rather we add our guard expressin using the add-guard-pre interface. (compile-dwim-predicate-match): Likewise, and also, we do not calculate the test-expr for the output compiled-match from the constituent match test-exprs. We ignore those and just set the test-expr pat-match.obj-var. The constituent test-exprs have been converted to guard-chain items already, so there is no point in referring to them. (compile-predicate-match): Use add-guard-pre method to add guard instead of pushing it on list. (compile-cons-structure): Eliminate test-expr being calculated from constituent test-exprs, and just stub it out to t. (compile-require-match): Use add-guards-post to push match-guard onto compiled child mach, instead of tweaking its test-expr. (compile-let-match): Oblierate calculation of test-expr from child test-exprs, replacing with t stub. (compile-loop-match): Call wrap-guards in the new way, without generating assignments or test-expr. (compile-parallel-match): This method is removed; there are now separate compile-or-match and compile-and-match methods. (compile-or-match): New method: compiles consitituent expressions, and converts them into multiple guard-chains for a guard-disjunction object. Then wrap-guards will finish the job of emitting the or logic out of those chains. (compile-and-match): This shares some common logic with compile-or-match, but is substantially simpler. Pattern matching is implicitly AND-based: in a pattern, all the sub-patterns have to match. So there isn't much to do beyond just evaluating all the patterns against the same object. They can all be thrown into one combined flat guard chain. (compile-not-match): Adjust to new wrap-guards interface. Nothing left to do here but pass the expression t to it. (copmile-hash-mach): The post-constructon manipulations of the child compiled matches are done with the appropriate add-guards-pre. The test-expr is eliminated, replaced with t. (compile-match): Wire or and and to the new separate methods compile-or-match and compile-and-match. (when-match, if-match, match-case): Simplified due to when-match interface change. The macros depend on a lot less implementation detail now: they bind the required vars and generate the code.
-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)