1;; 2;; testing macro expansion 3;; 4 5(use gauche.test) 6 7(test-start "macro") 8 9;; strip off syntactic information from identifiers in the macro output. 10(define (unident form) 11 (cond 12 ((identifier? form) (identifier->symbol form)) 13 ((pair? form) (cons (unident (car form)) (unident (cdr form)))) 14 ((vector? form) 15 (list->vector (map unident (vector->list form)))) 16 (else form))) 17 18(define-macro (test-macro msg expect form) 19 `(test ,msg ',expect (lambda () (unident (%macroexpand ,form))))) 20 21;;---------------------------------------------------------------------- 22;; 23 24(test-section "ER macro basics") 25 26(define-syntax er-when 27 (er-macro-transformer 28 (^[f r c] 29 (let ([test (cadr f)] 30 [exprs (cddr f)]) 31 `(,(r 'if) ,test (,(r 'begin) ,@exprs)))))) 32 33(test "when - basic" #t (^[] (let ((x #f)) (er-when #t (set! x #t)) x))) 34(test "when - basic" #f (^[] (let ((x #f)) (er-when #f (set! x #t)) x))) 35 36(test "when - hygene" 3 37 (^[] (let ([if list] 38 [begin list]) 39 (er-when #t 1 2 3)))) 40 41(define-syntax er-aif 42 (er-macro-transformer 43 (^[f r c] 44 (let ([test (cadr f)] 45 [then (caddr f)] 46 [else (cadddr f)]) 47 `(,(r 'let) ((it ,test)) 48 (,(r 'if) it ,then ,else)))))) 49 50(test "aif - basic" 4 (^[] (er-aif (+ 1 2) (+ it 1) #f))) 51(test "aif - basic" 5 (^[] (let ((it 999)) (er-aif (+ 1 2) (+ it 2) #f)))) 52 53(test "aif - hygene" 6 54 (^[] (let ((it 999) 55 (let list)) 56 (er-aif (+ 1 2) (+ it 3) #f)))) 57(test "aif - nesting" #t 58 (^[] (let ([it 999]) 59 (er-aif (+ 1 2) (er-aif (odd? it) it #f) #f)))) 60 61(test-section "ER macro local scope") 62 63(let ([if list]) 64 (let-syntax ([fake-if (er-macro-transformer 65 (^[f r c] `(,(r 'if) ,@(cdr f))))]) 66 (test "fake-if" '(1 2 3) (^[] (fake-if 1 2 3))) 67 (let ([if +]) 68 (test "fake-if" '(4 5 6) (^[] (fake-if 4 5 6)))))) 69 70(test-section "ER compare literals") 71 72;; from Clinger "Hygienic Macros Through Explicit Renaming" 73(define-syntax er-cond 74 (er-macro-transformer 75 (^[f r c] 76 (let1 clauses (cdr f) 77 (if (null? clauses) 78 `(,(r 'quote) ,(r 'unspecified)) 79 (let* ([first (car clauses)] 80 [rest (cdr clauses)] 81 [test (car first)]) 82 (cond [(and (identifier? test) 83 (c test (r 'else))) 84 `(,(r 'begin) ,@(cdr first))] 85 [else `(,(r 'if) ,test 86 (,(r 'begin) ,@(cdr first)) 87 (er-cond ,@rest))]))))))) 88 89(define (er-cond-tester1 x) 90 (er-cond [(odd? x) 'odd] [else 'even])) 91 92(test "er-cond 1" '(even odd) 93 (^[] (list (er-cond-tester1 0) (er-cond-tester1 1)))) 94 95(let ([else #f]) 96 (define (er-cond-tester2 x) 97 (er-cond [(odd? x) 'odd] [else 'even])) 98 (test "er-cond 2" '(unspecified odd) 99 (^[] (list (er-cond-tester2 0) (er-cond-tester2 1))))) 100 101(define-module er-test-mod 102 (export er-cond2) 103 (define-syntax er-cond2 104 (er-macro-transformer 105 (^[f r c] 106 (let1 clauses (cdr f) 107 (if (null? clauses) 108 `(,(r 'quote) ,(r 'unspecified)) 109 (let* ([first (car clauses)] 110 [rest (cdr clauses)] 111 [test (car first)]) 112 (cond [(and (identifier? test) 113 (c test (r 'else))) 114 `(,(r 'begin) ,@(cdr first))] 115 [else `(,(r 'if) ,test 116 (,(r 'begin) ,@(cdr first)) 117 (er-cond2 ,@rest))])))))))) 118 119(define-module er-test-mod2 120 (use gauche.test) 121 (import er-test-mod) 122 (define (er-cond-tester1 x) 123 (er-cond2 [(odd? x) 'odd] [else 'even])) 124 (test "er-cond (cross-module)" '(even odd) 125 (^[] (list (er-cond-tester1 0) (er-cond-tester1 1))))) 126 127;; Introducing local bindings 128(let ((x 3)) 129 (let-syntax ([foo (er-macro-transformer 130 (^[f r c] 131 (let1 body (cdr f) 132 `(,(r 'let) ([,(r 'x) (,(r '+) ,(r 'x) 2)]) 133 (,(r '+) ,(r 'x) ,@body)))))]) 134 (let ((x -1)) 135 (test* "er-macro introducing local bindings" 4 136 (foo x))))) 137 138;; er-macro and nested identifier 139;; cf. http://saito.hatenablog.jp/entry/2014/11/18/233209 140(define (er-test-traverse proc obj) 141 (let loop ((obj obj)) 142 (cond [(identifier? obj) (proc obj)] 143 [(pair? obj) (cons (loop (car obj)) (loop (cdr obj)))] 144 [(vector? obj) (vector-map loop obj)] 145 [else obj]))) 146 147(define-syntax er-test-let/scope 148 (er-macro-transformer 149 (lambda (form rename _) 150 (let ([scope (cadr form)] 151 [body (cddr form)]) 152 `(let-syntax ((,scope 153 (,(rename 'er-macro-transformer) 154 (,(rename 'lambda) (f r _) 155 (,(rename 'let) ((form2 (,(rename 'cdr) f))) 156 (,(rename 'cons) 157 ',(rename 'begin) 158 (,(rename 'er-test-traverse) r form2))))))) 159 ,@body))))) 160 161(test "er-macro and nested identifier" 162 '(2 2 3 4) 163 (lambda () 164 (let ([x 1]) 165 (er-test-let/scope scope-1 166 (let ([x 2]) 167 (er-test-let/scope scope-2 168 (let ([x 3]) 169 (er-test-let/scope scope-1 170 (let ([x 4]) 171 (list (scope-2 (scope-1 x)) 172 (scope-2 x) 173 (scope-1 x) 174 x)))))))))) 175 176;; passing form rename procedure 177(let ([a 1] [b 2]) 178 (let-syntax ([foo (er-macro-transformer 179 (lambda (f r c) 180 (r '(cons (list a b) `#(,a ,b)))))]) 181 (let ([a -1] [b -2] [list *]) 182 (test* "list arg for rename procedure" 183 '((1 2) . #(1 2)) 184 (foo))))) 185 186;; er-macro and with-module 187;; cf. https://github.com/shirok/Gauche/issues/250 188(define er-macro-scope-test-a 'a) 189 190(define-module er-macro-test-1 191 (define er-macro-scope-test-a 'b)) 192 193(with-module er-macro-test-1 194 (define-syntax er-macro-test-x 195 (er-macro-transformer 196 (^[f r c] (r 'er-macro-scope-test-a))))) 197 198(test* "er-macro and with-module" 'b 199 ((with-module er-macro-test-1 er-macro-test-x))) 200 201;; er-macro and eval 202(test* "er-macro and eval" 'b 203 (eval '(let-syntax ((m (er-macro-transformer 204 (^[f r c] (r 'er-macro-scope-test-a))))) 205 (m)) 206 (find-module 'er-macro-test-1))) 207 208;; quasirename 209(let ((unquote list) 210 (x 1) 211 (y 2)) 212 (let-syntax ([foo (er-macro-transformer 213 (^[f r c] 214 (let ([a (cadr f)] 215 [b (caddr f)] 216 [all (cdr f)]) 217 (quasirename r 218 `(list x ,a y ,b ,@all 219 '#(x ,a y ,b) ,@(reverse all))))))]) 220 (let ((list vector) 221 (x 10) 222 (y 20)) 223 (test* "er-macro and quasirename" 224 '(1 3 2 4 3 4 #(x 3 y 4) 4 3) 225 (foo 3 4))))) 226 227;; nested quasirename 228(let () 229 (define (add-prefix p) 230 (^s (symbol-append p s))) 231 (define a 1) 232 (define b 2) 233 (define c 3) 234 (test* "nested quasirename" 235 '(p:quasirename p:x 236 `(p:a ,p:b ,(p:quote 3) ,d)) 237 (unwrap-syntax 238 (quasirename (add-prefix 'p:) 239 `(quasirename x 240 `(a ,b ,',c ,,'d)))))) 241 242(let-syntax ([def (er-macro-transformer 243 (^[f r c] 244 (quasirename r 245 `(define-syntax ,(cadr f) 246 (er-macro-transformer 247 ;; we need to protect ff from being renamed, 248 ;; for we have to refer to it inside quote 249 ;; in (cadr ff). 250 (^[,'ff rr cc] 251 (quasirename rr 252 `(define ,',(caddr f) ,,'(cadr ff)))))))))]) 253 (test* "nested quasirename" 4 254 (let () 255 (def foo bar) 256 (let () 257 (foo 4) 258 bar)))) 259 260;; Mixing syntax-rules and er-macro requires unhygienic identifiers to be 261;; explicitly "injected". 262;; (This does not work with the current compiler) 263 264;; (define-syntax eri-test-loop 265;; (eri-macro-transformer 266;; (lambda (x r c i) 267;; (let ((body (cdr x))) 268;; `(,(r 'call-with-current-continuation) 269;; (,(r 'lambda) (,(i 'exiit)) 270;; (,(r 'let) ,(r 'f) () ,@body (,(r 'f))))))))) 271 272;; (define-syntax eri-test-foo 273;; (syntax-rules () 274;; ((_ x) (eri-test-loop (exiit x))))) 275 276;; (test* "Mixing syntax-rules and eri-macro" 'yot 277;; (let ((exiit 42)) 278;; (eri-test-foo exiit))) 279 280;;---------------------------------------------------------------------- 281;; basic tests 282 283(test-section "basic expansion") 284 285(define-syntax simple (syntax-rules () 286 ((_ "a" ?a) (a ?a)) 287 ((_ "b" ?a) (b ?a)) 288 ((_ #f ?a) (c ?a)) 289 ((_ (#\a #\b) ?a) (d ?a)) 290 ((_ #(1 2) ?a) (e ?a)) 291 ((_ ?b ?a) (f ?a ?b)))) 292 293(test-macro "simple" (a z) (simple "a" z)) 294(test-macro "simple" (b z) (simple "b" z)) 295(test-macro "simple" (c z) (simple #f z)) 296(test-macro "simple" (d z) (simple (#\a #\b) z)) 297(test-macro "simple" (e z) (simple #(1 2) z)) 298(test-macro "simple" (f z #(1.0 2.0)) (simple #(1.0 2.0) z)) 299(test-macro "simple" (f z (#\b #\a)) (simple (#\b #\a) z)) 300(test-macro "simple" (f z #(2 1)) (simple #(2 1) z)) 301 302(define-syntax underbar (syntax-rules () 303 [(_) 0] 304 [(_ _) 1] 305 [(_ _ _) 2] 306 [(_ _ _ _) 3] 307 [(_ _ _ _ . _) many])) 308(test-macro "underbar" 0 (underbar)) 309(test-macro "underbar" 1 (underbar a)) 310(test-macro "underbar" 2 (underbar a b)) 311(test-macro "underbar" 3 (underbar a b c)) 312(test-macro "underbar" many (underbar a b c d)) 313 314(define-syntax repeat (syntax-rules () 315 ((_ 0 (?a ?b) ...) ((?a ...) (?b ...))) 316 ((_ 1 (?a ?b) ...) (?a ... ?b ...)) 317 ((_ 2 (?a ?b) ...) (?a ... ?b ... ?a ...)) 318 ((_ 0 (?a ?b ?c) ...) ((?a ...) (?b ?c) ...)) 319 ((_ 1 (?a ?b ?c) ...) (?a ... (?c 8 ?b) ...)) 320 )) 321 322(test-macro "repeat" ((a c e) (b d f)) 323 (repeat 0 (a b) (c d) (e f))) 324(test-macro "repeat" (a c e b d f) 325 (repeat 1 (a b) (c d) (e f))) 326(test-macro "repeat" (a c e b d f a c e) 327 (repeat 2 (a b) (c d) (e f))) 328(test-macro "repeat" ((a d g) (b c) (e f) (h i)) 329 (repeat 0 (a b c) (d e f) (g h i))) 330(test-macro "repeat" (a d g (c 8 b) (f 8 e) (i 8 h)) 331 (repeat 1 (a b c) (d e f) (g h i))) 332 333(define-syntax repeat2 (syntax-rules () ;r7rs 334 ((_ 0 (?a ?b ... ?c)) (?a (?b ...) ?c)) 335 ((_ 1 (?a ?b ... ?c ?d)) (?a (?b ...) ?c ?d)) 336 ((_ 2 (?a ?b ... . ?c)) (?a (?b ...) ?c)) 337 ((_ 3 (?a ?b ... ?c ?d . ?e)) (?a (?b ...) ?c ?d ?e)) 338 ((_ ?x ?y) ho))) 339 340(test-macro "repeat2" (a (b c d e f) g) 341 (repeat2 0 (a b c d e f g))) 342(test-macro "repeat2" (a () b) 343 (repeat2 0 (a b))) 344(test-macro "repeat2" ho 345 (repeat2 0 (a))) 346(test-macro "repeat2" (a (b c d e) f g) 347 (repeat2 1 (a b c d e f g))) 348(test-macro "repeat2" (a () b c) 349 (repeat2 1 (a b c))) 350(test-macro "repeat2" ho 351 (repeat2 1 (a b))) 352(test-macro "repeat2" (a (b c d e f g) ()) 353 (repeat2 2 (a b c d e f g))) 354(test-macro "repeat2" (a (b c d e) f g ()) 355 (repeat2 3 (a b c d e f g))) 356(test-macro "repeat2" (a (b c d) e) 357 (repeat2 2 (a b c d . e))) 358(test-macro "repeat2" (a (b) c d e) 359 (repeat2 3 (a b c d . e))) 360 361(define-syntax nest1 (syntax-rules () 362 ((_ (?a ...) ...) ((?a ... z) ...)))) 363 364(test-macro "nest1" ((a z) (b c d z) (e f g h i z) (z) (j z)) 365 (nest1 (a) (b c d) (e f g h i) () (j))) 366 367(define-syntax nest2 (syntax-rules () 368 ((_ ((?a ?b) ...) ...) ((?a ... ?b ...) ...)))) 369 370(test-macro "nest2" ((a c b d) () (e g i f h j)) 371 (nest2 ((a b) (c d)) () ((e f) (g h) (i j)))) 372 373(define-syntax nest3 (syntax-rules () 374 ((_ ((?a ?b ...) ...) ...) ((((?b ...) ...) ...) 375 ((?a ...) ...))))) 376 377(test-macro "nest3" ((((b c d e) (g h i)) (() (l m n) (p)) () ((r))) 378 ((a f) (j k o) () (q))) 379 (nest3 ((a b c d e) (f g h i)) ((j) (k l m n) (o p)) () ((q r)))) 380 381(define-syntax nest4 (syntax-rules () ; r7rs 382 ((_ ((?a ?b ... ?c) ... ?d)) 383 ((?a ...) ((?b ...) ...) (?c ...) ?d)))) 384 385(test-macro "nest4"((a d f) 386 ((b) () (g h i)) 387 (c e j) 388 (k l m)) 389 (nest4 ((a b c) (d e) (f g h i j) (k l m)))) 390 391(define-syntax nest5 (syntax-rules () ; r7rs 392 ((_ (?a (?b ... ?c ?d) ... . ?e)) 393 (?a ((?b ...) ...) (?c ...) (?d ...) ?e)))) 394(test-macro "nest5" (z 395 ((a) (d e) ()) 396 (b f h) 397 (c g i) 398 j) 399 (nest5 (z (a b c) (d e f g) (h i) . j))) 400 401(define-syntax nest6 (syntax-rules () 402 ((_ (?a ...) ...) 403 (?a ... ...)))) ;srfi-149 404(test-macro "nest6" (a b c d e f g h i j) 405 (nest6 (a b c d) (e f g) (h i) (j))) 406(test-macro "nest6" (a b c d e f g) 407 (nest6 (a b c d) () (e) () (f g))) 408 409(define-syntax nest7 (syntax-rules () 410 ((_ (?a ...) ...) 411 (?a ... ... z ?a ... ...)))) ;srfi-149 412(test-macro "nest7" (a b c d e f g h i j z a b c d e f g h i j) 413 (nest7 (a b c d) (e f g) (h i) (j))) 414(test-macro "nest7" (a b c d e f g z a b c d e f g) 415 (nest7 (a b c d) () (e) () (f g))) 416 417(define-syntax nest8 (syntax-rules () 418 ((_ ((?a ...) ...) ...) 419 (?a ... ... ... z)))) ;srfi-149 420(test-macro "nest8" (a b c d e f g h i j z) 421 (nest8 ((a b c d) (e f g)) ((h i) (j)))) 422(test-macro "nest8" (a b c d e f g h i j z) 423 (nest8 ((a b c d) () (e f g)) () ((h i) () (j) ()))) 424 425;; mixlevel is allowed by srfi-149 426(define-syntax mixlevel1 (syntax-rules () 427 ((_ (?a ?b ...)) ((?a ?b) ...)))) 428 429(test-macro "mixlevel1" ((1 2) (1 3) (1 4) (1 5) (1 6)) 430 (mixlevel1 (1 2 3 4 5 6))) 431(test-macro "mixlevel1" () 432 (mixlevel1 (1))) 433 434(define-syntax mixlevel2 (syntax-rules () 435 ((_ (?a ?b ...) ...) 436 (((?a ?b) ...) ...)))) 437 438(test-macro "mixlevel2" (((1 2) (1 3) (1 4)) ((2 3) (2 4) (2 5) (2 6))) 439 (mixlevel2 (1 2 3 4) (2 3 4 5 6))) 440 441(define-syntax mixlevel3 (syntax-rules () 442 ((_ ?a (?b ?c ...) ...) 443 (((?a ?b ?c) ...) ...)))) 444 445(test-macro "mixlevel3" (((1 2 3) (1 2 4) (1 2 5) (1 2 6)) 446 ((1 7 8) (1 7 9) (1 7 10))) 447 (mixlevel3 1 (2 3 4 5 6) (7 8 9 10))) 448 449;; test that wrong usage of ellipsis is correctly identified 450(test "bad ellipsis 1" (test-error) 451 (lambda () 452 (eval '(define-syntax badellipsis 453 (syntax-rules () [(t) (3 ...)])) 454 (interaction-environment)))) 455(test "bad ellipsis 2" (test-error) 456 (lambda () 457 (eval '(define-syntax badellipsis 458 (syntax-rules () [(t a) (a ...)])) 459 (interaction-environment)))) 460(test "bad ellipsis 3" (test-error) 461 (lambda () 462 (eval '(define-syntax badellipsis 463 (syntax-rules () [(t a b ...) (a ...)])) 464 (interaction-environment)))) 465(test "bad ellipsis 4" (test-error) 466 (lambda () 467 (eval '(define-syntax badellipsis 468 (syntax-rules () [(t a ...) ((a ...) ...)])) 469 (interaction-environment)))) 470 471(test "bad ellipsis 5" (test-error) 472 (lambda () 473 (eval '(define-syntax badellipsis 474 (syntax-rules () [(t (a ... b ...)) ((a ...) (b ...))])) 475 (interaction-environment)))) 476(test "bad ellipsis 6" (test-error) 477 (lambda () 478 (eval '(define-syntax badellipsis 479 (syntax-rules () [(t (... a b)) (... a b )])) 480 (interaction-environment)))) 481 482(define-syntax hygiene (syntax-rules () 483 ((_ ?a) (+ ?a 1)))) 484(test "hygiene" 3 485 (lambda () (let ((+ *)) (hygiene 2)))) 486 487(define-syntax vect1 (syntax-rules () 488 ((_ #(?a ...)) (?a ...)) 489 ((_ (?a ...)) #(?a ...)))) 490(test-macro "vect1" (1 2 3 4 5) (vect1 #(1 2 3 4 5))) 491(test-macro "vect1" #(1 2 3 4 5) (vect1 (1 2 3 4 5))) 492 493(define-syntax vect2 (syntax-rules () 494 ((_ #(#(?a ?b) ...)) #(?a ... ?b ...)) 495 ((_ #((?a ?b) ...)) (?a ... ?b ...)) 496 ((_ (#(?a ?b) ...)) (#(?a ...) #(?b ...))))) 497 498(test-macro "vect2" #(a c e b d f) (vect2 #(#(a b) #(c d) #(e f)))) 499(test-macro "vect2" (a c e b d f) (vect2 #((a b) (c d) (e f)))) 500(test-macro "vect2" (#(a c e) #(b d f)) (vect2 (#(a b) #(c d) #(e f)))) 501 502(define-syntax vect3 (syntax-rules () 503 ((_ 0 #(?a ... ?b)) ((?a ...) ?b)) 504 ((_ 0 ?x) ho) 505 ((_ 1 #(?a ?b ... ?c ?d ?e)) (?a (?b ...) ?c ?d ?e)) 506 ((_ 1 ?x) ho))) 507 508(test-macro "vect3" ((a b c d e) f) 509 (vect3 0 #(a b c d e f))) 510(test-macro "vect3" (() a) 511 (vect3 0 #(a))) 512(test-macro "vect3" ho 513 (vect3 0 #())) 514(test-macro "vect3" (a (b c) d e f) 515 (vect3 1 #(a b c d e f))) 516(test-macro "vect3" (a () b c d) 517 (vect3 1 #(a b c d))) 518(test-macro "vect3" ho 519 (vect3 1 #(a b c))) 520 521(define-syntax dot1 (syntax-rules () 522 ((_ (?a . ?b)) (?a ?b)) 523 ((_ ?loser) #f))) 524(test-macro "dot1" (1 2) (dot1 (1 . 2))) 525(test-macro "dot1" (1 (2)) (dot1 (1 2))) 526(test-macro "dot1" (1 ()) (dot1 (1))) 527(test-macro "dot1" (1 (2 3)) (dot1 (1 2 3))) 528(test-macro "dot1" #f (dot1 ())) 529 530(define-syntax dot2 (syntax-rules () 531 ((_ ?a . ?b) (?b . ?a)) 532 ((_ . ?loser) #f))) 533(test-macro "dot2" (2 . 1) (dot2 1 . 2)) 534(test-macro "dot2" ((2) . 1) (dot2 1 2)) 535(test-macro "dot2" (() . 1) (dot2 1)) 536(test-macro "dot2" ((2 3) . 1) (dot2 1 2 3)) 537(test-macro "dot2" #f (dot2)) 538 539;; pattern to yield (. x) => x 540(define-syntax dot3 (syntax-rules () 541 ((_ (?a ...) ?b) (?a ... . ?b)))) 542(test-macro "dot3" (1 2 . 3) (dot3 (1 2) 3)) 543(test-macro "dot3" 3 (dot3 () 3)) 544 545;; see if effective quote introduced by quasiquote properly unwrap 546;; syntactic environment. 547(define-syntax unwrap1 (syntax-rules () 548 ((_ x) `(a ,x)))) 549(test "unwrap1" '(a 3) (lambda () (unwrap1 3)) 550 (lambda (x y) (and (eq? (car x) (car y)) (eq? (cadr x) (cadr y))))) 551(test "unwrap1" '(a 4) (lambda () (let ((a 4)) (unwrap1 a))) 552 (lambda (x y) (and (eq? (car x) (car y)) (eq? (cadr x) (cadr y))))) 553 554;; regression check for quasiquote hygienty handling code 555(define-syntax qq1 (syntax-rules () 556 ((_ a) `(,@a)))) 557(define-syntax qq2 (syntax-rules () 558 ((_ a) `#(,@a)))) 559 560(test "qq1" '() (lambda () (qq1 '()))) 561(test "qq2" '#() (lambda () (qq2 '()))) 562 563;; R7RS style alternative ellipsis 564(test-section "alternative ellipsis") 565 566(define-syntax alt-elli1 567 (syntax-rules ooo () 568 [(_ ... ooo) '((... ...) ooo)])) 569 570(test "alt-elli1" '((a a) (b b) (c c)) (lambda () (alt-elli1 a b c))) 571 572(define-syntax alt-elli2 573 (syntax-rules ::: () 574 [(_ ... :::) '((... ...) :::)])) 575 576(test "alt-elli2" '((a a) (b b) (c c)) (lambda () (alt-elli2 a b c))) 577 578;; https://srfi-email.schemers.org/srfi-148/msg/6115633 579(define-syntax alt-elli3 580 (syntax-rules ... (...) 581 [(m x y ...) 'ellipsis] 582 [(m x ...) 'literal])) 583 584(test "alt-elli3" 'literal (lambda () (alt-elli3 x ...))) 585 586;;---------------------------------------------------------------------- 587;; cond, taken from R5RS section 7.3 588 589(test-section "recursive expansion") 590 591(define-syntax %cond 592 (syntax-rules (else =>) 593 ((cond (else result1 result2 ...)) 594 (begin result1 result2 ...)) 595 ((cond (test => result)) 596 (let ((temp test)) 597 (if temp (result temp)))) 598 ((cond (test => result) clause1 clause2 ...) 599 (let ((temp test)) 600 (if temp 601 (result temp) 602 (%cond clause1 clause2 ...)))) 603 ((cond (test)) test) 604 ((cond (test) clause1 clause2 ...) 605 (let ((temp test)) 606 (if temp temp (%cond clause1 clause2 ...)))) 607 ((cond (test result1 result2 ...)) 608 (if test (begin result1 result2 ...))) 609 ((cond (test result1 result2 ...) clause1 clause2 ...) 610 (if test (begin result1 result2 ...) (%cond clause1 clause2 ...))) 611 )) 612 613(test-macro "%cond" (begin a) (%cond (else a))) 614(test-macro "%cond" (begin a b c) (%cond (else a b c))) 615(test-macro "%cond" (let ((temp a)) (if temp (b temp))) (%cond (a => b))) 616(test-macro "%cond" (let ((temp a)) (if temp (b temp) (%cond c))) (%cond (a => b) c)) 617(test-macro "%cond" (let ((temp a)) (if temp (b temp) (%cond c d))) (%cond (a => b) c d)) 618(test-macro "%cond" (let ((temp a)) (if temp (b temp) (%cond c d e))) (%cond (a => b) c d e)) 619(test-macro "%cond" a (%cond (a))) 620(test-macro "%cond" (let ((temp a)) (if temp temp (%cond b))) (%cond (a) b)) 621(test-macro "%cond" (let ((temp a)) (if temp temp (%cond b c))) (%cond (a) b c)) 622(test-macro "%cond" (if a (begin b)) (%cond (a b))) 623(test-macro "%cond" (if a (begin b c d)) (%cond (a b c d))) 624(test-macro "%cond" (if a (begin b c d) (%cond e f g)) (%cond (a b c d) e f g)) 625 626;; test for higiene 627(test "%cond" '(if a (begin => b)) 628 (lambda () (let ((=> #f)) (unident (%macroexpand (%cond (a => b))))))) 629(test "%cond" '(if else (begin z)) 630 (lambda () (let ((else #t)) (unident (%macroexpand (%cond (else z))))))) 631 632;;---------------------------------------------------------------------- 633;; letrec, taken from R5RS section 7.3 634(define-syntax %letrec 635 (syntax-rules () 636 ((_ ((var1 init1) ...) body ...) 637 (%letrec "generate_temp_names" 638 (var1 ...) 639 () 640 ((var1 init1) ...) 641 body ...)) 642 ((_ "generate_temp_names" () (temp1 ...) ((var1 init1) ...) body ...) 643 (let ((var1 :undefined) ...) 644 (let ((temp1 init1) ...) 645 (set! var1 temp1) ... 646 body ...))) 647 ((_ "generate_temp_names" (x y ...) (temp ...) ((var1 init1) ...) body ...) 648 (%letrec "generate_temp_names" 649 (y ...) 650 (newtemp temp ...) 651 ((var1 init1) ...) 652 body ...)))) 653 654;; Note: if you "unident" the expansion result of %letrec, you see a symbol 655;; "newtemp" appears repeatedly in the let binding, seemingly expanding 656;; into invalid syntax. Internally, however, those symbols are treated 657;; as identifiers with the correct identity, so the expanded code works 658;; fine (as tested in the second test). 659(test-macro "%letrec" 660 (let ((a :undefined) 661 (c :undefined)) 662 (let ((newtemp b) 663 (newtemp d)) 664 (set! a newtemp) 665 (set! c newtemp) 666 e f g)) 667 (%letrec ((a b) (c d)) e f g)) 668(test "%letrec" '(1 2 3) 669 (lambda () (%letrec ((a 1) (b 2) (c 3)) (list a b c)))) 670 671;;---------------------------------------------------------------------- 672;; do, taken from R5RS section 7.3 673(define-syntax %do 674 (syntax-rules () 675 ((_ ((var init step ...) ...) 676 (test expr ...) 677 command ...) 678 (letrec 679 ((loop 680 (lambda (var ...) 681 (if test 682 (begin 683 (if #f #f) 684 expr ...) 685 (begin 686 command 687 ... 688 (loop (%do "step" var step ...) 689 ...)))))) 690 (loop init ...))) 691 ((_ "step" x) 692 x) 693 ((_ "step" x y) 694 y))) 695 696(test-macro "%do" 697 (letrec ((loop (lambda (x y) 698 (if (>= x 10) 699 (begin (if #f #f) y) 700 (begin (loop (%do "step" x (+ x 1)) 701 (%do "step" y (* y 2)))))))) 702 (loop 0 1)) 703 (%do ((x 0 (+ x 1)) 704 (y 1 (* y 2))) 705 ((>= x 10) y))) 706(test "%do" 1024 707 (lambda () (%do ((x 0 (+ x 1)) 708 (y 1 (* y 2))) 709 ((>= x 10) y)))) 710 711(test-macro "%do" 712 (letrec ((loop (lambda (y x) 713 (if (>= x 10) 714 (begin (if #f #f) y) 715 (begin (set! y (* y 2)) 716 (loop (%do "step" y) 717 (%do "step" x (+ x 1)))))))) 718 (loop 1 0)) 719 (%do ((y 1) 720 (x 0 (+ x 1))) 721 ((>= x 10) y) 722 (set! y (* y 2)))) 723(test "%do" 1024 724 (lambda () (%do ((y 1) 725 (x 0 (+ x 1))) 726 ((>= x 10) y) 727 (set! y (* y 2))))) 728 729;;---------------------------------------------------------------------- 730;; non-syntax-rule transformers 731 732(test-section "transformers other than syntax-rules") 733 734(define-syntax xif if) 735(test "xif" 'ok (lambda () (xif #f 'ng 'ok))) 736 737(define-syntax fi (syntax-rules () [(_ a b c) (xif a c b)])) 738(define-syntax xfi fi) 739(test "xfi" 'ok (lambda () (xfi #f 'ok 'ng))) 740 741;;---------------------------------------------------------------------- 742;; local syntactic bindings. 743 744(test-section "local syntactic bindings") 745 746(test "let-syntax" ; R5RS 4.3.1 747 'now 748 (lambda () 749 (let-syntax ((%when (syntax-rules () 750 ((_ test stmt1 stmt2 ...) 751 (if test (begin stmt1 stmt2 ...)))))) 752 (let ((if #t)) 753 (%when if (set! if 'now)) 754 if)))) 755 756(test "let-syntax" ; R5RS 4.3.1 757 'outer 758 (lambda () 759 (let ((x 'outer)) 760 (let-syntax ((m (syntax-rules () ((m) x)))) 761 (let ((x 'inner)) 762 (m)))))) 763 764(test "let-syntax (multi)" 765 81 766 (lambda () 767 (let ((+ *)) 768 (let-syntax ((a (syntax-rules () ((_ ?x) (+ ?x ?x)))) 769 (b (syntax-rules () ((_ ?x) (* ?x ?x))))) 770 (let ((* -) 771 (+ /)) 772 (a (b 3))))))) 773 774(test "let-syntax (nest)" 775 19 776 (lambda () 777 (let-syntax ((a (syntax-rules () ((_ ?x ...) (+ ?x ...))))) 778 (let-syntax ((a (syntax-rules () 779 ((_ ?x ?y ...) (a ?y ...)) 780 ((_) 2)))) 781 (a 8 9 10))))) 782 783(test "let-syntax (nest)" 784 '(-6 11) 785 (lambda () 786 (let-syntax ((a (syntax-rules () ((_ ?x) (+ ?x 8)))) 787 (b (syntax-rules () ((_ ?x) (- ?x 8))))) 788 (let-syntax ((a (syntax-rules () ((_ ?x) (b 2)))) 789 (b (syntax-rules () ((_ ?x) (a 3))))) 790 (list (a 7) (b 8)))))) 791 792(test "letrec-syntax" ; R5RS 4.3.1 793 7 794 (lambda () 795 (letrec-syntax ((%or (syntax-rules () 796 ((_) #f) 797 ((_ e) e) 798 ((_ e f ...) 799 (let ((temp e)) 800 (if temp temp (%or f ...))))))) 801 (let ((x #f) 802 (y 7) 803 (temp 8) 804 (let odd?) 805 (if even?)) 806 (%or x (let temp) (if y) y))))) 807 808(test "letrec-syntax (nest)" 809 2 810 (lambda () 811 (letrec-syntax ((a (syntax-rules () ((_ ?x ...) (+ ?x ...))))) 812 (letrec-syntax ((a (syntax-rules () 813 ((_ ?x ?y ...) (a ?y ...)) 814 ((_) 2)))) 815 (a 8 9 10))))) 816 817(test "letrec-syntax (nest)" 818 '(9 11) 819 (lambda () 820 (letrec-syntax ((a (syntax-rules () ((_ ?x) (+ ?x 8)))) 821 (b (syntax-rules () ((_ ?x) (- ?x 8))))) 822 (letrec-syntax ((a (syntax-rules () 823 ((_ ?x) (b ?x 2)) 824 ((_ ?x ?y) (+ ?x ?y)))) 825 (b (syntax-rules () 826 ((_ ?x) (a ?x 3)) 827 ((_ ?x ?y) (+ ?x ?y))))) 828 (list (a 7) (b 8)))))) 829 830(test "letrec-syntax (recursive)" 831 #t 832 (lambda () 833 (letrec-syntax ((o? (syntax-rules () 834 ((o? ()) #f) 835 ((o? (x . xs)) (e? xs)))) 836 (e? (syntax-rules () 837 ((e? ()) #t) 838 ((e? (x . xs)) (o? xs))))) 839 (e? '(a a a a))))) 840 841;; This is from comp.lang.scheme posting by Antti Huima 842;; http://groups.google.com/groups?hl=ja&selm=7qpu5ncg2l.fsf%40divergence.tcs.hut.fi 843(test "let-syntax (huima)" '(1 3 5 9) 844 (lambda () 845 (define the-procedure 846 (let-syntax((l(syntax-rules()((l((x(y ...))...)b ...)(let-syntax((x (syntax-rules()y ...))...) b ...)))))(l('(('(a b ...)(lambda a b ...)))`((`(a b c)(if a b c))(`(a)(car a))),((,(a b)(set! a b))(,(a)(cdr a))),@((,@z(call-with-current-continuation z))))'((ls)('((s)('((i) ('((d)('((j)('((c)('((p)('((l)('(()(l l))))'((k)`((pair?,(p))('((c) ,(p(append,(,(p))(d c)))(k k))(c`(p)`(,(p))c))`(p)))))(cons(d)(map d ls))))'((x y c),@'((-)(s x y null? - s)(j x y c)))))'((x y c)('((q)('((f)(cons`(q)(c((f x)x)((f y)y)c)))'((h)`((eq? q h)'((x),(x)) i)))),@'((-)(s x y'((z)(>=`(z)(sqrt(*`(x)`(y)))))- s))))))list)) '((z)z)))'((x y p k l),@'((-)`((p x)(k y)(l y x'((z)`((p z)-(- #f)))k l))))))))) 847 (the-procedure '(5 1 9 3)))) 848 849 850(test "let-syntax, rebinding syntax" 'ok 851 (lambda () 852 (let-syntax ([xif if] [if when]) (xif #f 'ng 'ok)))) 853 854(test "let-syntax, rebinding macro" 'ok 855 (lambda () 856 (let-syntax ([if fi]) (if #f 'ok 'ng)))) 857 858;; Macro-generating-macro scoping 859;; Currently it's not working. 860(define-syntax mgm-bar 861 (syntax-rules () 862 ((_ . xs) '(bad . xs)))) 863 864(define-syntax mgm-foo 865 (syntax-rules () 866 ((_ xs) 867 (letrec-syntax ((mgm-bar 868 (syntax-rules () 869 ((_ (%x . %xs) %ys) 870 (mgm-bar %xs (%x . %ys))) 871 ((_ () %ys) 872 '%ys)))) 873 (mgm-bar xs ()))))) 874 875(test "macro-generating-macro scope" '(z y x) 876 (lambda () (mgm-foo (x y z)))) 877 878;;---------------------------------------------------------------------- 879;; macro and internal define 880 881(test-section "macro and internal define") 882 883(define-macro (gen-idef-1 x) 884 `(define foo ,x)) 885 886(test "define foo (legacy)" 3 887 (lambda () 888 (gen-idef-1 3) 889 foo)) 890(test "define foo (legacy)" '(3 5) 891 (lambda () 892 (let ((foo 5)) 893 (list (let () (gen-idef-1 3) foo) 894 foo)))) 895(define foo 10) 896(test "define foo (legacy)" '(3 10) 897 (lambda () 898 (list (let () (gen-idef-1 3) foo) foo))) 899(test "define foo (legacy)" '(4 5) 900 (lambda () 901 (gen-idef-1 4) 902 (define bar 5) 903 (list foo bar))) 904(test "define foo (legacy)" '(4 5) 905 (lambda () 906 (define bar 5) 907 (gen-idef-1 4) 908 (list foo bar))) 909 910(test "define foo (error)" (test-error) 911 (lambda () 912 (eval '(let () 913 (list 3 4) 914 (gen-idef-1 5))))) 915(test "define foo (error)" (test-error) 916 (lambda () 917 (eval '(let () 918 (gen-idef-1 5))))) 919 920(test "define foo (shadow)" 10 921 (lambda () 922 (let ((gen-idef-1 -)) 923 (gen-idef-1 5) 924 foo))) 925 926(define-macro (gen-idef-2 x y) 927 `(begin (define foo ,x) (define bar ,y))) 928 929(test "define foo, bar (legacy)" '((0 1) 10) 930 (lambda () 931 (let ((l (let () (gen-idef-2 0 1) (list foo bar)))) 932 (list l foo)))) 933(test "define foo, bar (legacy)" '(-1 -2 20) 934 (lambda () 935 (define baz 20) 936 (gen-idef-2 -1 -2) 937 (list foo bar baz))) 938(test "define foo, bar (legacy)" '(-1 -2 20) 939 (lambda () 940 (gen-idef-2 -1 -2) 941 (define baz 20) 942 (list foo bar baz))) 943(test "define foo, bar (legacy)" '(3 4 20 -10) 944 (lambda () 945 (begin 946 (define biz -10) 947 (gen-idef-2 3 4) 948 (define baz 20)) 949 (list foo bar baz biz))) 950(test "define foo, bar (legacy)" '(3 4 20 -10) 951 (lambda () 952 (define biz -10) 953 (begin 954 (gen-idef-2 3 4) 955 (define baz 20) 956 (list foo bar baz biz)))) 957(test "define foo, bar (legacy)" '(3 4 20 -10) 958 (lambda () 959 (begin 960 (define biz -10)) 961 (begin 962 (gen-idef-2 3 4)) 963 (define baz 20) 964 (list foo bar baz biz))) 965(test "define foo, bar (error)" (test-error) 966 (lambda () 967 (eval '(let () 968 (list 3) 969 (gen-idef-2 -1 -2) 970 (list foo bar))))) 971(test "define foo, bar (error)" (test-error) 972 (lambda () 973 (eval '(let () 974 (gen-idef-2 -1 -2))))) 975 976(define-syntax gen-idef-3 977 (syntax-rules () 978 ((gen-idef-3 x y) 979 (begin (define x y))))) 980 981(test "define boo (r5rs)" 3 982 (lambda () 983 (gen-idef-3 boo 3) 984 boo)) 985(test "define boo (r5rs)" '(3 10) 986 (lambda () 987 (let ((l (let () (gen-idef-3 foo 3) foo))) 988 (list l foo)))) 989 990(define-syntax gen-idef-4 991 (syntax-rules () 992 ((gen-idef-4 x y) 993 (begin (define x y) (+ x x))))) 994 995(test "define poo (r5rs)" 6 996 (lambda () 997 (gen-idef-4 poo 3))) 998 999(test "define poo (r5rs)" 3 1000 (lambda () 1001 (gen-idef-4 poo 3) poo)) 1002 1003(define-macro (gen-idef-5 o e) 1004 `(begin 1005 (define (,o n) 1006 (if (= n 0) #f (,e (- n 1)))) 1007 (define (,e n) 1008 (if (= n 0) #t (,o (- n 1)))))) 1009 1010(test "define (legacy, mutually-recursive)" '(#t #f) 1011 (lambda () 1012 (gen-idef-5 ooo? eee?) 1013 (list (ooo? 5) (eee? 7)))) 1014 1015 1016(define-syntax gen-idef-6 1017 (syntax-rules () 1018 ((gen-idef-6 o e) 1019 (begin 1020 (define (o n) (if (= n 0) #f (e (- n 1)))) 1021 (define (e n) (if (= n 0) #t (o (- n 1)))))))) 1022 1023(test "define (r5rs, mutually-recursive)" '(#t #f) 1024 (lambda () 1025 (gen-idef-5 ooo? eee?) 1026 (list (ooo? 5) (eee? 7)))) 1027 1028;; crazy case when define is redefined 1029(define-module mac-idef 1030 (export (rename my-define define)) 1031 (define (my-define . args) args)) 1032 1033(define-module mac-idef.user 1034 (import mac-idef)) 1035 1036(test "define (redefined)" '(5 2) 1037 (lambda () 1038 (with-module mac-idef.user 1039 (let ((a 5)) (define a 2))))) 1040 1041(define-module mac-idef2 1042 (export (rename my-define define)) 1043 (define-syntax my-define 1044 (syntax-rules () 1045 [(_ var expr) (define (var) expr)]))) 1046 1047(define-module mac-idef2.user 1048 (import mac-idef2)) 1049 1050(test "define (redefined2)" 5 1051 (lambda () 1052 (with-module mac-idef2.user 1053 (let ((a 5)) (define x a) (x))))) 1054 1055(test "internal define-syntax and scope 1" 'inner 1056 (let ((x 'outer)) 1057 (lambda () 1058 (define x 'inner) 1059 (define-syntax foo 1060 (syntax-rules () 1061 [(_) x])) 1062 (foo)))) 1063 1064(test "internal define-syntax and scope 2" 'inner 1065 (let ((x 'outer)) 1066 (lambda () 1067 (define-syntax foo 1068 (syntax-rules () 1069 [(_) x])) 1070 (define x 'inner) 1071 (foo)))) 1072 1073(test "internal define-syntax and scope 3" '(inner inner) 1074 (let ((x 'outer)) 1075 (lambda () 1076 (define-syntax def 1077 (syntax-rules () 1078 [(_ v) (define v x)])) 1079 (define x 'inner) 1080 (def y) 1081 (list x y)))) 1082 1083(test "internal define-syntax and scope 4" '(inner inner) 1084 (let ((x 'outer)) 1085 (lambda () 1086 (define-syntax def 1087 (syntax-rules () 1088 [(_ v) (define v (lambda () x))])) 1089 (def y) 1090 (define x 'inner) 1091 (list x (y))))) 1092 1093(test "internal define-syntax and scope 5" '(inner (inner . innermost)) 1094 (let ((x 'outer)) 1095 (lambda () 1096 (define-syntax def1 1097 (syntax-rules () 1098 [(_ v) (def2 v x)])) 1099 (define-syntax def2 1100 (syntax-rules () 1101 [(_ v y) (define v (let ((x 'innermost)) 1102 (lambda () (cons y x))))])) 1103 (def1 z) 1104 (define x 'inner) 1105 (list x (z))))) 1106 1107;;---------------------------------------------------------------------- 1108;; macro defining macros 1109 1110(test-section "macro defining macros") 1111 1112(define-syntax mdm-foo1 1113 (syntax-rules () 1114 ((mdm-foo1 x y) 1115 (define-syntax x 1116 (syntax-rules () 1117 ((x z) (cons z y))))) 1118 )) 1119 1120(mdm-foo1 mdm-cons 0) 1121 1122(test "define-syntax - define-syntax" '(1 . 0) 1123 (lambda () (mdm-cons 1))) 1124 1125(define-syntax mdm-foo2 1126 (syntax-rules () 1127 ((mdm-foo2 x y) 1128 (let-syntax ((x (syntax-rules () 1129 ((x z) (cons z y))))) 1130 (x 1))))) 1131 1132(test "define-syntax - let-syntax" '(1 . 0) 1133 (lambda () (mdm-foo2 cons 0))) 1134 1135(test "let-syntax - let-syntax" '(4 . 3) 1136 (lambda () 1137 (let-syntax ((mdm-foo3 (syntax-rules () 1138 ((mdm-foo3 x y body) 1139 (let-syntax ((x (syntax-rules () 1140 ((x z) (cons z y))))) 1141 body))))) 1142 (mdm-foo3 list 3 (list 4))))) 1143 1144(test "letrec-syntax - let-syntax" 3 1145 (lambda () 1146 (letrec-syntax ((mdm-foo4 1147 (syntax-rules () 1148 ((mdm-foo4 () n) n) 1149 ((mdm-foo4 (x . xs) n) 1150 (let-syntax ((mdm-foo5 1151 (syntax-rules () 1152 ((mdm-foo5) 1153 (mdm-foo4 xs (+ n 1)))))) 1154 (mdm-foo5)))))) 1155 (mdm-foo4 (#f #f #f) 0)))) 1156 1157(define-syntax mdm-foo3 1158 (syntax-rules () 1159 ((mdm-foo3 y) 1160 (letrec-syntax ((o? (syntax-rules () 1161 ((o? ()) #f) 1162 ((o? (x . xs)) (e? xs)))) 1163 (e? (syntax-rules () 1164 ((e? ()) #t) 1165 ((e? (x . xs)) (o? xs))))) 1166 (e? y))))) 1167 1168(test "define-syntax - letrec-syntax" #t 1169 (lambda () (mdm-foo3 (a b c d)))) 1170 1171;; Examples from "Two pitfalls in programming nested R5RS macros" 1172;; by Oleg Kiselyov 1173;; http://pobox.com/~oleg/ftp/Scheme/r5rs-macros-pitfalls.txt 1174 1175(define-syntax mdm-bar-m 1176 (syntax-rules () 1177 ((_ x y) 1178 (let-syntax 1179 ((helper 1180 (syntax-rules () 1181 ((_ u) (+ x u))))) 1182 (helper y))))) 1183 1184(test "lexical scope" 5 1185 (lambda () (mdm-bar-m 4 1))) 1186 1187(define-syntax mdm-bar-m1 1188 (syntax-rules () 1189 ((_ var body) 1190 (let-syntax 1191 ((helper 1192 (syntax-rules () 1193 ((_) (lambda (var) body))))) 1194 (helper))))) 1195 1196(test "lexical scope" 5 1197 (lambda () ((mdm-bar-m1 z (+ z 1)) 4))) 1198 1199(define-syntax mdm-bar-m3 1200 (syntax-rules () 1201 ((_ var body) 1202 (let-syntax 1203 ((helper 1204 (syntax-rules () 1205 ((_ vvar bbody) (lambda (vvar) bbody))))) 1206 (helper var body))))) 1207 1208(test "passing by parameters" 5 1209 (lambda () ((mdm-bar-m3 z (+ z 1)) 4))) 1210 1211;; Macro defining toplevel macros. 1212(define-syntax defMyQuote 1213 (syntax-rules () 1214 ((_ name) 1215 (begin 1216 (define-syntax TEMP 1217 (syntax-rules () 1218 ((_ arg) 1219 `arg))) 1220 (define-syntax name 1221 (syntax-rules () 1222 ((_ arg) 1223 (TEMP arg)))))))) 1224 1225(defMyQuote MyQuote) 1226 1227(test "macro defining a toplevel macro" '(1 2 3) 1228 (lambda () (MyQuote (1 2 3)))) 1229 1230;; Macro inserting toplevel identifier 1231(define-module defFoo-test 1232 (export defFoo) 1233 (define-syntax defFoo 1234 (syntax-rules () 1235 [(_ accessor) 1236 (begin 1237 (define foo-toplevel 42) 1238 (define (accessor) foo-toplevel))]))) 1239 1240(import defFoo-test) 1241(defFoo get-foo) 1242 1243(test "macro injecting toplevel definition" '(#f #f 42) 1244 (lambda () 1245 (list (global-variable-ref (current-module) 'foo-toplevel #f) 1246 (global-variable-ref (find-module 'defFoo-test) 'foo-toplevel #f) 1247 (get-foo)))) 1248 1249;; recursive reference in macro-defined-macro 1250;; https://gist.github.com/ktakashi/03ae059f804a723a9589 1251(define-syntax assocm 1252 (syntax-rules () 1253 ((_ key (alist ...)) 1254 (letrec-syntax ((fooj (syntax-rules (key) 1255 ((_ (key . e) res (... ...)) '(key . e)) 1256 ((_ (a . d) res (... ...)) (fooj res (... ...)))))) 1257 (fooj alist ...))))) 1258 1259(test "recursive reference in macro-defined-macro" '(c . d) 1260 (lambda () (assocm c ((a . b) (b . d) (c . d) (d . d))))) 1261 1262;; literal identifier comparison with renamed identifier 1263;; https://gist.github.com/ktakashi/fa4ee23da88151536619 1264(define-module literal-id-test-sub 1265 (export car)) 1266 1267(define-module literal-id-test 1268 (use gauche.test) 1269 (import (literal-id-test-sub :rename ((car car-alias)))) 1270 1271 (define-syntax free-identifier=?? 1272 (syntax-rules () 1273 ((_ a b) 1274 (let-syntax ((foo (syntax-rules (a) 1275 ((_ a) #t) 1276 ((_ _) #f)))) 1277 (foo b))))) 1278 1279 (test "literal identifier comparison a a" #t 1280 (lambda () (free-identifier=?? a a))) 1281 (test "literal identifier comparison b a" #f 1282 (lambda () (free-identifier=?? b a))) 1283 (test "literal identifier comparison car car-alias" #t 1284 (lambda () (free-identifier=?? car car-alias)))) 1285 1286;; macro defining macro from other module 1287;; https://github.com/shirok/Gauche/issues/532 1288 1289(define-module macro-defining-macro-toplevel 1290 (export x1) 1291 (define-syntax x1 1292 (syntax-rules () 1293 ((x1 y1) 1294 (x2 x3 y1)))) 1295 1296 (define-syntax x2 1297 (syntax-rules () 1298 ((x2 x3 y1) 1299 (begin 1300 (define-syntax x3 1301 (syntax-rules () 1302 ((x3 x4) x4))) 1303 (define-syntax y1 1304 (syntax-rules () 1305 ((y1 y2) (x3 y2))))))))) 1306 1307(define-module macro-defining-macro-toplevel-user 1308 (use gauche.test) 1309 (import macro-defining-macro-toplevel) 1310 (x1 bar) 1311 ;; without fix, (bar 1) fails with "unbound variable: #<identifier ... x3>" 1312 (test "macro defining macro in other module" 1 1313 (lambda () (eval '(bar 1) (current-module))))) 1314 1315;;---------------------------------------------------------------------- 1316;; identifier comparison 1317 1318(test-section "identifier comparison") 1319 1320;; This is EXPERIMENTAL: may be changed in later release. 1321(define-syntax expand-id-compare (syntax-rules () ((hoge foo ...) (cdr b)))) 1322(test "comparison of identifiers" '(cdr b) 1323 (lambda () (macroexpand '(expand-id-compare bar) #t))) 1324(test "comparison of identifiers" (macroexpand '(expand-id-compare bar) #t) 1325 (lambda () (macroexpand '(expand-id-compare bar) #t))) 1326 1327;;---------------------------------------------------------------------- 1328;; keyword and extended lambda list 1329 1330(test-section "keyword inserted by macro") 1331 1332(define-syntax define-extended-1 1333 (syntax-rules () 1334 [(_ name) 1335 (define (name a :key (b #f)) 1336 (list a b))])) 1337 1338(define-extended-1 extended-1) 1339(test "macro expands to extended lambda list" '(1 2) 1340 (lambda () (extended-1 1 :b 2))) 1341 1342(define-syntax define-extended-2 1343 (syntax-rules () 1344 [(_ name) 1345 (define (name a :key ((:b boo) #f)) 1346 (list a boo))])) 1347(define-extended-2 extended-2) 1348(test "macro expands to extended lambda list" '(3 4) 1349 (lambda () (extended-2 3 :b 4))) 1350 1351;;---------------------------------------------------------------------- 1352;; common-macros 1353 1354(test-section "common-macros utilities") 1355 1356(test "push!" '(1 2 3) 1357 (lambda () 1358 (let ((a '())) 1359 (push! a 3) (push! a 2) (push! a 1) 1360 a))) 1361 1362(test "push!" '(0 1 2 3) 1363 (lambda () 1364 (let ((a (list 0))) 1365 (push! (cdr a) 3) (push! (cdr a) 2) (push! (cdr a) 1) 1366 a))) 1367 1368(test "push!" '#((1 2) (3 . 0)) 1369 (lambda () 1370 (let ((a (vector '() 0))) 1371 (push! (vector-ref a 0) 2) 1372 (push! (vector-ref a 0) 1) 1373 (push! (vector-ref a 1) 3) 1374 a))) 1375 1376(test "pop!" '((2 3) . 1) 1377 (lambda () 1378 (let* ((a (list 1 2 3)) 1379 (b (pop! a))) 1380 (cons a b)))) 1381 1382(test "pop!" '((1 3) . 2) 1383 (lambda () 1384 (let* ((a (list 1 2 3)) 1385 (b (pop! (cdr a)))) 1386 (cons a b)))) 1387 1388(test "pop!" '(#((2)) . 1) 1389 (lambda () 1390 (let* ((a (vector (list 1 2))) 1391 (b (pop! (vector-ref a 0)))) 1392 (cons a b)))) 1393 1394(test "push!, pop!" '((2 3) (4 1)) 1395 (lambda () 1396 (let ((a (list 1 2 3)) 1397 (b (list 4))) 1398 (push! (cdr b) (pop! a)) 1399 (list a b)))) 1400 1401(test "inc!" 3 1402 (lambda () (let ((x 2)) (inc! x) x))) 1403(test "inc!" 4 1404 (lambda () (let ((x 2)) (inc! x 2) x))) 1405(test "inc!" '(4 . 1) 1406 (lambda () 1407 (let ((x (cons 3 1))) 1408 (inc! (car x)) x))) 1409(test "inc!" '(1 . 1) 1410 (lambda () 1411 (let ((x (cons 3 1))) 1412 (inc! (car x) -2) x))) 1413(test "inc!" '((4 . 1) 1) 1414 (lambda () 1415 (let ((x (cons 3 1)) 1416 (y 0)) 1417 (define (zz) (inc! y) car) 1418 (inc! ((zz) x)) 1419 (list x y)))) 1420(test "dec!" 1 1421 (lambda () (let ((x 2)) (dec! x) x))) 1422(test "dec!" 0 1423 (lambda () (let ((x 2)) (dec! x 2) x))) 1424(test "dec!" '(2 . 1) 1425 (lambda () 1426 (let ((x (cons 3 1))) 1427 (dec! (car x)) x))) 1428(test "dec!" '(5 . 1) 1429 (lambda () 1430 (let ((x (cons 3 1))) 1431 (dec! (car x) -2) x))) 1432(test "dec!" '((2 . 1) -1) 1433 (lambda () 1434 (let ((x (cons 3 1)) 1435 (y 0)) 1436 (define (zz) (dec! y) car) 1437 (dec! ((zz) x)) 1438 (list x y)))) 1439 1440(test "dotimes" '(0 1 2 3 4 5 6 7 8 9) 1441 (lambda () 1442 (let ((m '())) 1443 (dotimes (n 10) (push! m n)) 1444 (reverse m)))) 1445(test "dotimes" '(0 1 2 3 4 5 6 7 8 9) 1446 (lambda () 1447 (let ((m '())) 1448 (dotimes (n 10 (reverse m)) (push! m n))))) 1449(test "dotimes" '(0 1 2 3 4 5 6 7 8 9) 1450 (lambda () 1451 (let ((m '())) 1452 (dotimes (n (if (null? m) 10 (error "Boom!")) (reverse m)) 1453 (push! m n))))) 1454 1455(test "while" 9 1456 (lambda () 1457 (let ((a 10) 1458 (b 0)) 1459 (while (positive? (dec! a)) 1460 (inc! b)) 1461 b))) 1462(test "while" 0 1463 (lambda () 1464 (let ((a -1) 1465 (b 0)) 1466 (while (positive? (dec! a)) 1467 (inc! b)) 1468 b))) 1469 1470(test "while =>" 6 1471 (lambda () 1472 (let ((a '(1 2 3 #f)) 1473 (b 0)) 1474 (while (pop! a) 1475 => val 1476 (inc! b val)) 1477 b))) 1478 1479(test "while => guard" 45 1480 (lambda () 1481 (let ((a 10) 1482 (b 0)) 1483 (while (dec! a) 1484 positive? => val 1485 (inc! b a)) 1486 b))) 1487 1488(test "until" 10 1489 (lambda () 1490 (let ((a 10) (b 0)) 1491 (until (negative? (dec! a)) 1492 (inc! b)) 1493 b))) 1494(test "until => guard" 45 1495 (lambda () 1496 (let ((a 10) (b 0)) 1497 (until (dec! a) 1498 negative? => val 1499 (inc! b a)) 1500 b))) 1501 1502(test "values-ref" 3 1503 (lambda () 1504 (values-ref (quotient&remainder 10 3) 0))) 1505(test "values-ref" 1 1506 (lambda () 1507 (values-ref (quotient&remainder 10 3) 1))) 1508(test "values-ref" 'e 1509 (lambda () 1510 (values-ref (values 'a 'b 'c 'd 'e) 4))) 1511(test "values-ref" '(d b) 1512 (lambda () 1513 (receive r 1514 (values-ref (values 'a 'b 'c 'd 'e) 3 1) 1515 r))) 1516(test "values-ref" '(d a b) 1517 (lambda () 1518 (receive r 1519 (values-ref (values 'a 'b 'c 'd 'e) 3 0 1) 1520 r))) 1521(test "values-ref" '(e d c b a) 1522 (lambda () 1523 (receive r 1524 (values-ref (values 'a 'b 'c 'd 'e) 4 3 2 1 0) 1525 r))) 1526 1527(test "values->list" '(3 1) 1528 (lambda () (values->list (quotient&remainder 10 3)))) 1529(test "values->list" '(1) 1530 (lambda () (values->list 1))) 1531(test "values->list" '() 1532 (lambda () (values->list (values)))) 1533 1534(test "let1" '(2 2 2) 1535 (lambda () (let1 x (+ 1 1) (list x x x)))) 1536(test "let1" '(2 4) 1537 (lambda () (let1 x (+ 1 1) (list x (let1 x (+ x x) x))))) 1538 1539(test "rlet1" 1 (lambda () (rlet1 x (/ 2 2) (+ x x)))) 1540 1541(test "if-let1" 4 1542 (lambda () (if-let1 it (+ 1 1) (* it 2)))) 1543(test "if-let1" 'bar 1544 (lambda () (if-let1 it (memq 'a '(b c d)) 'boo 'bar))) 1545 1546(test "let-values" '(2 1 1 (2) (2 1)) 1547 (lambda () (let ([a 1] [b 2]) 1548 (let-values ([(a b) (values b a)] 1549 [(c . d) (values a b)] 1550 [e (values b a)]) 1551 (list a b c d e))))) 1552 1553(test "let*-values" '(2 1 2 (1) (1 2)) 1554 (lambda () (let ([a 1] [b 2]) 1555 (let*-values ([(a b) (values b a)] 1556 [(c . d) (values a b)] 1557 [e (values b a)]) 1558 (list a b c d e))))) 1559 1560(test "ecase" 'b 1561 (lambda () (ecase 3 ((1) 'a) ((2 3) 'b) ((4) 'c)))) 1562(test "ecase" (test-error) 1563 (lambda () (ecase 5 ((1) 'a) ((2 3) 'b) ((4) 'c)))) 1564(test "ecase" 'd 1565 (lambda () (ecase 5 ((1) 'a) ((2 3) 'b) ((4) 'c) (else 'd)))) 1566 1567(test "$" '(0 1) 1568 (lambda () ($ list 0 1))) 1569(test "$" '(0 1 (2 3 (4 5 (6 7)))) 1570 (lambda () ($ list 0 1 $ list 2 3 $ list 4 5 $ list 6 7))) 1571(test "$ - $*" '(0 1 (2 3 4 5 6 7)) 1572 (lambda () ($ list 0 1 $ list 2 3 $* list 4 5 $* list 6 7))) 1573(test "$ - $*" '(0 1 2 3 (4 5 6 7)) 1574 (lambda () ($ list 0 1 $* list 2 3 $ list 4 5 $* list 6 7))) 1575(test "$ - $*" '(0 1 2 3 4 5 (6 7)) 1576 (lambda () ($ list 0 1 $* list 2 3 $* list 4 5 $ list 6 7))) 1577(test "$ - partial" '(0 1 (2 3 (4 5 a))) 1578 (lambda () (($ list 0 1 $ list 2 3 $ list 4 5 $) 'a))) 1579(test "$ - $* - partial" '(0 1 2 3 4 5 a) 1580 (lambda () (($ list 0 1 $* list 2 3 $* list 4 5 $) 'a))) 1581(test "$ - $* - partial" '(0 1 (2 3 (4 5 a b))) 1582 (lambda () (($ list 0 1 $ list 2 3 $ list 4 5 $*) 'a 'b))) 1583 1584(test "$ - hygienty" `(0 1 a ,list 2 3 b ,list 4 5) 1585 (lambda () 1586 (let-syntax ([$$ (syntax-rules () 1587 [($$ . xs) ($ . xs)])]) 1588 (let ([$ 'a] [$* 'b]) 1589 ($$ list 0 1 $ list 2 3 $* list 4 5))))) 1590 1591(test* "cond-list" '() (cond-list)) 1592(test* "cond-list" '(a) (cond-list ('a))) 1593(test* "cond-list" '(a) (cond-list (#t 'a) (#f 'b))) 1594(test* "cond-list" '(b) (cond-list (#f 'a) (#t 'b))) 1595(test* "cond-list" '(a b d) (cond-list (#t 'a) (#t 'b) (#f 'c) (#t 'd))) 1596(test* "cond-list" '((b)) (cond-list (#f 'a) ('b => list))) 1597(test* "cond-list" '(a b c d x) 1598 (cond-list (#t @ '(a b)) (#t @ '(c d)) (#f @ '(e f)) 1599 ('x => @ list))) 1600 1601;;---------------------------------------------------------------------- 1602;; macro-expand 1603 1604(test-section "macroexpand") 1605 1606(define-macro (foo x) `(bar ,x ,x)) 1607(define-macro (bar x y) `(list ,x ,x ,y ,y)) 1608 1609(test "macroexpand" '(list 1 1 1 1) 1610 (lambda () (macroexpand '(foo 1)))) 1611(test "macroexpand-1" '(bar 1 1) 1612 (lambda () (macroexpand-1 '(foo 1)))) 1613 1614;;---------------------------------------------------------------------- 1615;; not allowing first-class macro 1616 1617(test-section "failure cases") 1618 1619(define-macro (bad-if a b c) `(,if ,a ,b ,c)) 1620(test "reject first-class syntax usage" (test-error) 1621 (lambda () (bad-if #t 'a 'b))) 1622 1623(define-macro (bad-fi a b c) `(,fi ,a ,b ,c)) 1624(test "reject first-class macro usage" (test-error) 1625 (lambda () (bad-fi #t 'a 'b))) 1626 1627;;---------------------------------------------------------------------- 1628;; compiler macros 1629 1630(test-section "define-hybrid-syntax") 1631 1632(define-hybrid-syntax cpm 1633 (lambda (a b) (+ a b)) 1634 (er-macro-transformer 1635 (lambda (f r c) `(,(r '*) ,(cadr f) ,(caddr f))))) 1636(test "compiler macro" '(6 5 6) 1637 (lambda () 1638 (list (cpm 2 3) 1639 (apply cpm '(2 3)) 1640 (let ((* -)) (cpm 2 3))))) 1641 1642;;---------------------------------------------------------------------- 1643;; syntax error 1644 1645(test-section "syntax-error") 1646 1647(define-syntax test-syntax-error 1648 (syntax-rules () 1649 [(_ a) 'ok] 1650 [(_ a b) (syntax-errorf "bad {~a ~a}" a b)] 1651 [(_ x ...) (syntax-error "bad number of arguments" x ...)])) 1652 1653;; NB: These tests depends on the fact that the compile "wraps" 1654;; the error by <compile-error-mixin> in order. If the compiler changes 1655;; the error handling, adjust the tests accordingly. 1656;; Our purpose here is to make sure syntax-error preserves the offending macro 1657;; call (test-syntax-error ...). 1658(test "syntax-error" 1659 '("bad number of arguments x y z" 1660 (test-syntax-error x y z) 1661 (list (test-syntax-error x y z))) 1662 (lambda () 1663 (guard [e (else (let1 xs (filter <compile-error-mixin> 1664 (slot-ref e '%conditions)) 1665 (cons (condition-message e e) 1666 (map (lambda (x) (slot-ref x 'expr)) xs))))] 1667 (eval '(list (test-syntax-error x y z)) 1668 (interaction-environment))))) 1669(test "syntax-errorf" 1670 '("bad {x y}" 1671 (test-syntax-error x y) 1672 (list (test-syntax-error x y))) 1673 (lambda () 1674 (guard [e (else (let1 xs (filter <compile-error-mixin> 1675 (slot-ref e '%conditions)) 1676 (cons (condition-message e e) 1677 (map (lambda (x) (slot-ref x 'expr)) xs))))] 1678 (eval '(list (test-syntax-error x y)) 1679 (interaction-environment))))) 1680 1681;;---------------------------------------------------------------------- 1682;; 'compare-ellipsis-1' test should output the following error. 1683;; 1684;; *** ERROR: in definition of macro mac-sub1: 1685;; template's ellipsis nesting is deeper than pattern's: 1686;; (#<identifier user#list.2d80660> #<identifier user#x.2d80690> 1687;; #<identifier user#ooo.2d806f0>) 1688;; 1689;; 'compare-ellipsis-2' test should output the following error. 1690;; 1691;; *** ERROR: in definition of macro mac-sub1: 1692;; template's ellipsis nesting is deeper than pattern's: 1693;; (#<identifier user#list.2969870> #<identifier user#x.29698a0> 1694;; #<identifier user#ooo.2969900>) 1695 1696(test-section "compare ellipsis") 1697 1698(define-syntax ell-test 1699 (syntax-rules (ooo) 1700 ((_ zzz) 1701 (let-syntax 1702 ((mac-sub1 1703 (syntax-rules ooo () 1704 ((_ x zzz) 1705 (list x ooo))))) 1706 (mac-sub1 1 2 3))))) 1707 1708(test* "compare-ellipsis-1" 1709 (test-error <error> #/^in definition of macro/) 1710 (eval 1711 '(ell-test ooo) 1712 (interaction-environment))) 1713 1714(test* "compare-ellipsis-2" 1715 (test-error <error> #/^in definition of macro/) 1716 (eval 1717 '(let ((ooo 'yyy)) (ell-test ooo)) 1718 (interaction-environment))) 1719 1720;;---------------------------------------------------------------------- 1721;; 'compare-literals-2' test should output the following error. 1722;; 1723;; *** ERROR: malformed #<identifier user#lit-test-2.29d4060>: 1724;; (#<identifier user#lit-test-2.29d4060> #<identifier user#temp.29d40c0>) 1725;; While compiling: (lit-test-2 temp 1) 1726 1727(test-section "compare literals") 1728 1729(define-syntax lit-test-1 1730 (syntax-rules (temp) 1731 ((_ temp x) 1732 (lit-test-1 temp)) 1733 ((_ temp) 1734 'passed))) 1735 1736(test* "compare-literals-1" 'passed (lit-test-1 temp 1)) 1737 1738(define-syntax lit-test-2 1739 (syntax-rules (temp) 1740 ((_ temp x) 1741 (let ((temp 100)) 1742 (lit-test-2 temp))) 1743 ((_ temp) 1744 'failed))) 1745 1746(test* "compare-literals-2" 1747 (test-error <error> #/^malformed/) 1748 (eval '(lit-test-2 temp 1) (interaction-environment))) 1749 1750;;---------------------------------------------------------------------- 1751;; 'generate-underbar-1' inserts global underbar into the macro output. 1752;; It shouldn't be regarded as a pattern variable, so the underbar in 1753;; the template refers to the global binding of '_'. 1754 1755(test-section "generate underbar") 1756 1757(define-syntax gen-underbar 1758 (syntax-rules (_) 1759 ((gen-underbar) 1760 (let-syntax 1761 ((mac-sub1 1762 (syntax-rules () 1763 ((mac-sub1 _) 1764 _)))) 1765 (mac-sub1 'failed))))) 1766 1767(test* "generate-underbar-1" _ 1768 (gen-underbar)) 1769 1770;;---------------------------------------------------------------------- 1771;; 'pattern-variables-1' test should output the following error. 1772;; 1773;; *** ERROR: too many pattern variables in the macro definition of pat-vars 1774;; While compiling: (syntax-rules () ((_ (z1 (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 1775;; x11 x12 x13 x14 x15 x16 x17 x ... 1776;; While compiling: (define-syntax pat-vars (syntax-rules () ((_ (z1 (x1 x2 x3 1777;; x4 x5 x6 x7 x8 x9 x10 x11 x ... 1778 1779(test-section "pattern variables check") 1780 1781(test* "pattern-variables-1" 1782 (test-error <error> #/^Too many pattern variables/) 1783 (eval 1784 '(define-syntax pat-vars 1785 (syntax-rules () 1786 ((_ (z1 (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 1787 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 1788 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 1789 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 1790 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 1791 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 1792 x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 1793 x71 x72 x73 x74 x75 x76 x77 x78 x79 x80 1794 x81 x82 x83 x84 x85 x86 x87 x88 x89 x90 1795 x91 x92 x93 x94 x95 x96 x97 x98 x99 x100 1796 x101 x102 x103 x104 x105 x106 x107 x108 x109 x110 1797 x111 x112 x113 x114 x115 x116 x117 x118 x119 x120 1798 x121 x122 x123 x124 x125 x126 x127 x128 x129 x130 1799 x131 x132 x133 x134 x135 x136 x137 x138 x139 x140 1800 x141 x142 x143 x144 x145 x146 x147 x148 x149 x150 1801 x151 x152 x153 x154 x155 x156 x157 x158 x159 x160 1802 x161 x162 x163 x164 x165 x166 x167 x168 x169 x170 1803 x171 x172 x173 x174 x175 x176 x177 x178 x179 x180 1804 x181 x182 x183 x184 x185 x186 x187 x188 x189 x190 1805 x191 x192 x193 x194 x195 x196 x197 x198 x199 x200 1806 x201 x202 x203 x204 x205 x206 x207 x208 x209 x210 1807 x211 x212 x213 x214 x215 x216 x217 x218 x219 x220 1808 x221 x222 x223 x224 x225 x226 x227 x228 x229 x230 1809 x231 x232 x233 x234 x235 x236 x237 x238 x239 x240 1810 x241 x242 x243 x244 x245 x246 x247 x248 x249 x250 1811 x251 x252 x253 x254 x255 x256))) 1812 (print z1 " " x255 " " x256)))) 1813 (interaction-environment))) 1814 1815(test* "pattern-variables-2" 1816 (test-error <error> #/^Pattern levels too deeply nested/) 1817 (let () 1818 (define (build-deep-nested-pattern n f) 1819 (if (= n 0) 1820 `(define-syntax pat-vars 1821 (syntax-rules () 1822 ((_ ,f) 1823 (quote ,f)))) 1824 (build-deep-nested-pattern (- n 1) `(,f ...)))) 1825 (eval 1826 (build-deep-nested-pattern 256 'x) 1827 (interaction-environment)))) 1828 1829;;---------------------------------------------------------------------- 1830;; let-keyword* hygienic expansion 1831;; 1832 1833(test-section "hygienic extened-lambda expansion") 1834(define-module let-keyword-hygiene-def 1835 (use gauche.base) 1836 (use util.match) 1837 (export klambda) 1838 (extend scheme) 1839 (define-syntax klambda 1840 (er-macro-transformer 1841 (^[f r c] 1842 (match f 1843 [(_ formals&keys . body) 1844 (quasirename r 1845 `(lambda (,@(drop-right formals&keys 1) 1846 ,(make-keyword 'key) 1847 ,@(map (^s `(,s #f)) (last formals&keys))) 1848 ,@body))]))))) 1849 1850(define-module let-keyword-hygeiene-use 1851 (import let-keyword-hygiene-def) 1852 (import gauche.keyword) 1853 (export call-klambda) 1854 (extend scheme) 1855 (define (call-klambda a b c d) 1856 ((klambda (a b (x y)) (list a b x y)) 1857 a b :x c :y d))) 1858 1859(test* "hygienic let-keyword expansion" '(1 2 3 4) 1860 ((with-module let-keyword-hygeiene-use call-klambda) 1 2 3 4)) 1861 1862;; Cf. http://chaton.practical-scheme.net/gauche/a/2020/11/05#entry-5fa3ba50-dc7d3 1863(define-syntax let-keywords-hygiene-test-1-inner 1864 (er-macro-transformer 1865 (^[f r c] 1866 (let-keywords (cdr f) ([a 1] 1867 [b 2]) 1868 (quasirename r `(+ ,a ,b)))))) 1869(define-syntax let-keywords-hygiene-test-1-outer 1870 (syntax-rules () 1871 [(_ x) (let-keywords-hygiene-test-1-inner :b x)])) 1872 1873(test* "hygienic let-keyword match" 10 1874 (let-keywords-hygiene-test-1-outer 9)) 1875 1876 1877;;---------------------------------------------------------------------- 1878;; srfi-147 begin 1879;; (not yest supported) 1880 1881'(test-section "srfi-147 begin") 1882 1883'(test "srfi-147 begin (internal) 1" 1884 '(yes no) 1885 (lambda () 1886 (define-syntax foo 1887 (begin (define-syntax bar if) 1888 (syntax-rules () 1889 [(_ x y z) (bar z x y)]))) 1890 (list (foo 'yes 'no (zero? 0)) 1891 (foo 'yes 'no (zero? 1))))) 1892 1893'(test "srfi-147 begin (internal) 2" 1894 11 1895 (lambda () 1896 (let-syntax ([foo (syntax-rules () 1897 [(_ a) (begin (define x (* a 2)) 1898 (syntax-rules () 1899 [(_ b) (+ b x)]))])]) 1900 (define-syntax bar (foo 3)) 1901 (bar 5)))) 1902 1903(test-end) 1904