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