summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-02-06 19:07:15 -0800
committerKaz Kylheku <kaz@kylheku.com>2021-02-06 19:07:15 -0800
commit777eb4e599dd13797fbf7f458717a3ceff71b94d (patch)
treef10405d27d244063f011f906e2263e8b12fedd6d
parent4104aedd5d1924ac52e5be8e05a2eb179ce4320e (diff)
downloadtxr-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.tl2
-rw-r--r--share/txr/stdlib/match.tl73
-rw-r--r--share/txr/stdlib/optimize.tl2
-rw-r--r--tests/011/patmatch.tl23
-rw-r--r--txr.1152
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
diff --git a/txr.1 b/txr.1
index 762e886c..03eab8fe 100644
--- a/txr.1
+++ b/txr.1
@@ -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