diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2021-02-06 19:07:15 -0800 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2021-02-06 19:07:15 -0800 |
commit | 777eb4e599dd13797fbf7f458717a3ceff71b94d (patch) | |
tree | f10405d27d244063f011f906e2263e8b12fedd6d | |
parent | 4104aedd5d1924ac52e5be8e05a2eb179ce4320e (diff) | |
download | txr-777eb4e599dd13797fbf7f458717a3ceff71b94d.tar.gz txr-777eb4e599dd13797fbf7f458717a3ceff71b94d.tar.bz2 txr-777eb4e599dd13797fbf7f458717a3ceff71b94d.zip |
matcher: redesign predicate pattern.
* share/txr/stdlib/match.tl (compile-dwim-predicate-match):
Function removed. There is no more special @(dwim ...)
or @[...] pattern.
(compile-predicate-match): Function rewritten, providing
different syntax and semantics.
(compile-match): dwim dispatch removed.
(non-triv-pat-p): Replaced @(op ...) calls with new-style
predicate syntax.
(var-pat-p): Likewise, and upgraded one instance of old-style
predicate syntax to new.
* share/txr/stdlib/compiler.tl (reduce-or): Adjust predicate
pattern to new style.
* share/txr/stdlib/optimize.tl (dedup-labels): Likewise.
* tests/011/patmatch.tl: All test cases with predicate syntax
are updated to new style. One test case removed; some added.
* txr.1: Predicate patterns re-documented. All examples
involving predicate patterns updated.
-rw-r--r-- | share/txr/stdlib/compiler.tl | 2 | ||||
-rw-r--r-- | share/txr/stdlib/match.tl | 73 | ||||
-rw-r--r-- | share/txr/stdlib/optimize.tl | 2 | ||||
-rw-r--r-- | tests/011/patmatch.tl | 23 | ||||
-rw-r--r-- | txr.1 | 152 |
5 files changed, 142 insertions, 110 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index e858ade1..855b3004 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -1309,7 +1309,7 @@ ((or) form) ((or @a) form) ((or nil . @rest) (reduce-or ^(or ,*rest))) - ((or @(true-const-p c) . @rest) ^(or ,c)) + ((or @(true-const-p @c) . @rest) ^(or ,c)) ((or @a . @rest) ^(or ,a ,*(cdr (reduce-or ^(or ,*rest))))) (@else else))) diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index f99a8fe6..8fbac8f8 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -276,35 +276,43 @@ guard-expr ^ [,op-expr ,obj-var])) var-match)) -(defun compile-dwim-predicate-match (pred-expr obj-var var-list) - (mac-param-bind *match-form* (dwim fun : sym pat) pred-expr - (let ((var-match (compile-var-match sym obj-var var-list))) - (if pat - (let* ((pat-match (if (symbolp pat) - (compile-var-match pat (gensym) var-list) - (compile-match pat (gensym) var-list))) - (guard (new match-guard - pure-temps (list pat-match.obj-var) - pure-temp-exprs (list ^[,fun ,obj-var]) - test-expr pat-match.obj-var))) - (new compiled-match - pattern pred-expr - obj-var obj-var - guard-chain (cons guard (append var-match.guard-chain - pat-match.guard-chain)))) - (progn - var-match.(add-guard-pre (new match-guard - guard-expr ^[,fun ,obj-var])) - var-match))))) - -(defun compile-predicate-match (pred-expr obj-var var-list) - (mac-param-bind *match-form* (fun : sym) pred-expr - (or (null sym) (bindable sym) - (compile-error *match-form* "~s is not a bindable symbol" sym)) - (let ((var-match (compile-var-match sym obj-var var-list))) - var-match.(add-guard-pre (new match-guard - guard-expr ^(,fun ,obj-var))) - var-match))) +(defun compile-predicate-match (exp obj-var var-list) + (let ((head (car exp))) + (if (and (consp head) (eq (car head) 'sys:var)) + (tree-case exp + (((sv rvar) (op . args)) + (let* ((avar + (condlet + (((vm (member-if [andf consp (op eq (car @1) 'sys:var)] + args))) + (let ((sym (cadar vm))) + (set args (append (ldiff args vm) + (list sym) + (cdr vm))) + sym)) + (((vm (memq 'sys:var args))) + (let ((sym (cadr vm))) + (set args (append (ldiff args vm) sym)) + sym)))) + (res-var (if rvar rvar (gensym "res-"))) + (arg-var (if avar avar (gensym "obj-")))) + (unless avar + (set args (append args (list arg-var)))) + (let* ((guard (new match-guard + pure-temps (list res-var) + pure-temp-exprs ^((alet ((,arg-var ,obj-var)) + (,op ,*args))) + test-expr res-var)) + (avar-match (compile-var-match avar obj-var var-list)) + (rvar-match (compile-var-match rvar res-var var-list))) + (new compiled-match + pattern exp + obj-var obj-var + guard-chain (append avar-match.guard-chain + (list guard) + rvar-match.guard-chain))))) + (els (compile-error *match-form* "invalid predicate syntax: ~s" exp))) + (compile-predicate-match (list '@nil exp) obj-var var-list)))) (defun compile-cons-structure (cons-pat obj-var var-list) (mac-param-bind *match-form* (car . cdr) cons-pat @@ -556,7 +564,6 @@ (op (compile-op-match exp obj-var var-list)) (hash (compile-hash-match exp obj-var var-list)) (rcons (compile-range-match exp obj-var var-list)) - (dwim (compile-dwim-predicate-match exp obj-var var-list)) (exprs (compile-exprs-match exp obj-var var-list)) (t (compile-predicate-match exp obj-var var-list))) (compile-error *match-form* @@ -733,8 +740,8 @@ (defun non-triv-pat-p (syntax) (match-case syntax - ((@(op eq 'sys:expr) (@(bindable) . @nil)) t) - ((@(op eq 'sys:var) @(or @(bindable) nil) . @nil) t) + ((@(eq 'sys:expr) (@(bindable) . @nil)) t) + ((@(eq 'sys:var) @(or @(bindable) nil) . @nil) t) ((@pat . @rest) (or (non-triv-pat-p pat) (non-triv-pat-p rest))) (#R(@from @to) (or (non-triv-pat-p from) @@ -742,5 +749,5 @@ (@(some @(non-triv-pat-p)) t))) (defun var-pat-p (syntax) - (when-match (@(op eq 'sys:var) @(bindable sym) . @nil) syntax + (when-match (@(eq 'sys:var) @(bindable @sym) . @nil) syntax sym)) diff --git a/share/txr/stdlib/optimize.tl b/share/txr/stdlib/optimize.tl index 4f69d424..5a50f495 100644 --- a/share/txr/stdlib/optimize.tl +++ b/share/txr/stdlib/optimize.tl @@ -124,7 +124,7 @@ (defun dedup-labels (insns) (rewrite (lambda (tail) (match-case tail - ((@(symbolp label0) @(symbolp label1) . @rest) + ((@(symbolp @label0) @(symbolp @label1) . @rest) (set insns (mapcar [iffi listp (op subst label1 label0)] (remq label1 insns))) (list* label0 rest)) diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl index 870a3a0b..d30f5aec 100644 --- a/tests/011/patmatch.tl +++ b/tests/011/patmatch.tl @@ -13,7 +13,7 @@ (test (when-match (@a @b @c) '(1 2 3) (list c b a)) (3 2 1)) (test (if-match (@a @b @c . @d) '(1 2 3 . 4) (list d c b a)) (4 3 2 1)) -(test (if-match (@(oddp a) @b @c . @d) '(2 x y z) +(test (if-match (@(oddp @a) @b @c . @d) '(2 x y z) (list a b c d) :no-match) :no-match) @@ -85,8 +85,9 @@ (test (if-match @(or (@x 3 3) (1 @x 3) (1 2 @x)) '(1 2 3) x) 2) (test (if-match @(op <= 10 @1 13) 11 :yes :no) :yes) (test (when-match @(as x @(op <= 10 @1 13)) 11 x) 11) -(test (when-match (@(evenp) @(oddp x)) '(2 3) x) 3) - +(test (when-match (@(evenp) @(oddp @x)) '(2 3) x) 3) +(test (when-match @(<= 1 @x 10) 4 x) 4) +(test (when-match @(@d (chr-digit @c)) #\5 (list d c)) (5 #\5)) (test (when-match @(or @(require @a (oddp a)) @b @c) 2 (list a b c)) (nil 2 nil)) @@ -124,12 +125,12 @@ (1 2 3 42)) (test (let ((o 3)) - (when-match (@(evenp x) @(with @z @(oddp y) o)) '(4 6) + (when-match (@(evenp @x) @(with @z @(oddp @y) o)) '(4 6) (list x y z))) (4 3 6)) (test (let ((o 3)) - (when-match (@(evenp x) @(with @(oddp y) o)) '(4 6) + (when-match (@(evenp @x) @(with @(oddp @y) o)) '(4 6) (list x y))) (4 3)) @@ -154,7 +155,7 @@ (match-case obj (@(struct @s year 2021 day @d) (list d (struct-type-name s))) (@(struct time year @y month @x day @x) (list y x)) - (#(@(integerp x) @(require @y (succ x))) (list x y)) + (#(@(integerp @x) @(require @y (succ x))) (list x y)) (#(@x @y) (list x y)) ((@x @nil @x) x) ((@nil @nil @x) x) @@ -165,7 +166,7 @@ (test (when-match @(hash (x @y) (@y @datum)) #H(() (x k) (k 42)) datum) 42) -(test (when-match @(hash (x @y) (@(symbolp y) @datum)) #H(() (x k) (k 42)) datum) +(test (when-match @(hash (x @y) (@(symbolp @y) @datum)) #H(() (x k) (k 42)) datum) (42)) (test (if-match #R(10 20) 10..20 :yes :no) :yes) @@ -181,15 +182,11 @@ (test (when-match (rcons @a @b) '(rcons 1 2) (list a b)) (1 2)) (test (let ((h #H(() (a 1) (b 2)))) - (when-match @[h x] 'a x)) + (when-match @[h @x] 'a x)) a) (test (let ((h #H(() (a 1) (b 2)))) - (when-match @[h x y] 'a (list x y))) - (a 1)) - -(test (let ((h #H(() (a 1) (b 2)))) - (when-match @[h x @(oddp y)] 'a (list x y))) + (when-match @(@y [h @x]) 'a (list x y))) (a 1)) (test @@ -39951,7 +39951,7 @@ and therefore is not a list pattern. --> (4 3 2 1) ;; 2 doesn't satisfy oddp - (if-match (@(oddp a) @b @c . @d) '(2 x y z) + (if-match (@(oddp @a) @b @c . @d) '(2 x y z) (list a b c d) :no-match) --> :no-match @@ -40250,7 +40250,8 @@ operator matching against an association list. ;; a single entry matching the value of @y. This ;; is the k entry, whose value is 42. The @datum ;; value match takes this 42. - (when-match @(hash (x @y) (@y @datum)) #H(() (x k) (k 42)) datum) + (when-match @(hash (x @y) (@y @datum)) + #H(() (x k) (k 42)) datum) --> 42 ;; Again, (x @y) has a trivial key pattern so the x @@ -40262,7 +40263,8 @@ operator matching against an association list. ;; hash table. The @y variable has a binding to k, ;; so only the (k 42) entry is matched. The 42 ;; value matches @datum, and is collected into a list. - (when-match @(hash (x @y) (@(symbolp y) @datum)) #H(() (x k) (k 42)) datum) + (when-match @(hash (x @y) (@(symbolp @y) @datum)) + #H(() (x k) (k 42)) datum) --> (42) .brev @@ -40379,7 +40381,7 @@ it must be a bindable symbol or else --> (1 2 3 42) (let ((o 3)) - (when-match (@(evenp x) @(with @z @(oddp y) o)) '(4 6) + (when-match (@(evenp @x) @(with @z @(oddp y) o)) '(4 6) (list x y z))) --> (4 3 6) .brev @@ -40708,85 +40710,111 @@ function is capable of being called with exactly one argument. .NP* Pattern predicate operator .synb -.mets >> @( function <> [ variable ]) -.mets >> @[ expression >> [ variable >> [ pattern | << variable ]]] +.mets >> @( function << arg *) +.mets >> @( function << arg * >> @ avar << arg *) +.mets >> @(@ rvar >> ( function << arg *)) +.mets >> @(@ rvar >> ( function << arg * >> @ avar << arg *)) .syne .desc -Whenever the operator of a pattern predicate is not recognized and is -a bindable symbol, that operator is assumed to be the name of a function, and -the syntax is treated as the predicate operator. +Whenever the operator position of a pattern consists of a symbol which is not +the name of a predicate operator, the expression denotes a predicate pattern, +expected to conform to one of the first two syntax descriptions above. Whenever +the operator position of a pattern consists of a meta-variable, it is also a +predicate pattern, expected to conform to one of the second two syntax +descriptions. -The pattern predicate operator invokes the function, passing it the -corresponding object as an argument. The match is successful if the function -returns true. - -Optionally, if the -.meta variable -is specified, and is not -.codn nil , -it is bound to the corresponding object. - -The -.meta variable -argument, if present, must be a -.code bindable -symbol, or else +The first form of the predicate pattern consists of a compound form consisting +of an operator and arguments. Exactly one of the arguments may be a pattern +variable +.meta avar +("argument variable") which must be a bindable symbol. The role of +.meta avar +and the consequences of omitting it are described below. + +The second form of the predicate pattern consists of a meta-variable +.meta rvar +("result variable") +which must be a bindable symbol or else .codn nil . +This is followed by a compound form which consists of an operator +symbol, followed by arguments, one of which may be a pattern +.code avar +as in the simple form. +If +.meta rvar +is +.codn nil , +then the predicate pattern is equivalent to the first form. That is to say, +the following are equivalent: -The -.meta function -must be capable of accepting exactly one argument. +.verb + @(@nil (f ...)) <--> @(f ...) +.brev -The -.mono -.mets >> @[ expression >> [ variable >> [ pattern | << variable ]]] -.onom -variant of the predicate syntax is always a predicate. It denotes the evaluation of +The matching of the predicate pattern is processed as follows. +If the +.meta avar +variable is present, then the predicate pattern first binds the +corresponding object to the +.meta avar +variable, performing an ordinary variable match with the potential +back-referencing which that implies. If that succeeds, then the object is +inserted into the compound form, substituted in the position indicated by the .mono -.meti >> [ expression << arg ] +.meti >> @ avar .onom -where -.meta arg -is the corresponding object, that evaluation being required to -yield true. The -.meta variable -plays the same role. +variable. This form is then evaluated. If it yields true, then the +match is successful, otherwise the match fails. -This syntax supports an optional third argument, which may be a -.meta pattern -or another -.metn variable . -This pattern or variable, if present, is matched against the value of applying -.meta expression -to its argument. It allows that value to be captured and subject to -pattern matching. The restriction that this value must be true -continues to apply. +If the +.meta avar +variable is absent, then no initial variable matching takes place. +The corresponding object is inserted as an implicit extra argument into the +compound form, which is evaluated. Its truth value then determines the success +of the match, just like in the case with +.metn avar . + +If the second form is being processed, and specifies a +.meta rvar +that is not +.codn nil , +and if the predicate has succeeded, then then an extra processing step takes +place. A variable match is performed to bind the +.meta rvar +variable to the result of the predicate, with potential back-referencing. +If that match succeeds, then the predicate pattern succeeds. -Note: a -.code lambda -expression may be used as either -.meta function -or -.metn expression . +The compound form may be headed by the +.code dwim +operator, and therefore the DWIM bracket notation may be used. +For instance +.code "@[f @x]" +is equivalent to +.code "@(dwim f @x)" +and is processed accordingly. Similarly, +.code "@(@y [f @x])" +is equivalent to +.codn "@(@y (dwim f @x))" . .TP* Examples: .verb - (when-match (@(evenp) @(oddp x)) '(2 3) x) -> 3 + (when-match (@(evenp) @(oddp @x)) '(2 3) x) -> 3 + + (when-match @(<= 1 @x 10) 4 x) -> 4 + + (when-match @(@d (chr-digit @c)) #\e5 (list d c)) -> (5 #\e5) + + (when-match @(<= 1 @x 10) 11 x) -> nil ;; use hash table as predicate: (let ((h #H(() (a 1) (b 2)))) - (when-match @[h x] 'a x)) + (when-match @[h @x] 'a x)) -> a ;; as above, also capture hash value (let ((h #H(() (a 1) (b 2)))) - (when-match @[h x y] 'a (list x y))) - -> (a 1) - - ;; as above, also capture hash value, if odd - (let ((h #H(() (a 1) (b 2)))) - (when-match @[h x @(oddp y)] 'a (list x y))) + (when-match @(@y [h @x]) 'a (list x y))) -> (a 1) .brev |