1 ;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*-
3 ;;;; Copyright (C) 2001, 2006, 2009, 2010, 2011, 2013 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 ;; These tests are in a module so that the syntax transformer does not
20 ;; affect code outside of this file.
22 (define-module (test-suite test-syncase)
23 #:use-module (test-suite lib)
24 #:use-module (system base compile)
25 #:use-module (ice-9 regex)
26 #:use-module ((srfi srfi-1) :select (member)))
30 ((plus x ...) (+ x ...))))
32 (pass-if "basic syncase macro"
33 (= (plus 1 2 3) (+ 1 2 3)))
35 (pass-if "@ works with syncase"
36 (eq? run-test (@ (test-suite lib) run-test)))
38 (define-syntax string-let
42 #`(let ((id #,(symbol->string
43 (syntax->datum #'id))))
46 (pass-if "macro using quasisyntax"
47 (equal? (string-let foo (list foo foo))
50 (define-syntax string-case
52 ((string-case expr ((string ...) clause-body ...) ... (else else-body ...))
54 (cond ((member value '(string ...) string=?)
59 ((string-case expr ((string ...) clause-body ...) ...)
61 (cond ((member value '(string ...) string=?)
67 ((alist ((key val) ... (tail expr)))
68 (cons* '(key . val) ... expr))
69 ((alist ((key val) ...))
70 (list '(key . val) ...))))
72 (with-test-prefix "with-syntax"
73 (pass-if "definitions allowed in body"
74 (equal? (with-syntax ((a 23))
79 (with-test-prefix "tail patterns"
80 (with-test-prefix "at the outermost level"
81 (pass-if "non-tail invocation"
82 (equal? (string-case "foo" (("foo") 'foo))
84 (pass-if "tail invocation"
85 (equal? (string-case "foo" (("bar") 'bar) (else 'else))
87 (with-test-prefix "at a nested level"
88 (pass-if "non-tail invocation"
89 (equal? (alist ((a 1) (b 2) (c 3)))
90 '((a . 1) (b . 2) (c . 3))))
91 (pass-if "tail invocation"
92 (equal? (alist ((foo 42) (tail '((bar . 66)))))
93 '((foo . 42) (bar . 66))))))
95 (with-test-prefix "serializable labels and marks"
97 (define-syntax duplicate-macro
99 ((_ new-name old-name)
100 (define-syntax new-name
103 (letrec-syntax ((apply (syntax-rules ()
106 (apply old-name vals))))))))
112 (duplicate-macro kwote* kwote))
113 #:env (current-module))
114 (pass-if "compiled macro-generating macro works"
115 (eq? (eval '(kwote* foo) (current-module))
118 (with-test-prefix "changes to expansion environment"
119 (pass-if "expander detects changes to current-module with @@ @@"
121 (define-module (new-module))
123 (define-syntax new-module-macro
126 ((_ arg) (syntax arg))))))
128 (new-module-macro #t)))
129 #:env (current-module))))
131 (define-module (test-suite test-syncase-2)
132 #:export (make-the-macro))
137 (define-syntax make-the-macro
144 (define-module (test-suite test-syncase)) ;; back to main module
145 (use-modules (test-suite test-syncase-2))
149 (with-test-prefix "macro-generating macro"
150 (pass-if "module hygiene"
153 (pass-if "_ is a placeholder"
154 (equal? (eval '(begin
166 (with-test-prefix "identifier-syntax"
168 (pass-if "global reference"
169 (let-syntax ((baz (identifier-syntax qux)))
172 (pass-if "lexical hygienic reference"
173 (let-syntax ((baz (identifier-syntax qux)))
178 (pass-if "lexical hygienic reference (bound)"
180 (let-syntax ((baz (identifier-syntax qux)))
184 (pass-if "global reference (settable)"
185 (let-syntax ((baz (identifier-syntax
187 ((set! id expr) (set! qux expr)))))
190 (pass-if "lexical hygienic reference (settable)"
191 (let-syntax ((baz (identifier-syntax
193 ((set! id expr) (set! qux expr)))))
198 (pass-if "lexical hygienic reference (bound, settable)"
200 (let-syntax ((baz (identifier-syntax
202 ((set! id expr) (set! qux expr)))))
206 (pass-if "global set!"
207 (let-syntax ((baz (identifier-syntax
209 ((set! id expr) (set! qux expr)))))
211 (equal? (+ baz qux) 20)))
213 (pass-if "lexical hygienic set!"
214 (let-syntax ((baz (identifier-syntax
216 ((set! id expr) (set! qux expr)))))
223 (pass-if "lexical hygienic set! (bound)"
225 (let-syntax ((baz (identifier-syntax
227 ((set! id expr) (set! qux expr)))))
232 (with-test-prefix "top-level expansions"
233 (pass-if "syntax definitions expanded before other expressions"
237 (or (= x 0) (odd? (- x 1)))))
240 ((odd? x) (not (even? x)))))
244 (define-module (test-suite test-syncase-3)
245 #:autoload (test-syncase-3-does-not-exist) (baz))
247 (define-module (test-suite test-syncase)) ;; back to main module
249 (pass-if "missing autoloads do not foil psyntax"
250 (parameterize ((current-warning-port (%make-void-port "w")))
251 (eval '(if #f (baz) #t)
252 (resolve-module '(test-suite test-syncase-3)))))
254 (use-modules (system syntax))
256 (with-test-prefix "syntax-local-binding"
257 (define-syntax syntax-type
263 (syntax-local-binding
265 #:resolve-syntax-parameters? (syntax->datum #'resolve?)))
267 (with-syntax ((type (datum->syntax #'id type)))
270 (define-syntax-parameter foo
273 (pass-if "syntax-parameters (resolved)"
274 (equal? (syntax-type foo #t) 'macro))
276 (pass-if "syntax-parameters (unresolved)"
277 (equal? (syntax-type foo #f) 'syntax-parameter)))
279 ;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
280 (define-syntax pass-if-syntax-error
285 (lambda () exp (error "expected syntax-error exception"))
286 (lambda (k who what where form . maybe-subform)
288 (and (eq? who (car pat))
289 (string-match (cdr pat) what))
290 (string-match pat what))
292 (error "unexpected syntax-error exception" what pat))))))))
294 (with-test-prefix "primitives"
295 (pass-if-syntax-error "primref in default module"
297 (macroexpand '(@@ primitive cons)))
299 (pass-if-syntax-error "primcall in default module"
301 (macroexpand '((@@ primitive cons) 1 2)))
303 (pass-if-equal "primcall in (guile)"
305 (@@ @@ (guile) ((@@ primitive cons) 1 2)))
307 (pass-if-syntax-error "primref in (guile)"
308 "not in operator position"
309 (macroexpand '(@@ @@ (guile) (@@ primitive cons)))))