1;; -*- coding: utf-8 -*-
2#!compatible
3
4(import (rnrs)
5	(match)
6	(srfi :64 testing))
7
8(define-record-type employee
9  (fields name title))
10
11(test-begin "match test")
12
13(test-assert "match-1" (let ((ls (list 1 2 3))) (match ls ((1 2 3) #t))))
14(test-equal "match-bind"
15	    2
16	    (match (list 1 2 3)
17	      ((a b c) b)))
18(test-equal "match-bind 2"
19	    2
20	    (match (list 1 2 1)
21	      ((a a b) 1)
22	      ((a b a) 2)))
23
24(test-equal "match-_"
25	    1
26	    (match (list 1 2 1) ((_ _ b) 1) ((a b a) 2)))
27(test-equal "'a"
28	    2
29	    (match 'a ('b 1) ('a 2)))
30(test-equal "match ellipsis"
31	    '(#t #t #t)
32	    (list (match (list 1 2) ((1 2 3 ...) #t))
33		  (match (list 1 2 3) ((1 2 3 ...) #t))
34		  (match (list 1 2 3 3 3) ((1 2 3 ...) #t))))
35(test-equal "match ellipsis 2"
36	    '(() (3) (3 4 5))
37	    (list (match (list 1 2) ((a b c ...) c))
38		  (match (list 1 2 3) ((a b c ...) c))
39		  (match (list 1 2 3 4 5) ((a b c ...) c))))
40
41(test-equal "match ellipsis 3"
42	    '(() (3) (3 4 5))
43	    (list (match (list 1 2 3 4) ((a b c ... d e) c))
44		  (match (list 1 2 3 4 5) ((a b c ... d e) c))
45		  (match (list 1 2 3 4 5 6 7) ((a b c ... d e) c))))
46
47(test-equal "match ..1"
48	    '(#t (3))
49	    (list (guard (e ((error? e))
50			    (else #f))
51		    (match (list 1 2) ((a b c ..1) c)))
52		  (match (list 1 2 3) ((a b c ..1) c))))
53
54(test-equal "match and"
55	    '(#t 1 1)
56	    (list (match 1 ((and) #t))
57		  (match 1 ((and x) x))
58		  (match 1 ((and x 1) x))))
59
60(test-equal "match or"
61	    '(#f 1 1)
62	    (list (match 1 ((or) #t) (else #f))
63		  (match 1 ((or x) x))
64		  (match 1 ((or x 1) x))))
65
66(test-assert "match not" (match 1 ((not 2) #t)))
67(test-equal "match pred"
68	    1
69	    (match 1 ((? odd? x) x)))
70(test-equal "match ="
71	    (list 1 2)
72	    (list (match '(1 . 2) ((= car x) x))
73		  (match 4 ((= sqrt x) x))))
74;; ditto
75(test-equal "match $"
76	    (list "Doctor" "Bob")
77	    (match (make-employee "Bob" "Doctor")
78	      (($ employee n t) (list t n))))
79
80(test-equal "match set!"
81	    (list '(1 . 3) 2)
82	    (list (let ((x (cons 1 2))) (match x ((1 . (set! s)) (s 3) x)))
83		  (match '(1 . 2) ((1 . (get! g)) (g)))))
84
85(test-equal "match ***"
86	    (list '(a a a)
87		  '(a c f))
88	    (list (match '(a (a (a b))) ((x *** 'b) x))
89		  (match '(a (b) (c (d e) (f g))) ((x *** 'g) x))))
90
91;; on bug-guile.gnu.org
92;; bug#22925: ice-9/match named match-let is not working
93(test-equal 6 (match-let loop (((x . rest) '(1 2 3))
94			       (sum 0))
95		(let ((sum (+ x sum)))
96		  (if (null? rest)
97		      sum
98		      (loop rest sum)))))
99
100(test-end)
101