summaryrefslogtreecommitdiffstats
path: root/tests/011
diff options
context:
space:
mode:
Diffstat (limited to 'tests/011')
-rw-r--r--tests/011/keyparams.tl47
-rw-r--r--tests/011/macros-3.expected0
-rw-r--r--tests/011/macros-3.tl13
-rw-r--r--tests/011/macros-4.tl11
-rw-r--r--tests/011/mandel.txr22
-rw-r--r--tests/011/patmatch.tl619
-rw-r--r--tests/011/place.tl9
-rw-r--r--tests/011/tree-bind.tl20
-rw-r--r--tests/011/txr-case.expected1
-rw-r--r--tests/011/txr-case.txr17
10 files changed, 747 insertions, 12 deletions
diff --git a/tests/011/keyparams.tl b/tests/011/keyparams.tl
new file mode 100644
index 00000000..189081d3
--- /dev/null
+++ b/tests/011/keyparams.tl
@@ -0,0 +1,47 @@
+(load "../common")
+
+(defvarl v :v)
+(defsymacro u (identity :u))
+(defvarl x :x)
+(defvarl y :y)
+
+(mtest
+ [(lambda (:key))] nil
+ [(lambda (:key a))] :error
+ [(lambda (:key a) a) 1] 1)
+
+(mtest
+ [(lambda (:key -- (a v)) a)] :v
+ [(lambda (:key -- (a 'v)) a)] v
+ [(lambda (:key -- (a v a-p)) (list a a-p))] (:v nil)
+ [(lambda (:key -- (a 'v a-p)) (list a a-p))] (v nil))
+
+(mtest
+ [(lambda (:key -- (a v)) a) :a 1] 1
+ [(lambda (:key -- (a 'v)) a) :a 1] 1
+ [(lambda (:key -- (a v a-p)) (list a a-p)) :a 1] (1 t)
+ [(lambda (:key -- (a 'v a-p)) (list a a-p)) :a 1] (1 t))
+
+(mtest
+ [(lambda (:key -- (a v) (b u)) (list a b)) :a 1] (1 :u)
+ [(lambda (:key -- (a 'v) (b 'u)) (list a b)) :b 1] (v 1)
+ [(lambda (:key -- (a v a-p) (b u b-p)) (list a a-p b b-p)) :a 1] (1 t :u nil)
+ [(lambda (:key -- (a v a-p) (b u b-p)) (list a a-p b b-p)) :b 1] (:v nil 1 t))
+
+(test
+ [(lambda (:key -- (a v) . r) (list a r)) :a 1] (1 (:a 1)))
+
+(defun key-place (:key -- x y (s nil s-p)) ^(,x ,y ,s ,s-p))
+
+(defset key-place (:key -- x y) s
+ ^(key-place :x ,x :y ,y :s ,s))
+
+(test
+ (set (key-place :x 3 :y 4) 42) (3 4 42 t))
+
+(defmacro kp (r (:key -- (a v a-p) (b u b-p)) : ((:key -- (c x c-p) (d y d-p))))
+ ^'(r ,a ,a-p ,b ,b-p ,c ,c-p ,d ,d-p))
+
+(mtest
+ (kp :r ()) (r :v nil :u nil :x nil :y nil)
+ (kp 0 (:a 1 :b 2) (:d 3)) (r 1 t 2 t :x nil 3 t))
diff --git a/tests/011/macros-3.expected b/tests/011/macros-3.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/011/macros-3.expected
+++ /dev/null
diff --git a/tests/011/macros-3.tl b/tests/011/macros-3.tl
index bf7cf9a6..fda312da 100644
--- a/tests/011/macros-3.tl
+++ b/tests/011/macros-3.tl
@@ -10,3 +10,16 @@
(macrolet ((m (:form f) f))
(m))))))
42)
+
+(defvarl x 0)
+(defmacro mac-time-counter () (inc x))
+(defsymacro s (mac-time-counter))
+
+(mtest s 1
+ s 2
+ s 3)
+
+(test (symacrolet ((a 42))
+ (labels ()
+ a))
+ 42)
diff --git a/tests/011/macros-4.tl b/tests/011/macros-4.tl
new file mode 100644
index 00000000..440dcd9e
--- /dev/null
+++ b/tests/011/macros-4.tl
@@ -0,0 +1,11 @@
+(load "../common")
+
+(defmacro xsqrt (:match :form f)
+ (((* @exp @exp)) exp)
+ (@else f))
+
+(defmacro xexpt (:match :form f)
+ ((@exp 2) ^(* ,exp ,exp))
+ (@else f))
+
+(test (expand '(xsqrt (xexpt x 2))) x)
diff --git a/tests/011/mandel.txr b/tests/011/mandel.txr
index 8a701526..cfa24857 100644
--- a/tests/011/mandel.txr
+++ b/tests/011/mandel.txr
@@ -1,16 +1,14 @@
@(do
- (defvar x-centre -0.5)
- (defvar y-centre 0.0)
- (defvar width 4.0)
- (defvar i-max 80)
- (defvar j-max 60)
- (defvar n 100)
- (defvar r-max 2.0)
- (defvar file "mandelbrot.pgm")
- (defvar colour-max 255)
- (defvar pixel-size (/ width i-max))
- (defvar x-offset (- x-centre (* 0.5 pixel-size (+ i-max 1))))
- (defvar y-offset (+ y-centre (* 0.5 pixel-size (+ j-max 1))))
+ (defvarl x-centre -0.5)
+ (defvarl y-centre 0.0)
+ (defvarl width 4.0)
+ (defvarl i-max 80)
+ (defvarl j-max 60)
+ (defvarl n 100)
+ (defvarl r-max 2.0)
+ (defvarl pixel-size (/ width i-max))
+ (defvarl x-offset (- x-centre (* 0.5 pixel-size (+ i-max 1))))
+ (defvarl y-offset (+ y-centre (* 0.5 pixel-size (+ j-max 1))))
;; complex number library
(macro-time
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
new file mode 100644
index 00000000..6d071f3d
--- /dev/null
+++ b/tests/011/patmatch.tl
@@ -0,0 +1,619 @@
+(load "../common")
+
+(mtest
+ (if-match 1 1 'yes 'no) yes
+ (if-match 1 0 'yes 'no) no)
+
+(test (let ((sym 'a))
+ (list (if-match a sym 'yes 'no)
+ (if-match b sym 'yes 'no)))
+ (yes no))
+
+(mtest
+ (when-match @a 42 (list a)) (42)
+ (when-match (@nil) '(1) 'yes) yes
+ (when-match (@a @b @c) '(1 2 3) (list c b a)) (3 2 1)
+ (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)
+ (list a b c d)
+ :no-match)
+ :no-match)
+
+(mtest
+ (if-match (1 2 . @a) '(1 2 3 4) a) (3 4)
+ (if-match ((1 2 @a) @b) '((1 2 3) 4) (list a b)) (3 4)
+ (if-match #() #() :yes :no) :yes
+ (if-match #() #(1) :yes :no) :no
+ (if-match #((1 @a) #(3 @b)) #((1 2) #(3 4)) (list a b)) (2 4))
+
+(test (when-match @(struct time year 2021 month @m) #S(time year 2021 month 1)
+ m)
+ 1)
+
+(defstruct widget ()
+ name
+ value)
+
+(defstruct grommet ()
+ name
+ value)
+
+(vtest (append-each ((obj (list (new grommet name "foo" value :grom)
+ (new widget name "foo" value :widg))))
+ (when-match @(struct @type name "foo" value @v) obj
+ (list (list type v))))
+ ^((,(find-struct-type 'grommet) :grom)
+ (,(find-struct-type 'widget) :widg)))
+
+(mtest
+ (when-match @(as w (@a @b @c)) '(1 2 3) (list w a b c)) ((1 2 3) 1 2 3)
+ (when-match @(require (+ @a @b) (equal a b)) '(+ z z) (list a b)) (z z))
+
+(test (if-match @(require (+ @a @b) (equal a b)) '(+ y z)
+ (list a b)
+ :no-match)
+ :no-match)
+
+(test (when-match @(all (x @a @b)) '((x 1 a) (x 2 b) (x 3 c))
+ (list a b))
+ ((1 2 3) (a b c)))
+
+(test (when-match (@x @(all @x)) '(1 (1 1 1 1)) x) 1)
+
+(test (when-match (@x @(all @x)) '(1 (1 1 1 2)) x) nil)
+
+(test (when-match @(some (x @a @b)) '((y 1 a) (x 2 b) (z 3 c))
+ (list a b))
+ (2 b))
+
+(test (when-match @(coll (x @a @b)) '((y 1 a) (x 2 b) (z 3 c) (x 4 d))
+ (list a b))
+ ((2 4) (b d)))
+
+(test (if-match @(and (@x 2 3) (1 @y 3) (1 2 @z)) '(1 2 3)
+ (list x y z))
+ (1 2 3))
+
+(test (if-match @(and (@x 1) (1 @x)) '(1 1) x) 1)
+(test (if-match @(and (@x 1) (1 @x)) '(1 2) x) nil)
+
+(test (when-match @(all @(or (@x @y) @z)) '((1 2) (3 4)) (list x y z))
+ ((1 3) (2 4) (nil nil)))
+
+(test (let ((a 1) (b 2) (c 3))
+ (if-match @(or @a @b @c) 2
+ (list a b c)))
+ (1 2 3))
+
+(test (when-match @(or @(all @x)) '(1 2 3) x) (1 2 3))
+
+(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)
+
+(mtest
+ (if-match @(or (@x 3 3) (1 @x 3) (1 2 @x)) '(1 2 3) x) 2
+ (if-match @(<= 10 @a 13) 11 :yes :no) :yes
+ (when-match @(as x @(<= 10 @a 13)) 11 x) 11
+ (when-match (@(evenp) @(oddp @x)) '(2 3) x) 3
+ (when-match @(<= 1 @x 10) 4 x) 4
+ (when-match @(@d (chr-digit @c)) #\5 (list d c)) (5 #\5)
+ (when-match @(or @(require @a (oddp a)) @b @c) 2 (list a b c)) (nil 2 nil)
+ (when-match @(@x (< . @sym)) '(1 2 3) (list x sym)) (t (1 2 3))
+ (when-match @(@x (< . @sym)) '(3 2 1) (list x sym)) nil
+ (let ((x t))
+ (when-match @(@x (< . @sym)) '(1 2 3) (list x sym))) (t (1 2 3))
+ (let ((x nil))
+ (when-match @(@x (< . @sym)) '(1 2 3) (list x sym))) nil
+ (if-match (@(or @a) @a) '(1 2) a :no) :no
+ (if-match (@(and @a) @a) '(1 2) a :no) :no)
+
+
+(test
+ (collect-each ((obj (list '(1 2 3)
+ '(4 5)
+ '(3 5)
+ #S(time year 2021 month 1 day 1)
+ #(vec tor))))
+ (match-case obj
+ (@(struct time year @y) y)
+ (#(@x @y) (list x y))
+ ((@nil @nil @x) x)
+ ((4 @x) x)
+ ((@x 5) x)))
+ (3 5 3 2021 (vec tor)))
+
+(test (when-match (@(and @a @b) (x . @c)) '(1 (x 2 3 4)) c) (2 3 4))
+
+(test (when-match (@(some @a) . @b) '((1 2 3) 2) (list a b)) (1 (2)))
+
+(set *print-circle* t)
+
+(test (when-match @(as a @(some @a)) '#1=(1 2 #1# 3) :yes) :yes)
+
+(test (when-match (@a @(as a @(some @a))) '(#1=(1 2 #1# 3) #1#) :yes) :yes)
+
+(test (when-match (@a @(as a @(or x @a))) '(#1=(1 2 #1# 3) #1#) :yes) :yes)
+
+(test (when-match (@(with @a x 42) @b @c) '(1 2 3) (list a b c x))
+ (1 2 3 42))
+
+(test (let ((o 3))
+ (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)
+ (list x y)))
+ (4 3))
+
+(defstruct node ()
+ left right)
+
+(mlet ((n (lnew node left (new node left n))))
+ (test (when-match @(as x @(struct node
+ left @(struct node left @x)))
+ n :yes)
+ :yes))
+
+(test
+ (collect-each ((obj (list '(1 2 3)
+ '(4 5)
+ '(3 5)
+ '(6 2 6)
+ #(11 12)
+ #S(time year 2021 month 1 day 2)
+ #S(time year 2020 month 1 day 1)
+ #(vec tor))))
+ (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))
+ (#(@x @y) (list x y))
+ ((@x @nil @x) x)
+ ((@nil @nil @x) x)
+ ((4 @x) x)
+ ((@x 5) x)))
+ (3 5 3 6 (11 12) (2 time) (2020 1) (vec tor)))
+
+(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)
+ (42))
+
+(mtest
+ (when-match @(hash (a)) #H(() (a b)) t) t
+ (when-match @(hash (c)) #H(() (a b)) t) nil
+ (let ((x 'a)) (when-match @(hash (@x)) #H(() (a b)) t)) t
+ (let ((x 'd)) (when-match @(hash (@x)) #H(() (a b)) t)) nil
+ (when-match @(hash (@x)) #H(() (a b)) x) (a))
+
+(mtest
+ (if-match #R(10 20) 10..20 :yes :no) :yes
+ (if-match #R(10 20) #R(10 20) :yes :no) :yes
+ (if-match #R(10 20) #R(1 2) :yes :no) :no
+ (when-match #R(@a @b) 1..2 (list a b)) (1 2)
+ (when-match #R(@a 2) 1..2 a) 1
+ (when-match #R(1 @a) 1..2 a) 2
+ (when-match #R(2 @a) 1..2 a) nil
+ (when-match #R(@a 1) 1..2 a) nil)
+
+(mtest
+ (when-match @a..@b '1..2 (list a b)) (1 2)
+ (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))
+ a)
+
+(test (let ((h #H(() (a 1) (b 2))))
+ (when-match @(@y [h @x]) 'a (list x y)))
+ (a 1))
+
+(test
+ (let ((f (lambda-match
+ (() (list 0 :args))
+ ((@a) (list 1 :arg a))
+ ((@a @b) (list 2 :args a b))
+ ((@a @b . @c) (list* '> 2 :args a b c)))))
+ (list [f] [f 1] [f 1 2] [f 1 2 3]))
+ ((0 :args) (1 :arg 1) (2 :args 1 2) (> 2 :args 1 2 3)))
+
+(test
+ [(lambda-match
+ ((0 1) :zero-one)
+ ((1 0) :one-zero)
+ ((@x @y) :no-match)) 1 0]
+ :one-zero)
+
+(test
+ [(lambda-match
+ ((0 1) :zero-one)
+ ((1 0) :one-zero)
+ ((@x @y) :no-match)) 1 1]
+ :no-match)
+
+(compile-only
+ (eval-only
+ (test
+ [(lambda-match
+ ((0 1) :zero-one)
+ ((1 0) :one-zero)
+ ((@x @y) :no-match)) 1 2 3]
+ :error)))
+
+(test
+ [(lambda-match
+ ((@a @b) (list a b))
+ ((@x . @y) (list x y)))
+ 1 2 3]
+ (1 (2 3)))
+
+(test
+ [(lambda-match
+ ((@a @b) (list a b))
+ (@x x))
+ 1 2 3]
+ (1 2 3))
+
+(defun-match fib
+ ((0) 1)
+ ((1) 1)
+ ((@x) (+ (fib (pred x)) (fib (ppred x)))))
+
+(mtest
+ (fib 0) 1
+ (fib 1) 1
+ (fib 2) 2
+ (fib 3) 3
+ (fib 4) 5
+ (fib 5) 8)
+
+(defun-match ack
+ ((0 @n) (+ n 1))
+ ((@m 0) (ack (- m 1) 1))
+ ((@m @n) (ack (- m 1) (ack m (- n 1)))))
+
+(mtest
+ (ack 1 1) 3
+ (ack 2 2) 7)
+
+(defun x-x-y (list x)
+ (when-match (@x @x @y) list y))
+
+(mtest
+ (x-x-y '(1 1 2) 1) 2
+ (x-x-y '(1 2 3) 1) nil
+ (x-x-y '(1 1 2 r2) 1) nil)
+
+(test (let ((a 3) (x 0))
+ (match-case '(3 2 1)
+ ((@x 2 @b) ^(1 ,b))
+ ((@a 2 @b) ^(2 ,a))))
+ (2 3))
+
+(test
+ (let ((a 3) (x 0))
+ (labels ((local (:match)
+ ((@x 2 @b) ^(1 ,b))
+ ((@a 2 @b) ^(2 ,a))))
+ (local 3 2 1)))
+ (2 3))
+
+(test
+ (when-match @(sme (1 2) (3 4) (5 . 6) m e)
+ '(1 2 3 4 5 . 6)
+ (list m e))
+ ((3 4 5 . 6) (5 . 6)))
+
+(test
+ (when-match @(sme (1 2) (3 4) (5 . 6) m d)
+ '(1 2 abc 3 4 def 5 . 6)
+ (list m d))
+ ((3 4 def 5 . 6) (5 . 6)))
+
+(test
+ (when-match @(sme (1 2 @x . @y) (4 @z) 6)
+ '(1 2 abc 3 4 def 5 . 6)
+ (list x y z))
+ (abc (3 4 def 5 . 6) def))
+
+(mtest
+ (when-match @(sme (1 2) (2 3) (4)) '(1 2 3 4) t) nil
+ (when-match @(sme (1 2) (3 4) (4)) '(1 2 3 4) t) nil
+ (when-match @(sme (1 2) (2 3) (3 4)) '(1 2 3 4) t) nil
+ (when-match @(sme (1 2 . @x) (3 . @y) (4)) '(1 2 3 4) t) t
+ (when-match @(sme (1 2 . @x) (3 . @y) ()) '(1 2 3 4) t) t
+ (when-match @(sme (1 2 . @x) (3 . @y) ()) '(1 2 3 4 . 5) t) nil)
+
+(test (when-match @(sme (1 @y) (@z @x @y @z) (@x @y)) '(1 2 3 1 2 3 1 2)
+ (list x y z))
+ (1 2 3))
+
+(test (when-match @(and @(sme (1 @x) (3) (7) m n)
+ @(with @(coll @(oddp @y)) (ldiff m n)))
+ '(1 2 3 4 5 6 7)
+ (list x y))
+ (2 (3 5)))
+
+(test (when-match @(sme () () 5) 5 t) t)
+
+(mtest
+ (when-match @(end 3 x) 3 x) 3
+ (when-match @(end (2 @x) y) '(1 2 3) (list x y)) (3 (2 3))
+ (when-match @(end (2 . @x) y) '(1 2 . 3) (list x y)) (3 (2 . 3)))
+
+(test (when-match @(as z @(end (2 @x) y)) '(1 2 3) (list x y z))
+ (3 (2 3) (1 2 3)))
+
+(defmatch env (var :env e)
+ ^@(with ,var ',e))
+
+(test (when-match @(and @a @(env e) @b) 42
+ (list a (env-vbindings e) (lexical-var-p e 'a) (lexical-var-p e 'b) b))
+ (42 ((a . sys:special)) t nil 42))
+
+(defmatch var= (sym :env e)
+ (if (lexical-var-p e sym)
+ (with-gensyms (obj)
+ ^@(require (sys:var ,obj) (= ,sym ,obj)))
+ ^(sys:var ,sym)))
+
+(test (when-match (@(var= a) @(var= a)) '(1 1.0) a) 1)
+
+(mtest
+ (when-match `` "" t) t
+ (when-match `abc` "abc" t) t
+ (when-match `abc` "abcdef" t) nil
+ (when-match `@a` "abc" a) "abc"
+ (let ((x "foo")) (when-match `@x` "foobar" t)) nil
+ (let ((x "foo")) (when-match `@x` "foo" x)) "foo")
+
+(mtest
+ (when-match `@a@b` "abc" a) :error
+ (when-match `@nil@b` "abc" a) :error
+ (when-match `@nil@nil` "abc" a) :error
+ (when-match `@a@nil` "abc" a) :error)
+
+(mtest
+ (when-match `@a-$` "a-$" a) "a"
+ (when-match `#@a-$` "#a-$" a) "a"
+ (when-match `#@a-$` "#a-$$" a) nil
+ (when-match `#@a-$` "#a-" a) nil
+ (when-match `#@a-@b` "#a-$" (list a b)) ("a" "$")
+ (when-match `#@{a #/ab*c/}` "#abbbc" a) "abbbc"
+ (when-match `#@{a #/ab*c/}d` "#abbbcd" a) "abbbc"
+ (when-match `#@{nil #/ab*c/}` "#abbbc" t) t
+ (when-match `#@{nil #/ab*c/}d` "#abbbcd" t) t
+ (when-match `#@{a 3}@b` "#abb" a) "abb"
+ (when-match `#@{a 3}@b` "#abbbc" (list a b)) ("abb" "bc")
+ (when-match `#@{a 4}@b` "#abb" a) nil
+ (when-match `#@{a 3}` "#abb" a) "abb"
+ (when-match `#@{a 2}` "#abb" a) nil
+ (when-match `#@{a 4}` "#abb" a) nil)
+
+(let ((z 0))
+ (mtest
+ (when-match `@z#@a-$` "0#a-$" a) "a"
+ (when-match `@z#@a-$` "0#a-$$" a) nil
+ (when-match `@z#@a-$` "0#a-" a) nil
+ (when-match `@z#@a-@b` "0#a-$" (list a b)) ("a" "$")
+ (when-match `@z#@{a #/ab*c/}` "0#abbbc" a) "abbbc"
+ (when-match `@z#@{a #/ab*c/}d` "0#abbbcd" a) "abbbc"
+ (when-match `@z#@{a 3}@b` "0#abb" a) "abb"
+ (when-match `@z#@{a 3}@b` "0#abbbc" (list a b)) ("abb" "bc")
+ (when-match `@z#@{a 4}@b` "0#abb" a) nil
+ (when-match `@z#@{a 3}` "0#abb" a) "abb"
+ (when-match `@z#@{a 2}` "0#abb" a) nil
+ (when-match `@z#@{a 4}` "0#abb" a) nil))
+
+(test (when-match `#@{a 4 5}` "#abb" a) :error)
+
+(let ((b "bcd"))
+ (mtest
+ (when-match `@a@b` "abcd" a) "a"
+ (when-match `@a@{b [1..:]}` "acd" a) "a"
+ (when-match `@a@{b [1..:]}` "abcd" a) "ab"
+ (when-match `@a@{b [0..1]}` "abcd" a) nil
+ (when-match `@a@{b [0..2]}d` "abcd" a) "a"))
+
+(let ((x 123) (z 0))
+ (mtest
+ (when-match `^@{x 5}$` "^123 $" t) t
+ (when-match `^@{x -5}$` "^ 123$" t) t
+ (when-match `@x@x` "123123" t) t
+ (when-match `@x@{x [1..:]}` "12323" t) t
+ (when-match `@z^@{x 5}$` "0^123 $" t) t
+ (when-match `@z^@{x -5}$` "0^ 123$" t) t
+ (when-match `@z@x@x` "0123123" t) t
+ (when-match `@z@x@{x [1..:]}` "012323" t) t))
+
+(let ((a "$"))
+ (test (when-match `@a-@b` "$-@" b) "@"))
+
+(mtest
+ (when-match `@{a #/\d+/}-@{a #/\d+/}` "123-123" a) "123"
+ (when-match `@{a #/\d+/}-@{a #/\d+/}-` "123-123-" a) "123"
+ (when-match `@{a #/\d+/}-@{a #/\d+/}` "123-1234" a) nil
+ (when-match `@{a #/\d+/}-@{a #/\d+/}-` "123-1234-" a) nil)
+
+(test
+ (build
+ (each-match (`(@a) @b-@c` '("x"
+ ""
+ "(311) 555-5353"
+ "(604) 923-2323"
+ "133"
+ "4-5-6-7")
+ @x 1)
+ (add (list x a b c))))
+ ((3 "311" "555" "5353") (4 "604" "923" "2323")))
+
+(test
+ (append-matches ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d))
+ (@x :bar) '((1 :bar) (2 :bar) (3 :bar) (4 :foo)))
+ (list x y))
+ (1 a 3 c))
+
+(test
+ (append-matches (@x '((1) (2) (3) 4)) x)
+ (1 2 3 . 4))
+
+(test
+ (keep-matches ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d))
+ (@x :bar) '((1 :bar) (2 :bar) (3 :bar) (4 :foo)))
+ (list x y))
+ ((1 a) (3 c)))
+
+(test
+ (build
+ (each-match-product (`(@a) @b-@c` '("x"
+ ""
+ "(311) 555-5353"
+ "(604) 923-2323"
+ "133"
+ "4-5-6-7")
+ @(oddp @x) '(1 2 3))
+ (add (list x a b c))))
+ ((1 "311" "555" "5353") (3 "311" "555" "5353")
+ (1 "604" "923" "2323") (3 "604" "923" "2323")))
+
+(test
+ (append-match-products (@(oddp @x) (range 1 5)
+ @(evenp @y) (range 1 5))
+ (list x y))
+ (1 2 1 4 3 2 3 4 5 2 5 4))
+
+(test
+ (keep-match-products (@(oddp @x) (range 1 5)
+ @(evenp @y) (range 1 5))
+ (list x y))
+ ((1 2) (1 4) (3 2) (3 4) (5 2) (5 4)))
+
+(test
+ (each-match (@a '(1 2 3)) (return 42)) 42)
+
+(mtest
+ (when-match ^(,a ,b) '(1 2) (list a b)) (1 2)
+ (when-match ^(,(oddp @a) ,(evenp @b)) '(1 2) (list a b)) (1 2)
+ (when-match ^#(,a ,b) #(1 2) (list a b)) (1 2)
+ (when-match ^#S(,type year ,y) #S(time year 2021)
+ (list (struct-type-name type) y)) (time 2021)
+ (when-match ^#H(() (x ,y) (,(symbolp @y) ,datum))
+ #H(() (x k) (k 42))
+ datum) (42))
+
+(mtest
+ (when-match ^#J~a 42.0 a) 42.0
+ (when-match ^#J[~a, ~b] #J[true, false] (list a b)) (t nil)
+ (when-match ^#J{"x" : ~y, ~(symbolp @y) : ~datum}
+ #J{"x" : true, true : 42}
+ datum) (42.0)
+ (when-match ^#J{"foo" : {"x" : ~val}} #J{"foo" : {"x" : "y"}} val) "y")
+
+(test
+ (let ((a '(1 2 3 4)))
+ (build
+ (while-match @(true @x) (pop a)
+ (add (* 10 x)))))
+ (10 20 30 40))
+
+(test
+ (let ((a '(1 (2 3) 4 (5 6))))
+ (build
+ (while-match-case (pop a)
+ ((@x @y) (add :pair x y))
+ (@(numberp @x) (add :num x)))))
+ (:num 1 :pair 2 3 :num 4 :pair 5 6))
+
+(test
+ (let ((a '(1 (2 3) 4 (5 6))))
+ (build
+ (while-true-match-case (pop a)
+ ((@x @y) (add :pair x y))
+ (@(evenp @x) (add :even x))
+ (@(oddp @x) (add :odd x))
+ (@else (error "unhandled case")))))
+ (:odd 1 :pair 2 3 :even 4 :pair 5 6))
+
+(mtest
+ (match (@a @b) '(1 2) (list a b)) (1 2)
+ (match (@a @b) '(1 2 3) (list a b)) :error)
+
+(mtest
+ (match-ecase 42) :error
+ (match-ecase 42 (@a a)) 42
+ (match-ecase '(1 2) ((@a) a)) :error)
+
+(mtest
+ (match @`foo-@a` "foo-abc" a) "abc"
+ (match ^(,`foo-@a`) '("foo-abc") a) "abc"
+ (match ^#J[~`foo-@a`] #("foo-abc") a) "abc")
+
+(mtest
+ (match @(< @nil 0) -1 42) 42
+ (match @(> 0 @nil) -1 42) 42
+ (if-match @(< @nil 0) 1 :y :n) :n
+ (if-match @(< @nil 2) 1 :y :n) :y
+ (match @(@nil (< @x 0)) -1 x) -1
+ (match @(@nil (< @nil 0)) -1 t) t)
+
+(mtest
+ (match ^(foo) '(foo) t) t
+ (match ^#H() #H(() (a b)) t) t
+ (match ^#H(()) #H(() (a b)) t) t
+ (match ^#S(time) #S(time year 2023) t) t)
+
+(mtest
+ (match-cond (t)) :error
+ (match-cond (t t)) t
+ (match-cond (t t nil)) nil
+ (match-cond (t t t)) t
+ (let ((x 42))
+ (match-cond
+ (`@x-73` "73-73" :a)
+ (`@x-@y` "42-24" y))) "24"
+ (let ((x 42)
+ (y 24))
+ (match-cond
+ (`@x-24` `42-@y`))) "42-24")
+
+(mtest
+ (symacrolet ((x 3))
+ (match @x 4 x)) :error
+ (symacrolet ((x 3))
+ (match @x 3 x)) 3
+ (let ((x 3))
+ (match @x 4 x)) :error
+ (let ((x 3))
+ (match @x 3 x)) 3)
+
+(defvar dv :dv)
+(defsymacro gs :gs)
+
+(mtest
+ (match @dv 0 dv) :error
+ (match @dv :dv dv) :dv
+ (match @gs 0 gs) :error
+ (match @gs :gs gs) :gs)
+
+(mtest
+ (match @(end @x) '(1 . 2) x) 2
+ (match @(end @(evenp @x)) '(1 . 2) x) 2
+ (match @(end (@z . @x)) '(1 . 2) (list z x)) (1 2)
+ (match @(end (@z . @(evenp @x))) '(1 . 2) (list z x)) (1 2))
+
+(mtest
+ (match @(sme (@a) (@b) @x) '(0 1 . 2) (list a b x)) (0 1 2)
+ (match @(sme (@a) (@b) @(evenp @x)) '(0 1 . 2) (list a b x)) (0 1 2))
+
+(compile-only
+ (eval-only
+ (with-compile-opts (nil unused)
+ (compile-file (base-name *load-path*) "temp.tlo"))
+ (remove-path "temp.tlo")))
diff --git a/tests/011/place.tl b/tests/011/place.tl
new file mode 100644
index 00000000..eb0dcb46
--- /dev/null
+++ b/tests/011/place.tl
@@ -0,0 +1,9 @@
+(load "../common")
+
+(defvar h (hash))
+
+(mtest
+ (let ((x 0)) (ensure (gethash h (pinc x)) "a") x) 1
+ [h 0] "a"
+ (let ((x 0)) (ensure (gethash h 0) (pinc x)) x) 0
+ [h 0] "a")
diff --git a/tests/011/tree-bind.tl b/tests/011/tree-bind.tl
new file mode 100644
index 00000000..ac55cc07
--- /dev/null
+++ b/tests/011/tree-bind.tl
@@ -0,0 +1,20 @@
+(load "../common")
+
+(mtest
+ (tree-bind b '(1 2) b) (1 2)
+ (tree-bind (t b) '(1 2) b) 2
+ (tree-bind (t . b) '(1 2) b) (2)
+ (tree-bind (b t) '(1 2) b) 1
+ (tree-bind (b . t) '(1 2) b) 1
+ (tree-bind t '(1 2) 3) 3
+ (tree-bind (t : b) '(1 2) b) 2
+ (tree-bind (b : t) '(1) b) 1
+ (tree-bind (b : (t 2)) '(1) b) 1
+ (tree-bind (#:b : (a 2 t)) '(1) a) 2
+ (let ((i 0)) (tree-bind (b : (t (inc i) t)) '(1) (cons i b))) (1 . 1)
+ (let ((i 0)) (tree-bind (b : (t (inc i) t)) '(1 2) (cons i b))) (0 . 1))
+
+(compile-only
+ (eval-only
+ (compile-file (base-name *load-path*) "temp.tlo")
+ (remove-path "temp.tlo")))
diff --git a/tests/011/txr-case.expected b/tests/011/txr-case.expected
index 4af473e5..e7582780 100644
--- a/tests/011/txr-case.expected
+++ b/tests/011/txr-case.expected
@@ -2,3 +2,4 @@ no match for 09-10-20
match: year 2009, month 10, day 20
no match for July-15-2014
no match for foo
+match: year 2021, month 06, day 16, foo:bar
diff --git a/tests/011/txr-case.txr b/tests/011/txr-case.txr
index 1aa80478..d6d8d788 100644
--- a/tests/011/txr-case.txr
+++ b/tests/011/txr-case.txr
@@ -1,4 +1,5 @@
@(load `@{stdlib}txr-case`)
+@(include "../common")
@(define date (year month day))
@{year /\d\d\d\d/}-@{month /\d\d/}-@{day /\d\d/}
@(end)
@@ -7,3 +8,19 @@
(txr-if date (y m d) date
(put-line `match: year @y, month @m, day @d`)
(put-line `no match for @date`))))
+@(define notmatch ())
+blah
+@(end)
+@(define stuff (year month day a b))
+@(date year month day)
+@a @b
+@(end)
+@(do (txr-case (make-strlist-input-stream '("2021-06-16"
+ "foo bar"))
+
+ (notmatch () (put-line "notexpected"))
+ (stuff (y m d a b) (put-line `match: year @y, month @m, day @d, @a:@b`)))
+ (mtest
+ (match-fboundp 'notmatch) t
+ (match-fboundp 'stuff) t
+ (match-fboundp 'xyzzy) nil))
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-18 16:07:36 +0000