1 ;;;; match.test --- (ice-9 match) -*- mode: scheme; coding: utf-8; -*-
3 ;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (define-module (test-match)
20 #:use-module (ice-9 match)
21 #:use-module (srfi srfi-9)
22 #:use-module (test-suite lib))
24 (define exception:match-error
25 (cons 'match-error "^.*$"))
27 (define-record-type rtd-2-slots
28 (make-2-slot-record a b)
33 (define-record-type rtd-3-slots
34 (make-3-slot-record a b c)
41 (with-test-prefix "matches"
44 (match "hello" (_ #t)))
47 (match 'foo ('foo #t)))
50 (match "bar" ("bar" #t)))
59 (match '(a b c) ('(a b c) #t)))
63 (('a (and (? odd?) one) (? even?))
70 (equal? (list x y z) lst)))))
72 (pass-if "list rest..."
76 (and (eq? x 'a) (equal? rest '(b c)))))))
78 (pass-if "list . rest"
82 (and (eq? x 'a) (equal? rest '(b c)))))))
87 (equal? x '(a b c)))))
89 (pass-if "list ..1, with predicate"
91 (((and x (? symbol?)) ..1)
92 (equal? x '(a b c)))))
94 (pass-if "list ..1, nested"
97 (equal? x '((1 2) (3 4))))))
100 (let ((tree '(one (two 2) (three 3 (and 4 (and 5))))))
102 (('one ('two x) ('three y ('and z '(and 5))))
103 (equal? (list x y z) '(2 3 4))))))
105 (pass-if "and, unique names"
109 (equal? 3 (+ a b))))))
111 (pass-if "and, same names"
115 (equal? 3 (+ a b))))))
117 (with-test-prefix "records"
119 (pass-if "all slots, bind"
120 (let ((r (make-3-slot-record 1 2 3)))
122 (($ rtd-3-slots a b c)
123 (equal? (list a b c) '(1 2 3))))))
125 (pass-if "all slots, literals"
126 (let ((r (make-3-slot-record 1 2 3)))
128 (($ rtd-3-slots 1 2 3)
132 (let ((r (make-3-slot-record 1 2 3)))
135 (equal? (list x y) '(1 2))))))
137 (pass-if "RTD correctly checked"
138 (let ((r (make-2-slot-record 1 2)))
143 (equal? (list a b) '(1 2))))))
146 (match (make-2-slot-record 1 2)
147 (($ rtd-2-slots (get! first) (get! second))
148 (equal? (list (first) (second)) '(1 2)))))
151 (let ((r (make-2-slot-record 1 2)))
153 (($ rtd-2-slots (set! set-first!) (set! set-second!))
156 (equal? (list (slot-first r) (slot-second r))
160 (with-test-prefix "doesn't match"
162 (pass-if-exception "tree"
163 exception:match-error
167 (pass-if-exception "list ..1"
168 exception:match-error
172 (pass-if-exception "list ..1, with predicate"
173 exception:match-error
175 (((and x (? symbol?)) ..1)
176 (equal? x '(a b c)))))
178 (with-test-prefix "records"
180 (pass-if "not a record"
185 (pass-if-exception "too many slots"
186 exception:out-of-range
187 (let ((r (make-3-slot-record 1 2 3)))
189 (($ rtd-3-slots a b c d)
194 ;;; Upstream tests, from Chibi-Scheme (3-clause BSD license).
197 (let-syntax ((load (syntax-rules ()
199 (test (syntax-rules ()
200 ((_ name expected expr)
202 (equal? expected expr)))))
203 (test-begin (syntax-rules ()
205 (test-end (syntax-rules ()
207 (with-test-prefix "upstream tests"
208 (include-from-path "tests/match.test.upstream")))