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