1;;;; syncase.test --- test suite for (ice-9 syncase)            -*- scheme -*-
2;;;;
3;;;; 	Copyright (C) 2001, 2006, 2009, 2010, 2011, 2013, 2015 Free Software Foundation, Inc.
4;;;;
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.
9;;;;
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.
14;;;;
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
18
19;; These tests are in a module so that the syntax transformer does not
20;; affect code outside of this file.
21;;
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)))
27
28(define-syntax plus
29  (syntax-rules ()
30    ((plus x ...) (+ x ...))))
31
32(pass-if "basic syncase macro"
33  (= (plus 1 2 3) (+ 1 2 3)))
34
35(pass-if "@ works with syncase"
36  (eq? run-test (@ (test-suite lib) run-test)))
37
38(define-syntax string-let
39  (lambda (stx)
40    (syntax-case stx ()
41      ((_ id body ...)
42       #`(let ((id #,(symbol->string
43                      (syntax->datum #'id))))
44           body ...)))))
45
46(pass-if "macro using quasisyntax"
47  (equal? (string-let foo (list foo foo))
48          '("foo" "foo")))
49
50(define-syntax string-case
51  (syntax-rules (else)
52    ((string-case expr ((string ...) clause-body ...) ... (else else-body ...))
53     (let ((value expr))
54       (cond ((member value '(string ...) string=?)
55              clause-body ...)
56             ...
57             (else
58              else-body ...))))
59    ((string-case expr ((string ...) clause-body ...) ...)
60     (let ((value expr))
61       (cond ((member value '(string ...) string=?)
62              clause-body ...)
63             ...)))))
64
65(define-syntax alist
66  (syntax-rules (tail)
67    ((alist ((key val) ... (tail expr)))
68     (cons* '(key . val) ... expr))
69    ((alist ((key val) ...))
70     (list '(key . val) ...))))
71
72(with-test-prefix "with-syntax"
73  (pass-if "definitions allowed in body"
74    (equal? (with-syntax ((a 23))
75              (define b #'a)
76              (syntax->datum b))
77            23)))
78
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))
83              'foo))
84    (pass-if "tail invocation"
85      (equal? (string-case "foo" (("bar") 'bar) (else 'else))
86              '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))))))
94
95(with-test-prefix "serializable labels and marks"
96  (compile '(begin
97              (define-syntax duplicate-macro
98                (syntax-rules ()
99                  ((_ new-name old-name)
100                   (define-syntax new-name
101                     (syntax-rules ()
102                       ((_ . vals)
103                        (letrec-syntax ((apply (syntax-rules ()
104                                                 ((_ macro args)
105                                                  (macro . args)))))
106                          (apply old-name vals))))))))
107
108              (define-syntax kwote
109                (syntax-rules ()
110                  ((_ arg1) 'arg1)))
111
112              (duplicate-macro kwote* kwote))
113           #:env (current-module))
114  (pass-if "compiled macro-generating macro works"
115    (eq? (eval '(kwote* foo) (current-module))
116         'foo)))
117
118(with-test-prefix "changes to expansion environment"
119  (pass-if "expander detects changes to current-module with @@ @@"
120    (compile '(begin
121                (define-module (new-module))
122                (@@ @@ (new-module)
123                       (define-syntax new-module-macro
124                         (lambda (stx)
125                           (syntax-case stx ()
126                             ((_ arg) (syntax arg))))))
127                (@@ @@ (new-module)
128                       (new-module-macro #t)))
129             #:env (current-module))))
130
131(define-module (test-suite test-syncase-2)
132  #:export (make-the-macro))
133
134(define (hello)
135  'hello)
136
137(define-syntax make-the-macro
138  (syntax-rules ()
139    ((_ name)
140     (define-syntax name
141       (syntax-rules ()
142         ((_) (hello)))))))
143
144(define-module (test-suite test-syncase)) ;; back to main module
145(use-modules (test-suite test-syncase-2))
146
147(make-the-macro foo)
148
149(with-test-prefix "macro-generating macro"
150  (pass-if "module hygiene"
151    (eq? (foo) 'hello)))
152
153(pass-if "_ is a placeholder"
154  (equal? (eval '(begin
155                   (define-syntax ciao
156                     (lambda (stx)
157                       (syntax-case stx ()
158                         ((_ _)
159                          "ciao"))))
160                   (ciao 1))
161                (current-module))
162          "ciao"))
163
164(define qux 30)
165
166(with-test-prefix "identifier-syntax"
167
168  (pass-if "global reference"
169    (let-syntax ((baz (identifier-syntax qux)))
170      (equal? baz qux)))
171
172  (pass-if "lexical hygienic reference"
173    (let-syntax ((baz (identifier-syntax qux)))
174      (let ((qux 20))
175        (equal? (+ baz qux)
176                50))))
177
178  (pass-if "lexical hygienic reference (bound)"
179    (let ((qux 20))
180      (let-syntax ((baz (identifier-syntax qux)))
181        (equal? (+ baz qux)
182                40))))
183
184  (pass-if "global reference (settable)"
185    (let-syntax ((baz (identifier-syntax
186                       (id qux)
187                       ((set! id expr) (set! qux expr)))))
188      (equal? baz qux)))
189
190  (pass-if "lexical hygienic reference (settable)"
191    (let-syntax ((baz (identifier-syntax
192                       (id qux)
193                       ((set! id expr) (set! qux expr)))))
194      (let ((qux 20))
195        (equal? (+ baz qux)
196                50))))
197
198  (pass-if "lexical hygienic reference (bound, settable)"
199    (let ((qux 20))
200      (let-syntax ((baz (identifier-syntax
201                         (id qux)
202                         ((set! id expr) (set! qux expr)))))
203        (equal? (+ baz qux)
204                40))))
205
206  (pass-if "global set!"
207    (let-syntax ((baz (identifier-syntax
208                       (id qux)
209                       ((set! id expr) (set! qux expr)))))
210      (set! baz 10)
211      (equal? (+ baz qux) 20)))
212
213  (pass-if "lexical hygienic set!"
214    (let-syntax ((baz (identifier-syntax
215                       (id qux)
216                       ((set! id expr) (set! qux expr)))))
217      (and (let ((qux 20))
218             (set! baz 5)
219             (equal? (+ baz qux)
220                     25))
221           (equal? qux 5))))
222
223  (pass-if "lexical hygienic set! (bound)"
224    (let ((qux 20))
225      (let-syntax ((baz (identifier-syntax
226                         (id qux)
227                         ((set! id expr) (set! qux expr)))))
228        (set! baz 50)
229        (equal? (+ baz qux)
230                100)))))
231
232(with-test-prefix "top-level expansions"
233  (pass-if "syntax definitions expanded before other expressions"
234    (eval '(begin
235             (define even?
236               (lambda (x)
237                 (or (= x 0) (odd? (- x 1)))))
238             (define-syntax odd?
239               (syntax-rules ()
240                 ((odd? x) (not (even? x)))))
241             (even? 10))
242          (current-module))))
243
244(define-module (test-suite test-syncase-3)
245  #:autoload (test-syncase-3-does-not-exist) (baz))
246
247(define-module (test-suite test-syncase)) ;; back to main module
248
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)))))
253
254(use-modules (system syntax))
255
256(with-test-prefix "syntax-local-binding"
257  (define-syntax syntax-type
258    (lambda (x)
259      (syntax-case x ()
260        ((_ id resolve?)
261         (call-with-values
262             (lambda ()
263               (syntax-local-binding
264                #'id
265                #:resolve-syntax-parameters? (syntax->datum #'resolve?)))
266           (lambda (type value)
267             (with-syntax ((type (datum->syntax #'id type)))
268               #''type)))))))
269
270  (define-syntax-parameter foo
271    (syntax-rules ()))
272
273  (pass-if "syntax-parameters (resolved)"
274    (equal? (syntax-type foo #t) 'macro))
275
276  (pass-if "syntax-parameters (unresolved)"
277    (equal? (syntax-type foo #f) 'syntax-parameter)))
278
279;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
280(define-syntax pass-if-syntax-error
281  (syntax-rules ()
282    ((_ name pat exp)
283     (pass-if name
284       (catch 'syntax-error
285         (lambda () exp (error "expected syntax-error exception"))
286         (lambda (k who what where form . maybe-subform)
287           (if (if (pair? pat)
288                   (and (eq? who (car pat))
289                        (string-match (cdr pat) what))
290                   (string-match pat what))
291               #t
292               (error "unexpected syntax-error exception" what pat))))))))
293
294(with-test-prefix "primitives"
295  (pass-if-syntax-error "primref in default module"
296    "failed to match"
297    (macroexpand '(@@ primitive cons)))
298
299  (pass-if-syntax-error "primcall in default module"
300    "failed to match"
301    (macroexpand '((@@ primitive cons) 1 2)))
302
303  (pass-if-equal "primcall in (guile)"
304      '(1 . 2)
305      (@@ @@ (guile) ((@@ primitive cons) 1 2)))
306
307  (pass-if-syntax-error "primref in (guile)"
308    "not in operator position"
309    (macroexpand '(@@ @@ (guile) (@@ primitive cons)))))
310
311(pass-if "infinite loop bug"
312  (begin
313    (macroexpand
314     '(let-syntax
315          ((define-foo
316             (syntax-rules ()
317               ((define-foo a b)
318                (begin
319                  (define a '())
320                  ;; Oddly, the "*" in the define* seems to be
321                  ;; important in triggering this bug.
322                  (define* (b) (set! a a)))))))
323        (define-foo a c)))
324    #t))
325