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