~ chicken-core (master) /tests/syntax-tests.scm

   1;;;; syntax-tests.scm - various macro tests
   2
   3(import-for-syntax chicken.pretty-print)
   4(import chicken.gc chicken.pretty-print chicken.port)
   5(import (only (scheme base) call/cc))
   6
   7(define-syntax t
   8  (syntax-rules ()
   9    ((_ r x)
  10     (let ((tmp x))
  11       (if (not (equal? r tmp))
  12	   (error "test failed" r tmp 'x)
  13	   (pp tmp))))))
  14
  15(define-syntax f
  16  (syntax-rules ()
  17    ((_ x)
  18     (let ((got-error #f))
  19      (handle-exceptions ex (set! got-error #t) x)
  20      (unless got-error
  21        (error "test returned, but should have failed" 'x) )))))
  22
  23(t 3 3)
  24
  25(f abc)
  26(f (t 3 4))
  27
  28;; test syntax-rules
  29
  30(define-syntax test
  31  (syntax-rules ()
  32    ((_ x form)
  33     (let ((tmp x))
  34       (if (number? tmp)
  35	   form
  36	   (error "not a number" tmp))))))
  37
  38(t 100 (test 2 100))
  39
  40
  41;; Keywords are not symbols; don't attempt to bind them
  42(t 1 (let-syntax ((foo (syntax-rules () ((foo bar: qux) qux))))
  43       (foo bar: 1)))
  44
  45;; some basic contrived testing
  46
  47(define (fac n)
  48  (let-syntax ((m1
  49		(er-macro-transformer
  50		 (lambda (n r c)
  51		   (pp `(M1: ,n))
  52		   (list (r 'sub1) (cadr n))))))
  53    (define (sub1 . _)			; ref. transp.? (should not be used here)
  54      (error "argh.") )
  55    #;(print "fac: " n)
  56    (if (test n (zero? n))
  57	1
  58	(* n (fac (m1 n))))))
  59
  60(t 3628800 (fac 10))
  61
  62;; letrec-syntax
  63
  64(t 34
  65(letrec-syntax ((foo (syntax-rules () ((_ x) (bar x))))
  66		(bar (syntax-rules () ((_ x) (+ x 1)))))
  67  (foo 33))
  68)
  69
  70;; letrec-values
  71
  72(t '(0 1 2 3 (4) (5 6))
  73   (letrec-values ((() (values))
  74                   ((a) (values 0))
  75                   ((b c) (values 1 2))
  76                   ((d . e) (values 3 4))
  77                   (f (values 5 6)))
  78     (list a b c d e f)))
  79
  80;; from r5rs:
  81
  82(t 45
  83(let ((x 5))
  84  (define foo (lambda (y) (bar x y)))
  85  (define bar (lambda (a b) (+ (* a b) a)))
  86  (foo (+ x 3)))
  87)
  88
  89;; an error, according to r5rs - here it treats foo as defining a toplevel binding
  90
  91#;(let-syntax
  92  ((foo (syntax-rules ()
  93          ((foo (proc args ...) body ...)
  94           (define proc
  95             (lambda (args ...)
  96               body ...))))))
  97  (let ((x 3))
  98    (foo (plus x y) (+ x y))
  99    (define foo x)
 100    (print (plus foo x))))
 101
 102(t 'now
 103(let-syntax ((when (syntax-rules ()
 104                     ((when test stmt1 stmt2 ...)
 105                      (if test
 106                          (begin stmt1
 107                                 stmt2 ...))))))
 108  (let ((if #t))
 109    (when if (set! if 'now))
 110    if))
 111)
 112
 113(t 'outer
 114(let ((x 'outer))
 115  (let-syntax ((m (syntax-rules () ((m) x))))
 116    (let ((x 'inner))
 117      (m))))
 118)
 119
 120(t 7
 121(letrec-syntax
 122  ((my-or (syntax-rules ()
 123            ((my-or) #f)
 124            ((my-or e) e)
 125            ((my-or e1 e2 ...)
 126             (let ((temp e1))
 127               (if temp
 128                   temp
 129                   (my-or e2 ...)))))))
 130  (let ((x #f)
 131        (y 7)
 132        (temp 8)
 133        (let odd?)
 134        (if even?))
 135    (my-or x
 136           (let temp)
 137           (if y)
 138           y)))
 139)
 140
 141;; From Al* Petrofsky's "An Advanced Syntax-Rules Primer for the Mildly Insane"
 142(let ((a 1))
 143  (letrec-syntax
 144      ((foo (syntax-rules ()
 145              ((_ b)
 146               (bar a b))))
 147       (bar (syntax-rules ()
 148              ((_ c d)
 149               (cons c (let ((c 3))
 150                         (list d c 'c)))))))
 151    (let ((a 2))
 152      (t '(1 2 3 a) (foo a)))))
 153
 154;; ER equivalent
 155(let ((a 1))
 156  (letrec-syntax
 157      ((foo (er-macro-transformer
 158             (lambda (x r c)
 159               `(,(r 'bar) ,(r 'a) ,(cadr x)))))
 160       (bar (er-macro-transformer
 161             (lambda (x r c)
 162               (let ((c (cadr x))
 163                     (d (caddr x)))
 164                `(,(r 'cons) ,c
 165                  (,(r 'let) ((,c 3))
 166                   (,(r 'list) ,d ,c ',c))))))))
 167    (let ((a 2))
 168      (t '(1 2 3 a) (foo a)))))
 169
 170;; IR equivalent
 171(let ((a 1))
 172  (letrec-syntax
 173      ((foo (ir-macro-transformer
 174             (lambda (x i c)
 175               `(bar a ,(cadr x)))))
 176       (bar (ir-macro-transformer
 177             (lambda (x i c)
 178               (let ((c (cadr x))
 179                     (d (caddr x)))
 180                 `(cons ,c
 181                        (let ((,c 3))
 182                          (list ,d ,c ',c))))))))
 183    (let ((a 2))
 184      (t '(1 2 3 a) (foo a)))))
 185
 186;; Strip-syntax on vectors:
 187(let-syntax
 188    ((foo (syntax-rules ()
 189            ((_)
 190             '#(b)))))
 191  (t '#(b) (foo)))
 192
 193(define-syntax kw
 194  (syntax-rules (baz)
 195    ((_ baz) "baz")
 196    ((_ any) "no baz")))
 197
 198(t "baz" (kw baz))
 199(t "no baz" (kw xxx))
 200
 201(let ((baz 100))
 202  (t "no baz" (kw baz)))
 203
 204;; Optimisation to rewrite constants with =>, reported by Michele La Monaca
 205(t 2 (cond (1 2)))
 206(f (cond (1 => string-length)))
 207(t #t (cond (1 => odd?)))
 208
 209(t 'ok
 210(let ((=> #f))
 211  (cond (#t => 'ok)))
 212)
 213
 214(t 1 (let ((=> 1))
 215       (cond (#f 'false)
 216             (#t =>))))
 217
 218(t 3 (let ((=> 1))
 219       (cond (#f 'false)
 220             (#t => 2 3))))
 221
 222(t '(3 4)
 223(let ((foo 3))
 224  (let-syntax ((bar (syntax-rules () ((_ x) (list foo x)))))
 225    (let ((foo 4))
 226      (bar foo))))
 227)
 228
 229;;; strip-syntax cuts across multiple levels of syntax
 230;;; reported by Matthew Flatt
 231(define-syntax c
 232  (syntax-rules ()
 233    [(_)
 234     (let ([x 10])
 235       (let-syntax ([z (syntax-rules ()
 236                         [(_) (quote x)])])
 237         (z)))]))
 238
 239(t "x" (symbol->string (c)))
 240
 241(define-syntax c2
 242   (syntax-rules ()
 243     [(_)
 244      (let ([x 10])
 245        (let-syntax ([z (syntax-rules ()
 246                          [(_) (let-syntax ([w (syntax-rules ()
 247                                                 [(_) (quote x)])])
 248                                 (w))])])
 249          (z)))]))
 250
 251(t "x" (symbol->string (c2)))
 252
 253;;; strip-syntax on renamed module identifiers, as well as core identifiers
 254(module foo (bar)
 255  (import scheme)
 256
 257  (define bar 1))
 258
 259(import foo)
 260
 261(define-syntax baz
 262  (er-macro-transformer
 263   (lambda (e r c)
 264     `',(strip-syntax (r 'bar)))))
 265
 266(t "bar" (symbol->string (baz bar)))
 267(t "bar" (symbol->string (baz void)))
 268
 269;; Fully qualified symbols are not mangled - these names are internal
 270;; and not documented, but shouldn't be messed with by the expander
 271
 272(t "foo#bar" (symbol->string 'foo#bar))
 273(t "foo#bar" (symbol->string (strip-syntax 'foo#bar)))
 274
 275(t "#!rest" (symbol->string '#!rest))
 276(t "#!rest" (symbol->string '|#!rest|))
 277(t "#!rest" (symbol->string (strip-syntax '#!rest)))
 278
 279;; Read-write invariance of "special" symbols
 280
 281(t '#!rest (with-input-from-string "#!rest" read))
 282(t '#!rest (with-input-from-string "|#!rest|" read))
 283(t "#!rest" (with-output-to-string (lambda () (write '#!rest))))
 284
 285;; Non-special symbols starting with shebang
 286(f (with-input-from-string "#!foo" read))
 287(t '|#!foo| (with-input-from-string "|#!foo|" read))
 288(t "|#!foo|" (with-output-to-string (lambda () (write '|#!foo|))))
 289
 290;; Namespaced symbols
 291(t "foo#bar" (with-output-to-string (lambda () (write 'foo#bar))))
 292(t "##foo#bar" (with-output-to-string (lambda () (write '##foo#bar))))
 293
 294;; These used to be treated specially, but now they just trigger an
 295;; "invalid sharp-sign read syntax" error.
 296(t "|#%foo|" (with-output-to-string (lambda () (write '|#%foo|))))
 297(f (with-input-from-string "#%foo" read))
 298
 299;;; alternative ellipsis test (SRFI-46)
 300
 301(define-syntax foo
 302  (syntax-rules
 303      ___ ()
 304      ((_ vals ___) (list '... vals ___))))
 305
 306(t '(... 1 2 3)
 307   (foo 1 2 3)
 308)
 309
 310(define-syntax defalias
 311  (syntax-rules ___ ()
 312    ((_ new old)
 313     (define-syntax new
 314       (syntax-rules ()
 315	 ((_ args ...) (old args ...)))))))
 316
 317(defalias inc add1)
 318
 319(t 3 (inc 2))
 320
 321;;; Rest patterns after ellipsis (SRFI-46)
 322
 323(define-syntax foo
 324  (syntax-rules ()
 325    ((_ (a ... b) ... (c d))
 326     (list (list (list a ...) ... b ...) c d))
 327    ((_ #(a ... b) ... #(c d) #(e f))
 328     (list (list (vector a ...) ... b ...) c d e f))
 329    ((_ #(a ... b) ... #(c d))
 330     (list (list (vector a ...) ... b ...) c d))))
 331
 332(t '(() 1 2)
 333   (foo (1 2)))
 334
 335(t '(((1) 2) 3 4)
 336   (foo (1 2) (3 4)))
 337
 338(t '(((1 2) (4) 3 5) 6 7)
 339   (foo (1 2 3) (4 5) (6 7)))
 340
 341(t '(() 1 2)
 342   (foo #(1 2)))
 343
 344(t '((#() 1) 2 3)
 345   (foo #(1) #(2 3)))
 346
 347(t '((#(1 2) 3) 4 5)
 348   (foo #(1 2 3) #(4 5)))
 349
 350(t '((#(1 2) 3) 4 5 6 7)
 351   (foo #(1 2 3) #(4 5) #(6 7)))
 352
 353(t '(() 1 2 3 4)
 354   (foo #(1 2) #(3 4)))
 355
 356(t '((#(1) 2) 3 4 5 6)
 357   (foo #(1 2) #(3 4) #(5 6)))
 358
 359(t '((#(1 2) #(4) 3 5) 6 7 8 9)
 360   (foo #(1 2 3) #(4 5) #(6 7) #(8 9)))
 361
 362;;; Bug discovered during implementation of SRFI-46 rest patterns:
 363
 364(define-syntax foo
 365  (syntax-rules ()
 366    ((_ #((a) ...)) (list a ...))))
 367
 368(t '(1)
 369   (foo #((1))))
 370
 371;;;
 372
 373(define-syntax usetmp
 374  (syntax-rules ()
 375    ((_ var)
 376     (list var))))
 377
 378(define-syntax withtmp
 379  (syntax-rules ()
 380    ((_ val exp)
 381     (let ((tmp val))
 382       (exp tmp)))))
 383
 384(t '(99)
 385   (withtmp 99 usetmp)
 386)
 387
 388(t 7
 389(letrec-syntax
 390    ((my-or (syntax-rules ()
 391	      ((my-or) #f)
 392	      ((my-or e) e)
 393	      ((my-or e1 e2 ...)
 394	       (let ((temp e1))
 395		 (if temp
 396		     temp
 397		     (my-or e2 ...)))))))
 398  (let ((x #f)
 399        (y 7)
 400        (temp 8)
 401        (let odd?)
 402        (if even?))
 403    (my-or x
 404           (let temp)
 405           (if y)
 406           y)))
 407)
 408
 409(define-syntax foo
 410  (syntax-rules ()
 411    ((_ #(a ...)) (list a ...))))
 412
 413(t '(1 2 3)
 414   (foo #(1 2 3))
 415)
 416
 417
 418(define-syntax loop
 419  (er-macro-transformer
 420   (lambda (x r c)
 421     (let ((body (cdr x)))
 422       `(,(r 'call/cc)
 423	 (,(r 'lambda) (exit)
 424	  (,(r 'let) ,(r 'f) () ,@body (,(r 'f)))))))))
 425
 426(let ((n 10))
 427  (loop
 428   (print* n " ")
 429   (set! n (sub1 n))
 430   (when (zero? n) (exit #f)))
 431  (newline))
 432
 433(define-syntax while0
 434  (syntax-rules ()
 435    ((_ t b ...)
 436     (loop (if (not t) (exit #f))
 437	   b ...))))
 438
 439(f (while0 #f (print "no.")))
 440
 441(define-syntax while
 442  (er-macro-transformer
 443   (lambda (x r c)
 444     `(,(r 'loop)
 445       (,(r 'if) (,(r 'not) ,(cadr x)) (exit #f))
 446       ,@(cddr x)))))
 447
 448(let ((n 10))
 449  (while (not (zero? n))
 450	 (print* n " ")
 451	 (set! n (- n 1)) )
 452  (newline))
 453
 454;;; found by Jim Ursetto
 455
 456(let ((lambda 0)) (define (foo) 1) (foo))
 457
 458
 459;;; define-macro implementation (only usable in a module-free environment)
 460
 461(define-syntax define-macro
 462  (syntax-rules ()
 463    ((_ (name . llist) body ...)
 464     (define-syntax name
 465       (er-macro-transformer
 466	(lambda (x r c)
 467	  (apply (lambda llist body ...) (strip-syntax (cdr x)))))))))
 468
 469(define-macro (loop . body)
 470  (let ((loop (gensym)))
 471    `(call/cc
 472      (lambda (exit)
 473	(let ,loop () ,@body (,loop))))))
 474
 475(let ((i 1))
 476  (loop (when (> i 10) (exit #f))
 477	(print* i " ")
 478	(set! i (add1 i))))
 479(newline)
 480
 481
 482;;;; exported macro would override original name (fixed in rev. 13351)
 483
 484(module xfoo (xbaz xbar)
 485  (import scheme)
 486  (define-syntax xbar
 487    (syntax-rules ()
 488      ((_ 1) (xbaz))
 489      ((_) 'xbar)))
 490  (define-syntax xbaz
 491    (syntax-rules ()
 492      ((_ 1) (xbar))
 493      ((_) 'xbazz))))
 494
 495(import xfoo)
 496(assert (eq? 'xbar (xbaz 1)))
 497(assert (eq? 'xbazz (xbar 1)))
 498(assert (eq? 'xbar (xbar)))
 499
 500
 501;;;; ellipsis pattern element wasn't matched - reported by Jim Ursetto (fixed rev. 13582)
 502
 503(define-syntax foo
 504  (syntax-rules ()
 505    ((_ (a b) ...)
 506     (list '(a b) ...))
 507    ((_ a ...)
 508     (list '(a) ...))))
 509
 510(assert (equal? (foo (1 2) (3 4) (5 6)) '((1 2) (3 4) (5 6))))
 511(assert (equal? (foo (1 2) (3) (5 6)) '(((1 2)) ((3)) ((5 6))))) ; failed
 512(assert (equal? (foo 1) '((1))))
 513
 514
 515;;; incorrect lookup for keyword variables in DSSSL llists
 516
 517(module broken-keyword-var ()
 518  (import scheme (chicken base))
 519  ((lambda (#!key string) (assert (not string))))) ; refered to R5RS `string'
 520
 521;;; Missing check for keyword and optional variable types in DSSSL llists
 522
 523(f (eval '(lambda (foo #!key (0 1)) x)))
 524(f (eval '(lambda (foo #!optional (0 1)) x)))
 525
 526;;; compiler didn't resolve expansion into local variable
 527;;; (reported by Alex Shinn, #15)
 528
 529(module unresolve-local (foo)
 530  (import scheme)
 531  (define (foo)
 532    (let ((qux 3))
 533      (let-syntax ((bar (syntax-rules () ((bar) qux))))
 534	(bar))))
 535
 536  (display (foo))
 537  (newline)
 538)
 539
 540
 541;;; incorrect expansion when assigning to something marked '##core#primitive (rev. 14613)
 542
 543(define x 99)
 544
 545(module primitive-assign ()
 546  (import scheme (chicken base))
 547  (let ((x 100)) (set! x 20) (assert (= x 20)))
 548  (set! setter 123))
 549
 550(assert (= x 99))
 551(assert (= 123 setter))
 552
 553
 554;;; prefixed import from `chicken' module with indirect reference to imported syntax
 555;;; (reported by Jack Trades)
 556
 557(module prefixed-self-reference1 (a b c)
 558  (import scheme (prefix chicken.base c:))
 559  (c:define-values (a b c) (values 1 2 3)) )
 560
 561(module prefixed-self-reference2 ()
 562  (import scheme (prefix (chicken base) c:) (prefix (chicken condition) c:))
 563  (c:define-values (a b c) (values 1 2 3))
 564  (c:print "ok")
 565  (c:condition-case
 566   (c:abort "ugh")
 567   (ex () (c:print "caught"))))
 568
 569(module prefixed-self-reference3 (a)
 570  ;; TODO: Switch this around when plain "chicken" has been removed
 571  (import (prefix scheme s.) (prefix (chicken condition) c.))
 572  (s.define (a x y)
 573	    (c.condition-case (s.+ x y) ((exn) "not numbers")))
 574  )
 575
 576(module prefixed-self-reference4 (a)
 577  (import (prefix scheme s.))
 578  (s.define (a x y) (s.and x y)))
 579
 580
 581;;; canonicalization of body captures 'begin (reported by Abdulaziz Ghuloum)
 582
 583(let ((begin (lambda (x y) (bomb)))) 1 2)
 584
 585
 586;;; redefinition of defining forms
 587
 588(module m0001 (foo bar)
 589  (import (prefix scheme s:))
 590  (s:define-syntax foo (syntax-rules () ((_ x) (s:list x))))
 591  (s:define bar 99))
 592
 593(module m0002 ()
 594  (import scheme m0001 chicken.pretty-print)
 595  (pp (foo bar)))
 596
 597
 598;;; renaming of arbitrary structures
 599
 600(module m1 (s1 s2)
 601
 602  (import scheme)
 603
 604  (define-syntax s1 (syntax-rules () ((_ x) (list x))))
 605
 606  (define-syntax s2
 607    (er-macro-transformer
 608     (lambda (x r c)
 609       (r `(vector (s1 ,(cadr x))))))) )	; without renaming the local version of `s1'
 610					; below will be captured
 611
 612(import m1)
 613
 614(let-syntax ((s1 (syntax-rules () ((_ x) x))))
 615  (assert (equal? '#((99)) (s2 99))))
 616
 617;; IR macros
 618
 619(define-syntax loop2
 620  (ir-macro-transformer
 621   (lambda (x i c)
 622     (let ((body (cdr x)))
 623       `(call/cc
 624         (lambda (,(i 'exit))
 625           (let f () ,@body (f))))))))
 626
 627(let ((n 10))
 628  (loop2
 629   (print* n " ")
 630   (set! n (sub1 n))
 631   (when (zero? n) (exit #f)))
 632  (newline))
 633
 634(define-syntax while20
 635  (syntax-rules ()
 636    ((_ t b ...)
 637     (loop2 (if (not t) (exit #f))
 638	    b ...))))
 639
 640(f (while20 #f (print "no.")))
 641
 642(define-syntax while2
 643  (ir-macro-transformer
 644   (lambda (x i c)
 645     `(loop
 646       (if (not ,(cadr x)) (,(i 'exit) #f))
 647       ,@(cddr x)))))
 648
 649(let ((n 10))
 650  (while2 (not (zero? n))
 651          (print* n " ")
 652          (set! n (- n 1)) )
 653  (newline))
 654
 655(module m2 (s3 s4)
 656
 657  (import scheme)
 658
 659  (define-syntax s3 (syntax-rules () ((_ x) (list x))))
 660
 661  (define-syntax s4
 662    (ir-macro-transformer
 663     (lambda (x r c)
 664       `(vector (s3 ,(cadr x)))))) ) ; without implicit renaming the local version
 665                                     ; of `s3' below would be captured
 666
 667(import m2)
 668
 669(let-syntax ((s3 (syntax-rules () ((_ x) x))))
 670  (t '#((99)) (s4 99)))
 671
 672(let ((vector list))
 673  (t '#((one)) (s4 'one)))
 674
 675(define-syntax nest-me
 676  (ir-macro-transformer
 677   (lambda (x i c)
 678     `(let ((,(i 'captured) 1))
 679        ,@(cdr x)))))
 680
 681(t '(1 #(1 #(1)))
 682   (nest-me (list captured
 683                  (let ((captured 2)
 684                        (let 'not-captured)
 685                        (list vector))
 686                    (nest-me (list captured
 687                                   (nest-me (list captured))))))))
 688
 689(define-syntax cond-test
 690  (ir-macro-transformer
 691   (lambda (x i c)
 692     (let lp ((exprs (cdr x)))
 693       (cond
 694        ((null? exprs) '(void))
 695        ((c (caar exprs) 'else)
 696         `(begin ,@(cdar exprs)))
 697        ((c (cadar exprs) '=>)
 698         `(let ((tmp ,(caar exprs)))
 699            (if tmp
 700                (,(caddar exprs) tmp)
 701                ,(lp (cdr exprs)))))
 702        ((c (cadar exprs) (i '==>)) ;; ==> is an Unhygienic variant of =>
 703         `(let ((tmp ,(caar exprs)))
 704            (if tmp
 705                (,(caddar exprs) tmp)
 706                ,(lp (cdr exprs)))))
 707        (else
 708         `(if ,(caar exprs)
 709              (begin ,@(cdar exprs))
 710              ,(lp (cdr exprs)))))))))
 711
 712(t 'yep
 713   (cond-test
 714    (#f 'false)
 715    (else 'yep)))
 716
 717(t 1
 718   (cond-test
 719    (#f 'false)
 720    (1 => (lambda (x) x))
 721    (else 'yep)))
 722
 723(let ((=> #f))
 724  (t 'a-procedure
 725     (cond-test
 726      (#f 'false)
 727      (1 => 'a-procedure)
 728      (else 'yep))))
 729
 730(let ((else #f))
 731  (t (void)
 732     (cond-test
 733      (#f 'false)
 734      (else 'nope))))
 735
 736(t 1
 737   (cond-test
 738    (#f 'false)
 739    (1 ==> (lambda (x) x))
 740    (else 'yep)))
 741
 742(let ((==> #f))
 743  (t 1
 744     (cond-test
 745      (#f 'false)
 746      (1 ==> (lambda (x) x))
 747      (else 'yep))))
 748
 749;; Undefined value (but no compiler error) on empty `else' clauses
 750(t (void) (cond (else)))
 751(t (void) (case 1 (else)))
 752
 753;; Literal quotation of a symbol, injected or not, should always result in that symbol
 754(module ir-se-test (run)
 755  (import scheme chicken.base)
 756  (define-syntax run
 757    (ir-macro-transformer
 758     (lambda (e i c)
 759       `(quote ,(i 'void))))))
 760
 761(import ir-se-test)
 762(t 'void (run))
 763
 764;;; local definitions
 765
 766(define-syntax s2
 767  (syntax-rules ()
 768    ((_) 1)))
 769
 770(define (f1) 3)
 771(define-values (v1 v2) (values 9 10))
 772(define-values (v3 . v4) (values 11 12))
 773(define-values v56 (values 13))
 774
 775(let ()
 776  (define-syntax s2
 777    (syntax-rules ()
 778      ((_) 2)))
 779  42
 780  (define-values (v1 v2) (values 1 2))
 781  (define-values (v3 . v4) (values 3 4))
 782  (define-values v56 (values 5 6))
 783  (define v56-again v56) ; ordering of assignments was broken #1274
 784  43
 785  (define (f1) 4)
 786  (define ((f2)) 4)
 787  (assert (= 4 (f1)))
 788  (assert (= 4 ((f2))))
 789  (assert (= 2 (s2)))
 790  (assert (= 1 v1))
 791  (assert (= 2 v2))
 792  (assert (= 3 v3))
 793  (assert (equal? (list 4) v4))
 794  (assert (equal? (list 5 6) v56))
 795  (assert (equal? (list 5 6) v56-again)))
 796
 797(assert (= 1 (s2)))
 798(assert (= 3 (f1)))
 799(assert (= 9 v1))
 800(assert (= 10 v2))
 801(assert (= 11 v3))
 802(assert (equal? (list 12) v4))
 803(assert (equal? (list 13) v56))
 804
 805;;; redefining definition forms (disabled, since we can not catch this error easily)
 806
 807#|
 808(module m0a () (import chicken.module) (reexport (only scheme define)))
 809(module m0b () (import chicken.module) (reexport (only scheme define-syntax)))
 810
 811(module m1 ()
 812(import (prefix scheme s:) (prefix m0b m:))
 813;(s:define m:define 1)
 814(s:define-syntax s:define-syntax (syntax-rules ()))
 815)
 816|#
 817
 818;;; Definitions of non-identifiers
 819
 820(f (eval '(define foo: 1)))
 821(f (eval '(define-syntax foo: (syntax-rules () ((_) 1)))))
 822(f (eval '(let foo: () 1)))
 823(f (eval '(let ((foo: 1)) 1)))
 824
 825
 826;;; Definitions in expression contexts are rejected (#1309)
 827
 828(f (eval '(+ 1 2 (begin (define x 3) x) 4)))
 829(f (eval '(+ 1 2 (begin (define-values (x y) (values 3 4)) x) 4)))
 830(f (eval '(display (define x 1))))
 831;; Some tests for nested but valid definition expressions:
 832(t 2 (eval '(begin (define x 1) 2)))
 833(t 2 (eval '(module _ () (import scheme) (define x 1) 2)))
 834(t 1 (eval '(let ()
 835	      (define-record-type foo (make-foo bar) foo? (bar foo-bar))
 836	      (foo-bar (make-foo 1)))))
 837
 838;; Nested begins inside definitions were not treated correctly
 839(t 3 (eval '(let () (begin 1 (begin 2 (define internal-def 3) internal-def)))))
 840;; Macros that expand to "define" should not cause a letrec barrier
 841(t 1 (eval '(let-syntax ((my-define (syntax-rules ()
 842				      ((_ var val) (define var val)))))
 843	      (let () (define (run-it) foo) (my-define foo 1) (run-it)))))
 844;; Begin should not cause a letrec barrier
 845(t 1 (eval '(let () (define (run-it) foo) (begin (define foo 1) (run-it)))))
 846(f (eval '(let () internal-def)))
 847
 848;;; renaming of keyword argument (#277)
 849
 850(define-syntax foo1
 851  (syntax-rules ()
 852    ((_ procname)
 853     (define (procname #!key (who "world"))
 854       (string-append "hello, " who)))))
 855
 856(foo1 bar)
 857
 858(assert (string=? "hello, XXX" (bar who: "XXX")))
 859
 860;;; DSSSL keyword arguments in various combinations with optional and rest args
 861;;; reported on IRC by R. Winkler
 862
 863(define (test-optional&rest x y #!optional z #!rest r)
 864  (list x y z r))
 865
 866(assert (equal? '(3 4 5 (6 7)) (test-optional&rest 3 4 5 6 7)))
 867
 868(define (test-optional&rest-cdrs x y #!optional z #!rest r)
 869  (list x y z (cdr (cdr r))))
 870
 871(assert (equal? '(3 4 5 ()) (test-optional&rest-cdrs 3 4 5 6 7)))
 872
 873(define (test-optional&key x y #!optional z #!key i (j 1))
 874  (list x y z i: i j: j))
 875
 876(assert (equal? '(3 4 5 i: 6 j: 7) (test-optional&key 3 4 5 i: 6 j: 7 8)))
 877;; Unfortunate but correct (missing optional arg)
 878(assert (equal? '(3 4 i: i: #f j: 1) (test-optional&key 3 4 i: 6 j: 7 8)))
 879
 880(define (test-key&rest x y #!rest r #!key i (j 1))
 881  (list x y i: i j: j r))
 882
 883(assert (equal? '(3 4 i: 5 j: 1 (i: 5 6 7)) (test-key&rest 3 4 i: 5 6 7)))
 884(assert (equal? '(3 4 i: 5 j: 6 (i: 5 j: 6 7 8))
 885                (test-key&rest 3 4 i: 5 j: 6 7 8)))
 886
 887(define (test-optional-key&rest x y #!optional z #!rest r #!key i (j 1))
 888  (list x y z i: i j: j r))
 889
 890(assert (equal? '(3 4 5 i: 6 j: 7 (i: 6 j: 7 8))
 891                (test-optional-key&rest 3 4 5 i: 6 j: 7 8)))
 892
 893;;; Miscellaneous DSSSL tests
 894
 895;; DSSSL annotations may each appear only once
 896(f (eval '(lambda (x #!optional o1 #!optional o2) 'foo)))
 897(f (eval '(lambda (x #!rest r1 #!rest r1) 'foo)))
 898(f (eval '(lambda (x #!key k1 #!key k2) 'foo)))
 899
 900;; DSSSL annotations must occur in order (optional, rest, key)
 901(f (eval '(lambda (x #!rest r1 #!optional o1) 'foo)))
 902(f (eval '(lambda (x #!key k1 #!optional o1) 'foo)))
 903(f (eval '(lambda (x #!key r1 #!rest k1) 'foo)))
 904
 905;; #!rest limited to 1 arg
 906(f (eval '(lambda (x #!rest r1 r2) 'foo)))
 907
 908;; list arguments invalid for required and rest parameters
 909(f (eval '(lambda ((x 0) #!rest r1) 'foo)))
 910(f (eval '(lambda (x #!rest (r1 0)) 'foo)))
 911
 912;; "optional" expansion should not rely on user imports (hygiene)
 913(t '(1 2)
 914   (eval '(module x ()
 915	    (import (only scheme lambda list))
 916	    ((lambda (x #!optional (y 0)) (list x y)) 1 2))))
 917
 918;; Dotted list syntax can be mixed in
 919(t '(1 2 3 4 (5 6))
 920   ((lambda (x y #!optional o1 o2 . r) (list x y o1 o2 r))
 921    1 2 3 4 5 6))
 922
 923;; More DSSSL hygiene issues, from #806
 924(module dsssl-extended-lambda-list-hygiene ()
 925  (import (prefix scheme s/))
 926  (s/define (foo #!optional bar #!rest qux #!key baz)
 927	    (s/list bar baz qux)))
 928
 929;;; import not seen, if explicitly exported and renamed:
 930
 931(module rfoo (rbar rbaz)
 932(import scheme)
 933
 934(define (rbaz x)
 935  (display x)
 936  (newline) )
 937
 938(define-syntax rbar
 939  (syntax-rules ()
 940    ((_ x) (rbaz x))))
 941
 942)
 943
 944(import (prefix rfoo f:))
 945(f:rbar 1)
 946
 947;;; SRFI-2 (and-let*)
 948
 949(t 1 (and-let* ((a 1)) a))
 950(f (eval '(and-let* ((a 1 2 3)) a)))
 951(t 2 (and-let* ((a 1) (b (+ a 1))) b))
 952(t 3 (and-let* (((or #f #t))) 3))
 953(f (eval '(and-let* ((or #f #t)) 1)))
 954(t 4 (and-let* ((c 4) ((equal? 4 c))) c))
 955(t #f (and-let* ((c 4) ((equal? 5 c))) (error "not reached")))
 956(t #f (and-let* (((= 4 5)) ((error "not reached 1"))) (error "not reached 2")))
 957(t 'foo (and-let* (((= 4 4)) (a 'foo)) a))
 958(t #f (and-let* ((a #f) ((error "not reached 1"))) (error "not reached 2")))
 959
 960(t  (and-let* () 1) 1)
 961(t  (and-let* () 1 2) 2)
 962(t  (and-let* () ) #t)
 963
 964(t (let ((x #f)) (and-let* (x))) #f)
 965(t (let ((x 1)) (and-let* (x))) 1)
 966(t (and-let* ((x #f)) ) #f)
 967(t (and-let* ((x 1)) ) 1)
 968(f (eval '(and-let* ( #f (x 1))) ))
 969(t (and-let* ( (#f) (x 1)) ) #f)
 970(f (eval '(and-let* (2 (x 1))) ))
 971(t (and-let* ( (2) (x 1)) ) 1)
 972(t (and-let* ( (x 1) (2)) ) 2)
 973(t (let ((x #f)) (and-let* (x) x)) #f)
 974(t (let ((x "")) (and-let* (x) x)) "")
 975(t (let ((x "")) (and-let* (x)  )) "")
 976(t (let ((x 1)) (and-let* (x) (+ x 1))) 2)
 977(t (let ((x #f)) (and-let* (x) (+ x 1))) #f)
 978(t (let ((x 1)) (and-let* (((positive? x))) (+ x 1))) 2)
 979(t (let ((x 1)) (and-let* (((positive? x))) )) #t)
 980(t (let ((x 0)) (and-let* (((positive? x))) (+ x 1))) #f)
 981(t (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1)))  3)
 982; The uniqueness of the bindings isn't enforced
 983(t (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1))) 4)
 984
 985(t (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))) 2)
 986(t (let ((x 1)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) 2)
 987(t (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))) #f)
 988(t (let ((x #f)) (and-let* (x ((positive? x))) (+ x 1))) #f)
 989(t (let ((x #f)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) #f)
 990
 991(t  (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f)
 992(t  (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f)
 993(t  (let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f)
 994(t  (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) 3/2)
 995
 996;;; SRFI-26
 997
 998;; Cut
 999(t '() ((cut list)))
 1000(t '() ((cut list <...>)))
1001(t '(1) ((cut list 1)))
1002(t '(1) ((cut list <>) 1))
1003(t '(1) ((cut list <...>) 1))
1004(t '(1 2) ((cut list 1 2)))
1005(t '(1 2) ((cut list 1 <>) 2))
1006(t '(1 2) ((cut list 1 <...>) 2))
1007(t '(1 2 3 4) ((cut list 1 <...>) 2 3 4))
1008(t '(1 2 3 4) ((cut list 1 <> 3 <>) 2 4))
1009(t '(1 2 3 4 5 6) ((cut list 1 <> 3 <...>) 2 4 5 6))
1010(t '(ok) (let* ((x 'wrong)
1011                (y (cut list x)))
1012           (set! x 'ok)
1013           (y)))
1014(t 2 (let ((a 0))
1015       (map (cut + (begin (set! a (+ a 1)) a) <>)
1016            '(1 2))
1017       a))
1018(f (eval '((cut + <...> 1) 1)))
1019
1020;; Cute
1021(t '() ((cute list)))
1022(t '() ((cute list <...>)))
1023(t '(1) ((cute list 1)))
1024(t '(1) ((cute list <>) 1))
1025(t '(1) ((cute list <...>) 1))
1026(t '(1 2) ((cute list 1 2)))
1027(t '(1 2) ((cute list 1 <>) 2))
1028(t '(1 2) ((cute list 1 <...>) 2))
1029(t '(1 2 3 4) ((cute list 1 <...>) 2 3 4))
1030(t '(1 2 3 4) ((cute list 1 <> 3 <>) 2 4))
1031(t '(1 2 3 4 5 6) ((cute list 1 <> 3 <...>) 2 4 5 6))
1032(t 1 (let ((a 0))
1033       (map (cute + (begin (set! a (+ a 1)) a) <>)
1034            '(1 2))
1035       a))
1036(f (eval '((cute + <...> 1) 1)))
1037
1038;;; (quasi-)quotation
1039
1040(f (eval '(let ((a 1)) (unquote a))))
1041(t 'unquote (quasiquote unquote))
1042(f (eval '(quasiquote (a unquote . 1)))) ; "Bad syntax". Also ok: '(a unquote . 1)
1043(t 'a (quasiquote a))
1044(f (eval '(quasiquote a b)))
1045(f (eval '(quote a b)))
1046(f (eval '(quasiquote)))
1047(f (eval '(quote)))
1048(f (eval '(quasiquote . a)))
1049(f (eval '(quote . a)))
1050(t '(foo . 1) (let ((bar 1))
1051                (quasiquote (foo . (unquote bar)))))
1052(f (eval '(let ((a 1)
1053                (b 2))
1054            (quasiquote (unquote a b))))) ; > 1 arg
1055
1056(t '(quasiquote (unquote a)) (quasiquote (quasiquote (unquote a))))
1057(t '(quasiquote x y) (quasiquote (quasiquote x y)))
1058
1059(t '(unquote-splicing a) (quasiquote (unquote-splicing a)))
1060(t '(1 2) (let ((a (list 2))) (quasiquote (1 (unquote-splicing a)))))
1061(f (eval '(let ((a 1))                  ; a is not a list
1062            (quasiquote (1 (unquote-splicing a) 2)))))
1063(f (eval '(let ((a (list 1))
1064                (b (list 2)))
1065            (quasiquote (1 (unquote-splicing a b)))))) ; > 1 arg
1066
1067;; level counting
1068(define x (list 1 2))
1069
1070;; Testing R5RS-compliance:
1071(t '(quasiquote (unquote (1 2)))
1072   (quasiquote (quasiquote (unquote (unquote x)))))
1073(t '(quasiquote (unquote-splicing (1 2)))
1074   (quasiquote (quasiquote (unquote-splicing (unquote x)))))
1075(t '(quasiquote (unquote 1 2))
1076   (quasiquote (quasiquote (unquote (unquote-splicing x)))))
1077(t 'x
1078   (quasiquote (unquote (quasiquote x))))
1079(t '(quasiquote (unquote-splicing (quasiquote (unquote x))))
1080   (quasiquote (quasiquote (unquote-splicing (quasiquote (unquote x))))))
1081(t '(quasiquote (unquote (quasiquote (unquote-splicing x))))
1082   (quasiquote (quasiquote (unquote (quasiquote (unquote-splicing x))))))
1083(t '(quasiquote (unquote (quasiquote (unquote (1 2)))))
1084   (quasiquote (quasiquote (unquote (quasiquote (unquote (unquote x)))))))
1085
1086;; The following are explicitly left undefined by R5RS. For consistency
1087;; we define any unquote-(splicing) or quasiquote that occurs in the CAR of
1088;; a pair to decrease, respectively increase the level count by one.
1089
1090(t '(quasiquote . #(1 (unquote x) 3))   ; cdr is not a pair
1091   (quasiquote (quasiquote . #(1 (unquote x) 3))))
1092(t '(quasiquote #(1 (unquote x) 3))     ; cdr is a list of one
1093   (quasiquote (quasiquote #(1 (unquote x) 3))))
1094(t '(quasiquote a #(1 (unquote x) 3) b) ; cdr is longer
1095   (quasiquote (quasiquote a #(1 (unquote x) 3) b)))
1096
1097(t '(quasiquote (unquote . #(1 (1 2) 3))) ; cdr is not a pair
1098   (quasiquote (quasiquote (unquote . #(1 (unquote x) 3)))))
1099(t '(quasiquote (unquote #(1 (1 2) 3))) ; cdr is a list of one
1100   (quasiquote (quasiquote (unquote #(1 (unquote x) 3)))))
1101(t '(quasiquote (unquote a #(1 (1 2) 3) b)) ; cdr is longer
1102   (quasiquote (quasiquote (unquote a #(1 (unquote x) 3) b))))
1103
1104(t '(quasiquote (unquote-splicing . #(1 (1 2) 3))) ; cdr is not a pair
1105   (quasiquote (quasiquote (unquote-splicing . #(1 (unquote x) 3)))))
1106(t '(quasiquote (unquote-splicing #(1 (1 2) 3))) ; cdr is a list of one
1107   (quasiquote (quasiquote (unquote-splicing #(1 (unquote x) 3)))))
1108(t '(quasiquote (unquote-splicing a #(1 (1 2) 3) b)) ; cdr is longer
1109   (quasiquote (quasiquote (unquote-splicing a #(1 (unquote x) 3) b))))
1110
1111(t 'quasiquote (quasiquote quasiquote))
1112(t 'unquote (quasiquote unquote))
1113(t 'unquote-splicing (quasiquote unquote-splicing))
1114(t '(x quasiquote) (quasiquote (x quasiquote)))
1115; (quasiquote (x unquote)) is identical to (quasiquote (x . (unquote)))....
1116;; It's either this (error) or make all calls to unquote with more or less
1117;; than one argument resolve to a literal unquote.
1118(f (eval '(quasiquote (x unquote))))
1119(t '(x unquote-splicing) (quasiquote (x unquote-splicing)))
1120;; Let's internal defines properly compared to core define procedure when renamed
1121(f (eval '(let-syntax ((foo (syntax-rules () ((_ x) (begin (define x 1))))))
1122            (let () (foo a))
1123            (print "1: " a))))
1124
1125(t '(a 1) (letrec-syntax ((define (syntax-rules () ((_ x y) (list 'x y))))
1126                          (foo (syntax-rules () ((_ x) (define x 1)))))
1127            (let () (foo a))))
1128
1129(t '(1) (let-syntax ((define (syntax-rules () ((_ x) (list x)))))
1130          (let () (define 1))))
1131
1132;; Local override: not a macro
1133(t '(1) (let ((define list)) (define 1)))
1134
1135;; Toplevel (no SE)
1136(define-syntax foo (syntax-rules () ((_ x) (begin (define x 1)))))
1137(foo a)
1138(t 1 a)
1139
1140
1141;; ,@ in tail pos with circular object - found in trav2 benchmark and
1142;; reported by syn:
1143
1144(let ((a '(1)))
1145  (set-cdr! a a)
1146  `(1 ,@a))
1147
1148
1149;; ##sys#alias-global-hook, when invoked via eval/meta, did resolve identifiers
1150;; used during evaluation of an expander body in the wrong environment and mapped
1151;; an identifier to something imported for the runtime environment
1152
1153(module foonumbers (+)
1154  (import (except scheme +) (only (chicken base) error))
1155  (define (+ . _) (error "failed.")))
1156
1157(import foonumbers)
1158
1159(define-syntax foo
1160  (er-macro-transformer
1161   (lambda (x r c)
1162     `(print ,(+ (cadr x) 1)))))
1163
1164(foo 3)
1165
1166
1167;; #578: import with specifier has no effect for internal modules on csi's top-level
1168
1169(import srfi-4)
1170(import (prefix srfi-4 other-))
1171u8vector
1172other-u8vector
1173
1174(import (prefix scheme other-))
1175eval
1176other-eval
1177
1178
1179;; #805: case-lambda is unhygienic (see 4706afb4 and bc5cc698)
1180(module case-lambda-and-ensure-hygiene ()
1181  (import (prefix (scheme case-lambda) c/) (prefix scheme s/))
1182  (c/case-lambda ((a) a)))
1183
1184
1185;; #816: compiler-syntax should obey hygiene in its rewrites
1186(module foo ()
1187  (import (prefix (only scheme map lambda list) ~))
1188  (~map (~lambda (y) y) (~list 1)))
1189
1190;; #852: renamed macros should not be returned as first-class
1191;;       objects in the interpreter
1192(module renamed-macros (renamed-macro-not-firstclassed)
1193  (import scheme chicken.base)
1194  (define-syntax renamed-macro-not-firstclassed
1195    (er-macro-transformer
1196     (lambda (e r c)
1197       `(,(r 'list) ,(r 'define))))))
1198
1199(f (eval '(begin (import renamed-macros) (renamed-macro-not-firstclassed))))
1200
1201;; #893: implicitly renamed variables shouldn't be resolved to core
1202;;       builtins (#%xyz), but go through a level of indirection, so
1203;;       strip-syntax can still access the original symbol.
1204(module rename-builtins
1205 (strip-syntax-on-*)
1206 (import scheme chicken.base)
1207 (define-syntax strip-syntax-on-*
1208   (ir-macro-transformer
1209    (lambda (e r c) '(quote *)))))
1210
1211(import rename-builtins)
1212(assert (eq? '* (strip-syntax-on-*)))
1213
1214;; #1362: Double rename would cause "renamed" var to be restored to
1215;; the original macro aliased name (resulting in a plain symbol)
1216(let-syntax ((wrapper/should-do-nothing
1217              (er-macro-transformer
1218               (lambda (e r c)
1219                 (let* ((%x (r 'x))
1220                        (%%x (r %x)))
1221                   `(let ((,%x 1)
1222                          (,%%x 2))
1223                      ,(cadr e)))))))
1224  (print (let ((x 1)) (wrapper/should-do-nothing x))))
1225
1226;; Same net effect as above, but more complex by the use of IR macros.
1227(letrec-syntax ((bind-pair
1228                 (ir-macro-transformer
1229                  (lambda (e i c)
1230                    (let* ((b (cadr e))
1231                           (exp (caddr e))
1232                           (body (cdddr e)))
1233                      `(let* ((x ,exp)
1234                              (,(car b) (car x))
1235                              (,(cadr b) (cdr x)))
1236                         ,@body)))))
1237                (foo
1238                 (ir-macro-transformer
1239                  (lambda (e i c)
1240                    `(bind-pair (x y) (cons 'foo-car 'foo-cdr) y)))))
1241  (assert (eq? 'second (bind-pair (x y) (cons 'first 'second) y)))
1242  (assert (eq? 'foo-cdr (foo))))
1243
1244;; #944: macro-renamed defines mismatch with the names recorded in module
1245;;       definitions, causing the module to be unresolvable.
1246
1247(module foo ()
1248  (import scheme)
1249  (define-syntax bar
1250    (syntax-rules ()
1251      ((_) (begin (define req 1) (display req) (newline)))))
1252  (bar))
1253
1254;; The fix for the above bug causes the req to be defined at toplevel,
1255;; unhygienically.  The test below should probably be enabled and this
1256;; behavior fixed.  R5RS seems to allow the current behavior though (?),
1257;; and some Schemes (at least Gauche) behave the same way.  I think it's
1258;; broken, since it's unhygienic.
1259#;(module foo ()
1260  (import scheme)
1261  (define req 1)
1262  (define-syntax bar
1263    (syntax-rules ()
1264      ((_) (begin (define req 2) (display req) (newline)))))
1265  (bar)
1266  (assert (eq? req 1)))
1267
1268
1269;; Includes should be spliced into the surrounding body context:
1270
1271(begin-for-syntax
1272  (with-output-to-file "x.out" (cut pp '(define x 2))))
1273
1274(let ()
1275  (define x 1)
1276  (include "x.out")
1277  (t 2 x))
1278
1279(let ()
1280  (define x 1)
1281  (let ()
1282    (include "x.out"))
1283  (t 1 x))
1284
1285;; letrec vs. letrec*
1286
1287;;XXX this fails - the optimizer substitutes "foo" for it's known constant value
1288#;(t (void) (letrec ((foo 1)
1289		   (bar foo))
1290	    bar))
1291
1292;; Obscure letrec issue #1068
1293(t 1 (letrec ((foo (lambda () 1))
1294	      (bar (let ((tmp (lambda (x) (if x (foo) (bar #t)))))
1295		     tmp)))
1296       (bar #f)))
1297
1298;; Deeper issue uncovered by fixing the above issue
1299(t 1 (letrec ((bar (lambda (x) (if x 1 (bar bar)))))
1300       (bar #f)))
1301
1302;; Just to verify (this has always worked)
1303(t 1 (letrec* ((foo (lambda () 1))
1304	       (bar (let ((tmp (lambda (x) (if x (foo) (bar #t)))))
1305		      tmp)))
1306       (bar #f)))
1307
1308(t 1 (letrec* ((foo 1)
1309	       (bar foo))
1310       bar))
1311
1312
1313;; This would crash in nasty ways (see #1493, reported by megane)
1314(module self-redefinition (foo)
1315  (import scheme (chicken base))
1316
1317  (define-syntax foo
1318    (ir-macro-transformer
1319     (lambda (e i c)
1320       (apply
1321	(lambda (name)
1322	  `(begin
1323	     (define-syntax ,(strip-syntax name)
1324	       (syntax-rules () ((_ . _) 'new)))
1325	     'old))
1326	(cdr e))))))
1327
1328(import (rename self-redefinition (foo imported-foo)))
1329(import (rename self-redefinition (foo reimported-foo)))
1330
1331(t 'old (imported-foo imported-foo))
1332(t 'new (imported-foo imported-foo))
1333
1334;; Like any normal redefinition, the underlying exported identifier
1335;; changes, and any other imports are simply aliases.
1336;;(t 'old (reimported-foo reimported-foo))
1337(t 'new (reimported-foo reimported-foo))
1338
1339;; #1166
1340(module val-vs-syn1 *
1341  (import scheme)
1342  (define-syntax bar (syntax-rules () ((_) 'bar)))
1343  (define (bar) 99)
1344)
1345
1346(module test-val-vs-syn1 ()
1347   (import scheme (chicken base) val-vs-syn1)
1348   (assert (eq? 99 (bar))))
1349
1350(module val-vs-syn2 *
1351  (import scheme)
1352  (define (bar) 99)
1353  (define-syntax bar (syntax-rules () ((_) 'bar)))
1354)
1355
1356(module test-val-vs-syn2 ()
1357   (import scheme (chicken base) val-vs-syn2)
1358   (assert (eq? 'bar (bar))))
1359
1360(define begin -)
1361(assert (eq? -1 (begin 0 1)))
1362
1363;; #1736 - dotted pairs after ellipsis
1364
1365(define-syntax match-ellipsis-and-dotted-tail1
1366  (syntax-rules ()
1367    ((_ a ... . b)
1368     '(a ... b))))
1369
1370(t '(x y z) (match-ellipsis-and-dotted-tail1 x y . z))
1371
1372(define-syntax match-ellipsis-and-dotted-tail2
1373  (syntax-rules ()
1374    ((_ (a) ... . (b))
1375     '(a ... b))))
1376
1377(t '(x y z) (match-ellipsis-and-dotted-tail2 (x) (y) z))
1378
1379;; from SRFI-46 document:
1380(define-syntax fake-begin
1381  (syntax-rules ()
1382    ((fake-begin ?body ... ?tail)
1383     (let* ((ignored ?body) ...) ?tail))))
1384
1385(t 3 (fake-begin 1 2 3))
1386
1387;; #1793
1388
1389(let ([x 'outer])
1390   (define-syntax m
1391     (syntax-rules ()
1392       ((m a)
1393        (let ([a 'inner]) x))))
1394   (t 'outer (m x)))
1395
1396; fails with error when compiled ("toplevel def. in non-toplevel context")
1397#;(let ([x 'outer])
1398   (define-syntax m
1399     (syntax-rules ()
1400       ((m a)
1401        (begin
1402          (define a 'inner)
1403          x))))
1404   (m x)
1405   (t 'inner x))