1;;; 8.ms 2;;; Copyright 1984-2017 Cisco Systems, Inc. 3;;; 4;;; Licensed under the Apache License, Version 2.0 (the "License"); 5;;; you may not use this file except in compliance with the License. 6;;; You may obtain a copy of the License at 7;;; 8;;; http://www.apache.org/licenses/LICENSE-2.0 9;;; 10;;; Unless required by applicable law or agreed to in writing, software 11;;; distributed under the License is distributed on an "AS IS" BASIS, 12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13;;; See the License for the specific language governing permissions and 14;;; limitations under the License. 15 16(mat define-syntax 17 (begin (define-syntax foo 18 (syntax-rules () 19 [(foo a b) (list a b)])) 20 #t) 21 (error? (expand '(foo))) 22 (error? (expand '(foo . a))) 23 (error? (expand '(foo a))) 24 (error? (expand '(foo a . b))) 25 (equal? (foo 3 4) '(3 4)) 26;; (equal? (expand-once '(foo 3 4)) '(list 3 4)) 27 (equal? (foo 3 4) '(3 4)) 28 (error? (expand '(foo a b . c))) 29 (error? (expand '(foo a b c))) 30 (begin (define-syntax foo 31 (syntax-rules (bar) 32 [(foo) '()] 33 [(foo (bar x)) x] 34 [(foo x) (cons x '())] 35 [(foo x y ...) (cons x (foo y ...))])) 36 #t) 37 (equivalent-expansion? (expand '(foo)) ''()) 38 (equivalent-expansion? (expand '(foo (bar a))) 'a) 39 (equal? (foo 'a) '(a)) 40;; (equal? (expand-once '(foo a b c)) '(cons a (foo b c))) 41 (equal? (foo 'a 'b 'c) '(a b c)) 42 (equal? (foo 'a 'b (bar 'c)) '(a b . c)) 43 (equal? (foo 'a 'b 'c 'd) '(a b c d)) 44 (equal? (foo 'a 'b 'c (bar 'd)) '(a b c . d)) 45 (begin (define-syntax foo 46 (lambda (x) 47 (syntax-case x () 48 [(_ ((x v) ...) e1 e2 ...) 49 (andmap symbol? '(x ...)) 50 (syntax ((lambda (x ...) e1 e2 ...) v ...))] 51 [(_ ((lambda (x ...) e1 e2 ...) v ...)) 52 (= (length '(x ...)) (length '(v ...))) 53 (syntax (foo ((x v) ...) e1 e2 ...))]))) 54 #t) 55 (equal? (foo ((a 3) (b 4)) (cons a b)) '(3 . 4)) 56 (error? (expand '(foo ((1 b) (c d)) e f g))) 57 (error? (expand '(foo ((lambda (a c) e f g) b)))) 58 (error? (define-syntax foo (syntax-rules (...) [(foo ...) 0]))) 59 ; no longer an error: 60 #;(error? (define-syntax foo (syntax-rules () [(foo x ... y) 0]))) 61 (error? (define-syntax foo (syntax-rules () [(foo x . ...) 0]))) 62 (error? (define-syntax foo (syntax-rules () [(foo (...)) 0]))) 63 (error? (define-syntax foo (syntax-rules () [(foo x x) 0]))) 64 (begin (define-syntax foo (syntax-rules () [(foo foo) 0])) #t) 65 (begin (define-syntax foo 66 (lambda (x) 67 (syntax-case x () 68 [(_ keys) 69 (with-syntax ([x `,(syntax keys)]) (syntax x))]))) 70 (equivalent-expansion? (expand '(foo (a b c))) '(a b c))) 71 (begin (define-syntax foo ; test exponential "with" time problem 72 (lambda (x) 73 (syntax-case x () 74 [(_) 75 (with-syntax 76 ([a1 1] [b1 2] [c1 3] [d1 4] [e1 5] [f1 6] [g1 7] [h1 8] 77 [a2 1] [b2 2] [c2 3] [d2 4] [e2 5] [f2 6] [g2 7] [h2 8] 78 [a3 1] [b3 2] [c3 3] [d3 4] [e3 5] [f3 6] [g3 7] [h3 8] 79 [a4 1] [b4 2] [c4 3] [d4 4] [e4 5] [f4 6] [g4 7] [h4 8] 80 [a5 1] [b5 2] [c5 3] [d5 4] [e5 5] [f5 6] [g5 7] [h5 8] 81 [a6 1] [b6 2] [c6 3] [d6 4] [e6 5] [f6 6] [g6 7] [h6 8] 82 [a7 1] [b7 2] [c7 3] [d7 4] [e7 5] [f7 6] [g7 7] [h7 8] 83 [a8 1] [b8 2] [c8 3] [d8 4] [e8 5] [f8 6] [g8 7] [h8 8]) 84 (syntax (list a1 b2 c3 d4 e5 f6 g7 h8)))]))) 85 (equal? (foo) '(1 2 3 4 5 6 7 8))) 86 (eqv? (let () 87 (let-syntax () (define x 3) (define y 4)) 88 (define z (lambda () (+ x y))) 89 (z)) 90 7) 91 (eqv? (let () 92 (let-syntax ((a (syntax-rules () 93 ((_ x v) (define x v)))) 94 (b (syntax-rules () 95 ((_ x v) (define-syntax x 96 (syntax-rules () 97 ((_) v))))))) 98 (a x 3) 99 (b y 4)) 100 (define z (lambda () (+ x (y)))) 101 (z)) 102 7) 103 (eqv? 104 (let-syntax ((a (eval '(lambda (x) (let ((x x)) (syntax 3)))))) 105 (a)) 106 3) 107 (error? 108 (begin 109 (define-syntax x (let ((a 3)) (identifier-syntax (define a 4)))) 110 x)) 111 (error? 112 (begin 113 (define-syntax x (let ((a 3)) (identifier-syntax (set! a 4)))) 114 x)) 115 (error? 116 (begin 117 (define-syntax x 118 (let ((a 3)) 119 (identifier-syntax 120 (fluid-let-syntax ((a (identifier-syntax 4))) 121 3)))) 122 x)) 123 ;; transformers expressions can reference local keywords 124 (eqv? 125 (let-syntax ((a (lambda (x) (syntax (lambda (y) (syntax 3)))))) 126 (let-syntax ((b a)) 127 b)) 128 3) 129 (eqv? 130 (let-syntax ((a (lambda (x) (syntax (lambda (y) (syntax 3)))))) 131 (letrec-syntax ((b a)) 132 b)) 133 3) 134 (eqv? 135 (let-syntax ((a (lambda (x) (syntax (lambda (y) (syntax 3)))))) 136 (fluid-let-syntax ((b a)) 137 b)) 138 3) 139 (eqv? 140 (let-syntax ((a (lambda (x) (syntax (lambda (y) (syntax 3)))))) 141 (let () 142 (define-syntax b a) 143 b)) 144 3) 145 (let-syntax ((a (lambda (x) #'(lambda (x) #'3)))) 146 (define-syntax top-level-b a) 147 (eqv? top-level-b 3)) 148 ;; transformers expressions cannot reference local variables 149 (error? 150 (let ((a (lambda (x) x))) 151 (let-syntax ((b a)) 152 b))) 153 (error? 154 (let ((a (lambda (x) x))) 155 (letrec-syntax ((b a)) 156 b))) 157 (error? 158 (let ((a (lambda (x) x))) 159 (fluid-let-syntax ((b a)) 160 b))) 161 (error? 162 (let ((a (lambda (x) x))) 163 (let () 164 (define-syntax b a) 165 b))) 166 ;; transformers expressions cannot reference pattern variables 167 (error? 168 (let-syntax ([foo 169 (lambda (x) 170 (syntax-case x () 171 [(_ z ...) 172 (let-syntax ([bar (lambda (y) #'(z ...))]) 173 (bar))]))]) 174 (foo + 8 9 10))) 175 ;; but can expand into syntax forms containing pattern variable references 176 (equal? 177 (let-syntax ([foo 178 (lambda (x) 179 (syntax-case x () 180 [(_ z ...) 181 (let-syntax ([bar (lambda (y) #'#'(z (... ...)))]) 182 (bar))]))]) 183 (foo + 8 9 10)) 184 27) 185 186 (procedure? (eval (expand '(rec f (lambda (x) x))))) 187 ; make sure we're using the right environment for evaluating transformers 188 (eq? (let () 189 (define x 3) 190 (let-syntax ((x (identifier-syntax (identifier-syntax 4)))) 191 (define-syntax a x)) 192 a) 193 4) 194 ; make sure local-syntax bindings aren't visible outside their scope 195 (equal? 196 (let ([a 14]) 197 (module (x y) 198 (let-syntax ((a (identifier-syntax 3))) 199 (define x a)) 200 (define y a)) 201 (cons x y)) 202 '(3 . 14)) 203 (begin 204 (define $ds-a 14) 205 (module ($ds-x $ds-y) 206 (letrec-syntax ((a (identifier-syntax 3))) 207 (define $ds-x a)) 208 (define $ds-y $ds-a)) 209 (equal? (cons $ds-x $ds-y) '(3 . 14))) 210 ; make sure both introduced references and defines are scoped the same 211 (eq? (let () 212 (define-syntax a (identifier-syntax (begin (define x 3) x))) 213 (let () a)) 214 3) 215 216 (begin 217 (define $a 'aaa) 218 (define $x 'xxx) 219 (define-syntax $introduce-module 220 (identifier-syntax 221 (begin (module $a ($x) (define $x 73)) 222 (import $a) 223 (eq? $x 73)))) 224 $introduce-module) 225 (eq? $a 'aaa) ; make sure introduced module binding isn't visible 226 (eq? $x 'xxx) ; make sure introduced and imported variable isn't visible 227 (eq? (top-level-value '$a) 'aaa) 228 (eq? (top-level-value '$x) 'xxx) 229 (begin 230 (define-syntax $dsmat-foo1 231 (lambda (x) 232 (syntax-case x () 233 ((_ name arg ...) 234 (with-syntax (($... (syntax (... ...)))) 235 (syntax 236 (begin 237 (define $dsmat-y 10) 238 (define-syntax name 239 (lambda (z) 240 (syntax-case z () 241 ((_ a $...) 242 (syntax (list 243 $dsmat-y 244 a $...))))))))))))) 245 #t) 246 (begin ($dsmat-foo1 $dsmat-bar) #t) 247 (error? ($dsmat-bar $dsmat-y)) 248 (begin (define $dsmat-y 77) #t) 249 (equal? ($dsmat-bar $dsmat-y) '(10 77)) 250 (error? ; misplaced ellipsis 251 (with-syntax ([x 3]) #'#(... (x)))) 252 (equal? 253 (let () 254 (define b) 255 (define d) 256 (define-syntax a 257 (lambda (x) 258 (syntax-case x (b c) 259 [(_ b) "b"] 260 [(_ c) "c"] 261 [(_ bar) (free-identifier=? #'bar #'d) "d"] 262 [(_ bar) (free-identifier=? #'bar #'e) "e"] 263 [(_ bar bee) 264 (bound-identifier=? #'bar #'bee) 265 (symbol->string (datum bar))] 266 [_ "nope"]))) 267 (list (a b) (a c) (a d) (a e) (a b b) (a c c) (a f))) 268 '("b" "c" "d" "e" "b" "c" "nope")) 269 (equal? 270 (let () 271 (define-syntax letrec 272 (lambda (x) 273 (syntax-case x () 274 [(_ ((i v) ...) e1 e2 ...) 275 (with-syntax ([(t ...) (generate-temporaries #'(i ...))]) 276 #'(let ([i #f] ...) 277 (let ([t v] ...) 278 (set! i t) 279 ... 280 (let () e1 e2 ...))))]))) 281 (list 282 (letrec ([f (lambda (x) 283 (if (zero? x) 'odd (g (- x 1))))] 284 [g (lambda (x) (if (zero? x) 'even (f (- x 1))))]) 285 (and (eq? (g 10) 'even) 286 (eq? (g 13) 'odd) 287 (eq? (f 13) 'even))) 288 (letrec ([v 0] [k (call/cc (lambda (x) x))]) 289 (set! v (+ v 1)) 290 (k (lambda (x) v))))) 291 '(#t 1)) 292 (equal? 293 (let () 294 (define-syntax main ; Anton's example 295 (lambda (stx) 296 (let ((make-swap 297 (lambda (x y) 298 (with-syntax ((x x) (y y) ((t) (generate-temporaries '(*)))) 299 (syntax 300 (let ((t1 x)) 301 (set! x y) 302 (set! y t1))))))) 303 (syntax-case stx () 304 ((_) 305 (with-syntax ((swap (make-swap (syntax s) (syntax t)))) 306 (syntax 307 (let ((s 1) (t 2)) 308 swap 309 (list s t))))))))) 310 (main)) 311 '(2 1)) 312 ; make sure second definition of marked id works like set! 313 (begin 314 (define $ds-b '()) 315 (define-syntax $ds-a 316 (lambda (x) 317 #'(begin 318 (define q 33) 319 (define (f) q) 320 (set! $ds-b (cons (f) $ds-b)) 321 (define q 55) 322 (set! $ds-b (cons (f) $ds-b)) 323 (set! $ds-b (cons q $ds-b)) 324 #t))) 325 #t) 326 $ds-a 327 (equal? $ds-b '(55 55 33)) 328 329 ; check underscore as wildcard 330 (equal? 331 (let () 332 (define-syntax a 333 (lambda (x) 334 (syntax-case x () 335 [(_ id e) 336 #'(let () 337 (define-syntax id 338 (lambda (x) 339 (syntax-case x () 340 [(_ q _) #'(list q '_)]))) 341 e)]))) 342 (a xxx (xxx (cons (xxx 3 (/ 1 0)) 4) (/ 1 0)))) 343 '(((3 _) . 4) _)) 344 345 (equal? 346 (let ([b 1] [c 2] [d 3] [e 4] [f 5] [g 6]) 347 (define-syntax a 348 (syntax-rules () 349 [(_ x _ y _ z _) 350 (list x y 'z '_)])) 351 (a b c d e f g)) 352 '(1 3 f _)) 353 ; test syntax-rules fender 354 (eqv? 355 (let () 356 (define-syntax k 357 (syntax-rules () 358 [(_ a b) (identifier? #'a) (let ((a (+ b 1))) (* a b))])) 359 (let ([x 4]) (k x (+ x 3)))) 360 88) 361 ; test for mishandling of underscore introduced by syntax-rules 362 (equal? 363 (let ([_ 3]) 364 (define-syntax a (lambda (x) (syntax-case x (_) [(k _) 4] [(k x) #'(* x x)]))) 365 (list (a _))) 366 '(4)) 367 (equal? 368 (let ([_ 3]) 369 (define-syntax a (syntax-rules (_) [(k _) 4] [(k x) (* x x)])) 370 (list (a _))) 371 '(4)) 372) 373 374(mat r6rs:syntax-rules 375 (equal? 376 (let ([b 1] [c 2] [d 3] [e 4] [f 5] [g 6]) 377 (import (rnrs)) 378 (define-syntax a 379 (syntax-rules () 380 [(_ x _ y _ z _) 381 (list x y 'z '_)])) 382 (a b c d e f g)) 383 '(1 3 f _)) 384 (equal? 385 (let () 386 (import (rnrs)) 387 (define-syntax a 388 (syntax-rules (b) 389 [(_ b) "yup"] 390 [(_ c) (list c)])) 391 (list (a b) (a 3))) 392 '("yup" (3))) 393 ; test syntax-rules fender 394 (error? 395 (let () 396 (import (rnrs)) 397 (define-syntax k 398 (syntax-rules () 399 [(_ a b) (identifier? #'a) (let ((a (+ b 1))) (* a b))])) 400 (let ([x 4]) (k x (+ x 3))))) 401 (error? 402 (let () 403 (import (rnrs)) 404 (syntax-rules (_)))) 405 (error? (syntax-rules (_))) 406 (error? 407 (let () 408 (import (rnrs)) 409 (syntax-rules (...)))) 410 (error? (syntax-rules (...))) 411 ; test for mishandling of underscore introduced by syntax-rules 412 (equal? 413 (let () 414 (import (rnrs)) 415 (let ([_ 3]) 416 (define-syntax a (syntax-rules (_) [(k _) 4] [(k x) (* x x)])) 417 (list (a _)))) 418 '(4)) 419) 420 421(mat definition-not-permitted 422 ; top level 423 (error? ; definition not permitted 424 (let-syntax ((frob (lambda (x) #'(void)))) 425 (define frob 15))) 426 (error? ; definition not permitted 427 (let-syntax ((frob (lambda (x) #'(void)))) 428 (define-syntax frob (identifier-syntax 15)))) 429 (error? ; definition not permitted 430 (let-syntax ((frob (lambda (x) #'(void)))) 431 (module frob (x) (define x 15)))) 432 (error? ; definition not permitted 433 (let-syntax ((frob (lambda (x) #'(void)))) 434 (alias frob cons))) 435 ; top level module body 436 (error? ; definition not permitted 437 (module (frob) 438 (let-syntax ((frob (lambda (x) #'(void)))) 439 (define frob -15)))) 440 (error? ; definition not permitted 441 (module (frob) 442 (let-syntax ((frob (lambda (x) #'(void)))) 443 (define-syntax frob (identifier-syntax -15))))) 444 (error? ; definition not permitted 445 (module (frob) 446 (let-syntax ((frob (lambda (x) #'(void)))) 447 (module frob (x) (define x -15))))) 448 (error? ; definition not permitted 449 (module (frob) 450 (let-syntax ((frob (lambda (x) #'(void)))) 451 (alias frob cons)))) 452 ; body 453 (error? ; definition not permitted 454 (let () 455 (let-syntax ((frob (lambda (x) #'(void)))) 456 (define frob 'xxx)) 457 frob)) 458 (error? ; definition not permitted 459 (let () 460 (let-syntax ((frob (lambda (x) #'(void)))) 461 (define-syntax frob (identifier-syntax 'xxx))) 462 frob)) 463 (error? ; definition not permitted 464 (let () 465 (let-syntax ((frob (lambda (x) #'(void)))) 466 (module frob (x) (define x 'xxx))) 467 (import frob) 468 x)) 469 (error? ; definition not permitted 470 (let () 471 (let-syntax ((frob (lambda (x) #'(void)))) 472 (alias frob cons)) 473 (cons 3 4))) 474) 475 476(mat invalid-bindings 477 (error? (let-syntax ([x '(global)]) x)) 478 (error? (letrec-syntax ([x '(global)]) x)) 479 (error? (fluid-let-syntax ([x '(global)]) x)) 480 (error? (begin (define-syntax x '(global)) x)) 481 (error? (let () (define-syntax x '(global)) x)) 482 (error? (let () (let-syntax ([x '(global)]) x))) 483 (error? (let () (letrec-syntax ([x '(global)]) x))) 484 (error? (let-syntax ([x '(lexical . #\a)]) x)) 485 (error? (letrec-syntax ([x '(lexical . #\a)]) x)) 486 (error? (fluid-let-syntax ([x '(lexical . #\a)]) x)) 487 (error? (begin (define-syntax x '(lexical . #\a)) x)) 488 (error? (let () (define-syntax x '(lexical . #\a)) x)) 489 (error? (let () (let-syntax ([x '(lexical . #\a)]) x))) 490 (error? (let () (letrec-syntax ([x '(lexical . #\a)]) x))) 491 (error? (let-syntax ([x '(macro . cond)]) x)) 492 (error? (letrec-syntax ([x '(macro . cond)]) x)) 493 (error? (fluid-let-syntax ([x '(macro . cond)]) x)) 494 (error? (begin (define-syntax x '(macro . cond)) x)) 495 (error? (let () (define-syntax x '(macro . cond)) x)) 496 (error? (let () (let-syntax ([x '(macro . cond)]) x))) 497 (error? (let () (letrec-syntax ([x '(macro . cond)]) x))) 498) 499 500(mat generalized-pattern 501 (begin 502 (define-syntax gp$a (syntax-rules () [(_ x ... y) (list y x ...)])) 503 #t) 504 (error? gp$a) 505 (error? (gp$a)) 506 (error? (gp$a . b)) 507 (equal? (gp$a 1 2 3 4 5) '(5 1 2 3 4)) 508 (equal? (gp$a 1) '(1)) 509 (equal? (gp$a 1 2) '(2 1)) 510 (begin 511 (define-syntax gp$b 512 (lambda (x) 513 (syntax-case x () 514 [(_ x ... y) #'(list y x ...)]))) 515 #t) 516 (error? gp$b) 517 (error? (gp$b)) 518 (error? (gp$b . b)) 519 (equal? (gp$b 1 2 3 4 5) '(5 1 2 3 4)) 520 (equal? (gp$b 1) '(1)) 521 (equal? (gp$b 1 2) '(2 1)) 522 (begin 523 (define-syntax gp$c 524 (syntax-rules () 525 [(_ x ... y z . w) '((x ...) y z w)])) 526 #t) 527 (error? (gp$c)) 528 (error? (gp$c 1)) 529 (equal? (gp$c 1 2) '(() 1 2 ())) 530 (equal? (gp$c 1 2 3 4 5) '((1 2 3) 4 5 ())) 531 (equal? (gp$c 1 2 . 3) '(() 1 2 3)) 532 (equal? (gp$c 1 2 3 4 5 . 6) '((1 2 3) 4 5 6)) 533 (begin 534 (define-syntax gp$d 535 (syntax-rules (foo) 536 [(_ x ... (y z) . #(foo w1 w2)) '((x ...) y z w1 w2)])) 537 #t) 538 (error? (gp$d 1 2 . #(foo 6 7))) 539 (error? (gp$d 1 2)) 540 (error? (gp$d 1 2 (3 4))) 541 (equal? (gp$d (4 5) . #(foo 6 7)) '(() 4 5 6 7)) 542 (equal? (gp$d 1 (4 5) . #(foo 6 7)) '((1) 4 5 6 7)) 543 (equal? (gp$d 1 2 3 (4 5) . #(foo 6 7)) '((1 2 3) 4 5 6 7)) 544 (begin 545 (define-syntax gp$e 546 (syntax-rules (rats) 547 [(_ x ... . rats) '(x ...)])) 548 #t) 549 (error? (gp$e)) 550 (error? (gp$e 1)) 551 (error? (gp$e 1 2)) 552 (error? (gp$e rats)) 553 (equal? (gp$e . rats) '()) 554 (equal? (gp$e 1 . rats) '(1)) 555 (equal? (gp$e 1 2 3 4 5 . rats) '(1 2 3 4 5)) 556 (begin 557 (define-syntax gp$f 558 (syntax-rules (rats) 559 [(_ (x ... y) ...) '(x ... ... y ...)])) 560 #t) 561 (equal? (gp$f) '()) 562 (equal? (gp$f (1 2 3 4 5) (6 7 8)) '(1 2 3 4 6 7 5 8)) 563 (error? 564 (define-syntax gp$g 565 (syntax-rules () 566 [(_ x ... y ...) '(x ... y ...)]))) 567 (begin 568 (define-syntax gp$h 569 (syntax-rules (rats) 570 [(_ #(x ... y) ...) '(x ... ... y ...)])) 571 #t) 572 (error? (gp$h (1 2 3))) 573 (error? (gp$h . 4)) 574 (equal? (gp$h) '()) 575 (equal? (gp$h #(1 2 3 4 5) #(6 7 8)) '(1 2 3 4 6 7 5 8)) 576) 577 578(mat define-integrable 579 (begin 580 (define-syntax define-integrable 581 (lambda (x) 582 (define make-residual-name 583 (lambda (name) 584 (datum->syntax name 585 (string->symbol 586 (string-append "residual-" 587 (symbol->string (syntax->datum name))))))) 588 (syntax-case x (lambda) 589 ((_ name (lambda formals form1 form2 ...)) 590 (identifier? (syntax name)) 591 (with-syntax ((xname (make-residual-name (syntax name)))) 592 (syntax 593 (begin 594 (define-syntax name 595 (lambda (x) 596 (syntax-case x () 597 (_ (identifier? x) (syntax xname)) 598 ((_ arg (... ...)) 599 (syntax 600 ((fluid-let-syntax 601 ((name (identifier-syntax xname))) 602 (lambda formals form1 form2 ...)) 603 arg (... ...))))))) 604 (define xname 605 (fluid-let-syntax ((name (identifier-syntax xname))) 606 (lambda formals form1 form2 ...)))))))))) 607 #t) 608 (let () 609 (define-integrable even? (lambda (x) (if (= x 0) #t (odd? (- x 1))))) 610 (define-integrable odd? (lambda (x) (if (= x 0) #f (even? (- x 1))))) 611 (and (even? 20) (not (odd? 20)))) 612 (begin 613 (define-syntax define-integrable 614 (lambda (x) 615 (syntax-case x (lambda) 616 [(_ name (lambda formals form1 form2 ...)) 617 (identifier? #'name) 618 #'(begin 619 (define-syntax name 620 (lambda (x) 621 (syntax-case x () 622 [_ (identifier? x) #'xname] 623 [(_ arg (... ...)) 624 #'((fluid-let-syntax ([name (identifier-syntax xname)]) 625 (lambda formals form1 form2 ...)) 626 arg 627 (... ...))]))) 628 (define xname 629 (fluid-let-syntax ([name (identifier-syntax xname)]) 630 (lambda formals form1 form2 ...))))]))) 631 #t) 632 (let () 633 (define-integrable even? (lambda (x) (if (= x 0) #t (odd? (- x 1))))) 634 (define-integrable odd? (lambda (x) (if (= x 0) #f (even? (- x 1))))) 635 (and (even? 20) (not (odd? 20)))) 636 (begin 637 (define-integrable $di-foo 638 (lambda (x) (if (list? x) (map $di-foo x) (list x)))) 639 (define-integrable $di-bar 640 (lambda (x) (if (vector? x) (vector-map $di-bar x) (vector ($di-foo x))))) 641 (equal? 642 (list ($di-bar '#(a b c)) ($di-bar '(1 2 3))) 643 '(#(#((a)) #((b)) #((c))) #(((1) (2) (3)))))) 644) 645 646(mat identifier-syntax 647 (eqv? 648 (let ([x 0]) 649 (define-syntax frob 650 (identifier-syntax 651 [id (begin (set! x (+ x 1)) x)] 652 [(set! id v) (set! x v)])) 653 (let ([n (+ frob frob frob)]) 654 (set! frob 15) 655 (+ n frob))) 656 22) 657 (begin 658 (module (($is-frob x)) 659 (define x 'initial-x) 660 (define-syntax $is-frob 661 (make-variable-transformer 662 (lambda (z) 663 (syntax-case z (set!) 664 [(set! id e) 665 (identifier? #'id) 666 #'(set! x e)] 667 [id (identifier? #'id) #'(vector x)] 668 [(_ a b c ...) #'(set! x (list (cons a b) c ...))]))))) 669 (equal? $is-frob '#(initial-x))) 670 (error? ; invalid syntax 671 ($is-frob)) 672 (error? ; invalid syntax 673 ($is-frob 3)) 674 (error? ; invalid syntax 675 (set! $is-frob)) 676 (error? ; invalid syntax 677 (set! $is-frob 3 4)) 678 (equal? 679 (begin 680 ($is-frob 3 4) 681 $is-frob) 682 '#(((3 . 4)))) 683 (equal? 684 (begin 685 ($is-frob 3 4 5 6 7) 686 $is-frob) 687 '#(((3 . 4) 5 6 7))) 688 (equal? 689 (let () 690 (set! $is-frob 55) 691 $is-frob) 692 '#(55)) 693 (equal? 694 (let () 695 ($is-frob 'q 'p 'doll) 696 $is-frob) 697 '#(((q . p) doll))) 698 (equal? 699 (let ([z (void)]) 700 (set! $is-frob 44) 701 (let ([set! (lambda args (set! z args))]) 702 (set! $is-frob 15) 703 (list z $is-frob))) 704 '((#(44) 15) #(44))) 705) 706 707(mat with-syntax 708 (begin (define-syntax foo 709 (lambda (x) 710 (syntax-case x () 711 [(_ x ...) 712 (with-syntax ([n (length (syntax (x ...)))]) 713 (syntax (list n 'x ...)))]))) 714 #t) 715 (equal? (foo 3 2 1) '(3 3 2 1)) 716 (equal? (foo 3 2 1) '(3 3 2 1)) 717 (begin (define-syntax foo 718 (lambda (x) 719 (syntax-case x () 720 [(_ (x ...) ...) 721 (with-syntax 722 (((len ...) (map length (syntax ((x ...) ...)))) 723 (((z ...) ...) (map reverse (syntax ((x ...) ...))))) 724 (syntax '((len z ...) ...)))]))) 725 #t) 726 (equal? (foo) '()) 727 (equal? (foo (a b) (c d e)) '((2 b a) (3 e d c))) 728 (error? (expand '(foo . a))) 729 (error? (expand '(foo a))) 730 (error? (expand '(foo (a b . c) (d e f)))) 731 (error? (expand '(foo (a b c) . d))) 732 (begin (define-syntax foo 733 (lambda (x) 734 (syntax-case x () 735 [(_ x ...) 736 (with-syntax ([(y1 y2 ...) (syntax (x ...))]) 737 (with-syntax ([(z1 z2) (syntax y1)]) 738 (syntax '(z2 z1))))]))) 739 #t) 740 (equal? (foo (a b) (c d) (e f)) '(b a)) 741 (error? (expand '(foo))) ;oops: "car: incorrect list structure" 742 (error? (expand '(foo a b c))) ;oops: "cadr: incorrect list structure" 743 (error? (define-syntax foo 744 (lambda (x) 745 (syntax-case x () 746 [(_) (with-syntax ([(x x) '(1 2)]) 0)])))) 747 (error? (define-syntax foo 748 (lambda (x) 749 (syntax-case x () 750 [(_) (with-syntax ([x 1] [x 2]) 0)])))) 751 (equal? (with-syntax ((x 3)) #'#&x) '#&3) 752 (equal? (with-syntax ((x 3)) #'#(x)) '#(3)) 753 (equal? (list (with-syntax () (define x 3) x) 4) '(3 4)) 754 (equal? (list (with-syntax ([q 3]) (define x #'q) x) 4) '(3 4)) 755 (equal? (list (with-syntax ([q 3] [r 5]) (define x #'q) (cons x #'r)) 4) '((3 . 5) 4)) 756 ) 757 758(mat generate-temporaries 759 (error? (generate-temporaries)) 760 (error? (generate-temporaries '(a b c) '(d e f))) 761 (error? (generate-temporaries '(a b . c))) 762 (error? (generate-temporaries (let ([x (list 'a 'b 'c)]) (set-cdr! (cddr x) (cdr x)) x))) 763 (andmap identifier? (generate-temporaries '(a b c))) 764 (= (length (generate-temporaries '(a b c))) 3) 765 (andmap identifier? (generate-temporaries #'(a b c))) 766 (= (length (generate-temporaries #'(a b c))) 3) 767 (andmap identifier? (generate-temporaries (cons 'q #'(1 2 3)))) 768 (= (length (generate-temporaries (cons 'q #'(1 2 3)))) 4) 769 ; make sure generate-temporaries isn't confused by annotations 770 (begin 771 (let ((op (open-output-file "testfile.ss" 'replace))) 772 (pretty-print 773 '(begin 774 (define-syntax $gt-a 775 (lambda (x) 776 (syntax-case x () 777 [(_ x) 778 (with-syntax ([(t1 t2 t3) (generate-temporaries #'(1 1 1))]) 779 #'(define x (let ([t1 17] [t2 53] [t3 -10]) (cons* t2 t3 t1))))]))) 780 ($gt-a $gt-x)) 781 op) 782 (close-output-port op) 783 (compile-file "testfile.ss")) 784 #t) 785 (begin 786 (load "testfile.so") 787 #t) 788 (equal? $gt-x '(53 -10 . 17)) 789) 790 791(mat syntax->list 792 (error? (syntax->list #'a)) 793 (error? (syntax->list #'(a b . e))) 794 (eq? (syntax->list #'()) '()) 795 (andmap bound-identifier=? (syntax->list #'(a b c)) (list #'a #'b #'c)) 796 (not (pair? (car (syntax->list #'((a . b)))))) 797 ; just for comparison 798 (pair? (car (syntax->datum #'((a . b))))) 799) 800 801(mat syntax->vector 802 (error? (syntax->vector #'a)) 803 (error? (syntax->vector #'(a b . e))) 804 (eq? (syntax->vector #'#()) '#()) 805 (andmap bound-identifier=? (vector->list (syntax->vector #'#(a b c))) (list #'a #'b #'c)) 806 (not (pair? (vector-ref (syntax->vector #'#((a . b))) 0))) 807 ; just for comparison 808 (pair? (vector-ref (syntax->datum #'#((a . b))) 0)) 809) 810 811(mat syntax-errors 812 (begin 813 (define $do-one 814 (lambda (x) 815 (collect (collect-maximum-generation)) ; close ports left open by load/compile-file w/mat's error handler 816 (let ((op (open-output-file "testfile.ss" 'replace))) 817 (fprintf op " ~% ") 818 (if (string? x) 819 (fprintf op "~a~%" x) 820 (parameterize ((pretty-initial-indent 5)) 821 (pretty-print x op))) 822 (close-output-port op)) 823 (load "testfile.ss"))) 824 #t) 825 826 ; fix "missing definition for exports" error to be like duplicate-id-error 827 ; as is, no character position information is given 828 (error? ($do-one '(module (y) (define x 3)))) 829 830 ; get no character position information for this 831 (error? ($do-one '(let () (define x 3) (define-syntax x (identifier-syntax 4)) x))) 832 833 ; these should possibly give position of invalid/duplicate id, not whole form 834 (error? ($do-one '(let () (module (x) (define x 3) (define-syntax x (identifier-syntax 4))) x))) 835 836 (error? ($do-one '(module (x) (define x 3) (define-syntax x (identifier-syntax 4))))) 837 838 (error? ($do-one '(letrec ((3 4)) 5))) 839 840 (error? ($do-one '(letrec-syntax ((3 4)) 5))) 841 842 ; these should be okay: 843 (error? ($do-one 844 '(module (x) 845 (module (x) (define a 1) (define a 2) (define x 3) (define x 4))))) 846 847 (error? ($do-one '(a . b))) 848 849 (error? ($do-one '(module (x) (define x 3) (define x 4)))) 850 851 (error? ($do-one '(module (x) (module (x) (define x 3) (define x 4))))) 852 853 (error? ($do-one '(letrec ((x 3) (x 4)) x))) 854 855 (error? ($do-one '(letrec-syntax ((x 3) (x 4)) x))) 856 857 (error? ($do-one '(let () (module (x) (define x 3) (define x 4)) x))) 858 859 (error? ($do-one '(let () (define x 3) (define x 4) x))) 860 861 (error? ($do-one '(cond (a . b)))) 862 863 (error? ($do-one '(syntax-case (list 'a 'b) (a) ((_ b b) (syntax b))))) 864 865 (error? ($do-one '(syntax-case (list 'a 'b) (a) ((_ a ...) 3 4 5)))) 866 867 (error? ($do-one '(syntax-case (list 'a 'b) (a ...) ((_ a ...) 3)))) 868 869 (error? ($do-one '(syntax a b))) 870 871 (error? ($do-one '(if a b c d))) 872 873 (error? ($do-one '(letrec ((x 3) (y 4) . (z 5)) (list x y z)))) 874 875 (error? ($do-one '(let () ($primitive 4 car)))) 876 877 (error? ($do-one '(syntax-case x))) 878 879 (error? ($do-one '(quote a b))) 880 881 (error? ($do-one '(fluid-let-syntax))) 882 883 (error? ($do-one '(letrec-syntax () . 3))) 884 885 (error? ($do-one '(lambda (x x) x))) 886 887 (error? ($do-one '(lambda (x y) . z))) 888 889 (error? ($do-one '(lambda (3) 3))) 890 891 (error? ($do-one '(let ((x 4)) (set! x 3 5) x))) 892 893 (error? ($do-one '(set! x 3 5))) 894 895 (error? ($do-one '(let () (import . x) 3))) 896 897 (error? ($do-one '(import . x))) 898 899 (error? ($do-one '(let () (import (just scheme cons))))) 900 901 (error? ($do-one '(import (just scheme cons)))) 902 903 (error? ($do-one '(module ((a . b)) c))) 904 905 (error? ($do-one '(module (a . b) c))) 906 907 (error? ($do-one '(define x y z))) 908 909 (error? ($do-one '(define-syntax x y z))) 910 911 (error? ($do-one '(case-lambda (())))) 912 913 (error? ($do-one '(import m-not-defined))) 914 915 (error? ($do-one '(let () (import m-not-defined) 3))) 916 917 (error? ($do-one '(module () (import m-not-defined)))) 918 919 (error? ($do-one '(lambda (x) (define x 3)))) 920 921 (begin 922 (define-syntax muck (lambda (x) 'x)) 923 #t) 924 925 (error? ($do-one '(muck))) 926 927 (error? ($do-one '(eval-when (compile load foo) bar))) 928 929 (error? ($do-one '(let ((x 3) (y . 4)) (+ x y)))) 930 931 (error? ($do-one '(begin 932 (define-syntax $a 933 (lambda (x) 934 (syntax-case x () 935 ((_ a b c) 936 (syntax-case #'(a b c) () 937 [(_ x y z) (quote (x y z))]))))) 938 ($a 1 2 3)))) 939 ; [ 940 (error? ($do-one "'(a b (c d])")) ; ) 941 942 (error? ($do-one '(let () 943 (define-syntax a 944 (lambda (x) 945 (syntax-case x () 946 [a (datum->syntax #'a '(if 1))]))) 947 a))) 948 949 (error? ($do-one '(let () 950 (define-syntax a 951 (syntax-rules () 952 [(_ m i) 953 (module m (i) 954 (import m1))])) 955 (module m1 (xxx) (define xxx 155)) 956 (a m2 xxx) 957 (let () (import m2) xxx)))) 958 959 (error? ($do-one '(let () 960 (define-syntax a 961 (lambda (q) 962 #'(let () 963 (define x 5) 964 (define-syntax x 965 (identifier-syntax 5)) 966 x))) 967 a))) 968 969 (error? ; attempt to assign immutable variable cons 970 ($do-one '(begin 971 (set! cons list) 972 (cons 1 2 3)))) 973 974 (error? ; attempt to assign immutable variable x 975 ($do-one 976 '(begin 977 (library ($selib1) (export (rename (a $selib1-a))) 978 (import (rnrs)) 979 (define x 0) 980 (define-syntax a 981 (syntax-rules () 982 [(_ n) (begin (set! x (+ x n)) x)]))) 983 (import ($selib1)) 984 ($selib1-a 17)))) 985 986 (error? ; attempt to assign immutable variable x 987 ($do-one 988 '(begin 989 (library ($selib1) (export (rename (a $selib1-a))) 990 (import (rnrs)) 991 (define x 0) 992 (define-syntax a 993 (syntax-rules () 994 [(_) (begin (set! x (+ x 1)) x)]))) 995 (import ($selib1)) 996 ($selib1-a)))) 997 998 (error? 999 (mat/cf 1000 (begin 1001 (define-syntax err-test 1002 (syntax-rules () 1003 [(_ a b c) (list 'a 'b 'c)])) 1004 (err-test "wrong # args")))) 1005 1006 (error? ($do-one '(let () 3 (module foo ()) 4))) 1007 (error? ($do-one '(let () 3 (module ()) 4))) 1008 (error? ($do-one '(let () 3 (import scheme) 4))) 1009 (error? ($do-one '(let () 3 (import-only scheme) 4))) 1010 (error? ($do-one '(let () 3 (module . foo) 4))) 1011 (error? ($do-one '(let () 3 (module) 4))) 1012 (error? ($do-one '(let () 3 (import . scheme) 4))) 1013 (error? ($do-one '(let () 3 (import-only . scheme) 4))) 1014 1015 (error? ($do-one '(let () (define-syntax foo (syntax-rules () [(_ e) (if e)])) (foo 17)))) 1016 1017 (error? ($do-one 1018 `(let () 1019 (define-syntax spam 1020 (lambda (x) 1021 #`(assert (let-syntax ([q '#,(lambda (x) #f)]) q)))) 1022 spam))) 1023 (error? ($do-one 1024 '(let () 1025 (define-syntax spam 1026 (lambda (x) 1027 #`(let-values ([(a b) (let-syntax ([q '#,(lambda (x) 3)]) q)]) 1028 (list a b)))) 1029 spam))) 1030 (error? ($do-one 1031 '(let () 1032 (define-syntax spam 1033 (lambda (x) 1034 #'(let () 1035 (define x 0) 1036 (define y 1) 1037 (define-property x y sort) 1038 (let-values ([(a b c) (values x y)]) 1039 (list a b))))) 1040 spam))) 1041 ) 1042 1043; this is identical to the preceding except that $do-one calls compile-file instead 1044; of load. 1045(mat syntax-errors2 1046 (begin 1047 (define $do-one 1048 (lambda (x) 1049 (collect (collect-maximum-generation)) ; close ports left open by load/compile-file w/mat's error handler 1050 (let ((op (open-output-file "testfile.ss" 'replace))) 1051 (fprintf op " ~% ") 1052 (if (string? x) 1053 (fprintf op "~a~%" x) 1054 (parameterize ((pretty-initial-indent 5)) 1055 (pretty-print x op))) 1056 (close-output-port op)) 1057 (compile-file "testfile.ss") 1058 (load "testfile.so"))) 1059 #t) 1060 1061 ; fix "missing definition for exports" error to be like duplicate-id-error 1062 ; as is, no character position information is given 1063 (error? ($do-one '(module (y) (define x 3)))) 1064 1065 ; get no character position information for this 1066 (error? ($do-one '(let () (define x 3) (define-syntax x (identifier-syntax 4)) x))) 1067 1068 ; these should possibly give position of invalid/duplicate id, not whole form 1069 (error? ($do-one '(let () (module (x) (define x 3) (define-syntax x (identifier-syntax 4))) x))) 1070 1071 (error? ($do-one '(module (x) (define x 3) (define-syntax x (identifier-syntax 4))))) 1072 1073 (error? ($do-one '(letrec ((3 4)) 5))) 1074 1075 (error? ($do-one '(letrec-syntax ((3 4)) 5))) 1076 1077 ; these should be okay: 1078 (error? ($do-one 1079 '(module (x) 1080 (module (x) (define a 1) (define a 2) (define x 3) (define x 4))))) 1081 1082 (error? ($do-one '(a . b))) 1083 1084 (error? ($do-one '(module (x) (define x 3) (define x 4)))) 1085 1086 (error? ($do-one '(module (x) (module (x) (define x 3) (define x 4))))) 1087 1088 (error? ($do-one '(letrec ((x 3) (x 4)) x))) 1089 1090 (error? ($do-one '(letrec-syntax ((x 3) (x 4)) x))) 1091 1092 (error? ($do-one '(let () (module (x) (define x 3) (define x 4)) x))) 1093 1094 (error? ($do-one '(let () (define x 3) (define x 4) x))) 1095 1096 (error? ($do-one '(cond (a . b)))) 1097 1098 (error? ($do-one '(syntax-case (list 'a 'b) (a) ((_ b b) (syntax b))))) 1099 1100 (error? ($do-one '(syntax-case (list 'a 'b) (a) ((_ a ...) 3 4 5)))) 1101 1102 (error? ($do-one '(syntax-case (list 'a 'b) (a ...) ((_ a ...) 3)))) 1103 1104 (error? ($do-one '(syntax a b))) 1105 1106 (error? ($do-one '(if a b c d))) 1107 1108 (error? ($do-one '(letrec ((x 3) (y 4) . (z 5)) (list x y z)))) 1109 1110 (error? ($do-one '(let () ($primitive 4 car)))) 1111 1112 (error? ($do-one '(syntax-case x))) 1113 1114 (error? ($do-one '(quote a b))) 1115 1116 (error? ($do-one '(fluid-let-syntax))) 1117 1118 (error? ($do-one '(letrec-syntax () . 3))) 1119 1120 (error? ($do-one '(lambda (x x) x))) 1121 1122 (error? ($do-one '(lambda (x y) . z))) 1123 1124 (error? ($do-one '(lambda (3) 3))) 1125 1126 (error? ($do-one '(let ((x 4)) (set! x 3 5) x))) 1127 1128 (error? ($do-one '(set! x 3 5))) 1129 1130 (error? ($do-one '(let () (import . x) 3))) 1131 1132 (error? ($do-one '(import . x))) 1133 1134 (error? ($do-one '(let () (import (just scheme cons))))) 1135 1136 (error? ($do-one '(import (just scheme cons)))) 1137 1138 (error? ($do-one '(module ((a . b)) c))) 1139 1140 (error? ($do-one '(module (a . b) c))) 1141 1142 (error? ($do-one '(define x y z))) 1143 1144 (error? ($do-one '(define-syntax x y z))) 1145 1146 (error? ($do-one '(case-lambda (())))) 1147 1148 (error? ($do-one '(import m-not-defined))) 1149 1150 (error? ($do-one '(let () (import m-not-defined) 3))) 1151 1152 (error? ($do-one '(module () (import m-not-defined)))) 1153 1154 (error? ($do-one '(lambda (x) (define x 3)))) 1155 1156 (begin 1157 (define-syntax muck (lambda (x) 'x)) 1158 #t) 1159 1160 (error? ($do-one '(muck))) 1161 1162 (error? ($do-one '(eval-when (compile load foo) bar))) 1163 1164 (error? ($do-one '(let ((x 3) (y . 4)) (+ x y)))) 1165 1166 (error? ($do-one '(begin 1167 (define-syntax $a 1168 (lambda (x) 1169 (syntax-case x () 1170 ((_ a b c) 1171 (syntax-case #'(a b c) () 1172 [(_ x y z) (quote (x y z))]))))) 1173 ($a 1 2 3)))) 1174 ; [ 1175 (error? ($do-one "'(a b (c d])")) ; ) 1176 1177 (error? ($do-one '(let () 1178 (define-syntax a 1179 (lambda (x) 1180 (syntax-case x () 1181 [a (datum->syntax #'a '(if 1))]))) 1182 a))) 1183 1184 (error? ($do-one '(let () 1185 (define-syntax a 1186 (syntax-rules () 1187 [(_ m i) 1188 (module m (i) 1189 (import m1))])) 1190 (module m1 (xxx) (define xxx 155)) 1191 (a m2 xxx) 1192 (let () (import m2) xxx)))) 1193 1194 (error? ($do-one '(let () 1195 (define-syntax a 1196 (lambda (q) 1197 #'(let () 1198 (define x 5) 1199 (define-syntax x 1200 (identifier-syntax 5)) 1201 x))) 1202 a))) 1203 1204 (error? ; ris #f: attempt to assign immutable variable cons 1205 ; ris #t: incorrect number of arguments to cons 1206 ($do-one '(begin 1207 (set! cons list) 1208 (set! cons #%cons) 1209 (cons 1 2 3)))) 1210 1211 (error? ; attempt to assign immutable variable x 1212 ($do-one 1213 '(begin 1214 (library ($selib1) (export (rename (a $selib1-a))) 1215 (import (rnrs)) 1216 (define x 0) 1217 (define-syntax a 1218 (syntax-rules () 1219 [(_ n) (begin (set! x (+ x n)) x)]))) 1220 (import ($selib1)) 1221 ($selib1-a 17)))) 1222 1223 (error? ; attempt to assign immutable variable x 1224 ($do-one 1225 '(begin 1226 (library ($selib1) (export (rename (a $selib1-a))) 1227 (import (rnrs)) 1228 (define x 0) 1229 (define-syntax a 1230 (syntax-rules () 1231 [(_) (begin (set! x (+ x 1)) x)]))) 1232 (import ($selib1)) 1233 ($selib1-a)))) 1234 1235 (error? 1236 (mat/cf 1237 (begin 1238 (define-syntax err-test 1239 (syntax-rules () 1240 [(_ a b c) (list 'a 'b 'c)])) 1241 (err-test "wrong # args")))) 1242 1243 (error? ($do-one '(let () 3 (module foo ()) 4))) 1244 (error? ($do-one '(let () 3 (module ()) 4))) 1245 (error? ($do-one '(let () 3 (import scheme) 4))) 1246 (error? ($do-one '(let () 3 (import-only scheme) 4))) 1247 (error? ($do-one '(let () 3 (module . foo) 4))) 1248 (error? ($do-one '(let () 3 (module) 4))) 1249 (error? ($do-one '(let () 3 (import . scheme) 4))) 1250 (error? ($do-one '(let () 3 (import-only . scheme) 4))) 1251 1252 (error? ($do-one '(let () (define-syntax foo (syntax-rules () [(_ e) (if e)])) (foo 17)))) 1253 1254 ; make sure we don't get complaints from fasl writer due to procedures in the source 1255 ; information residualzied for the production of errors 1256 (error? ($do-one 1257 `(let () 1258 (define-syntax spam 1259 (lambda (x) 1260 #`(assert (let-syntax ([q '#,(lambda (x) #f)]) q)))) 1261 spam))) 1262 (error? ($do-one 1263 '(let () 1264 (define-syntax spam 1265 (lambda (x) 1266 #`(let-values ([(a b) (let-syntax ([q '#,(lambda (x) 3)]) q)]) 1267 (list a b)))) 1268 spam))) 1269 (error? ($do-one 1270 '(let () 1271 (define-syntax spam 1272 (lambda (x) 1273 #'(let () 1274 (define x 0) 1275 (define y 1) 1276 (define-property x y sort) 1277 (let-values ([(a b c) (values x y)]) 1278 (list a b))))) 1279 spam))) 1280 ) 1281 1282(mat define-structure 1283 (begin 1284 (define-structure ($tree left node right)) 1285 #t) 1286 ($tree? (make-$tree 3 4 5)) 1287 (let ((tr (make-$tree 'a 'b 'c))) 1288 (and (eq? ($tree-left tr) 'a) 1289 (eq? ($tree-node tr) 'b) 1290 (eq? ($tree-right tr) 'c))) 1291 (begin 1292 (define-structure (pare kar kdr) 1293 ((original-kar kar) (original-kdr kdr))) 1294 #t) 1295 (andmap procedure? 1296 (list make-pare 1297 pare? 1298 pare-kar 1299 pare-kdr 1300 pare-original-kar 1301 pare-original-kdr 1302 set-pare-kar! 1303 set-pare-kdr! 1304 set-pare-original-kar! 1305 set-pare-original-kdr!)) 1306 (pare? (make-pare 3 4)) 1307 (eq? (pare-kar (make-pare 'a 'b)) 'a) 1308 (eq? (pare-kdr (make-pare 'a 'b)) 'b) 1309 (eq? (pare-original-kar (make-pare 'a 'b)) 'a) 1310 (eq? (pare-original-kdr (make-pare 'a 'b)) 'b) 1311 (let ((p (make-pare 'a 'b))) 1312 (set-pare-kar! p 'c) 1313 (set-pare-kdr! p 'd) 1314 (and (eq? (pare-kar p) 'c) 1315 (eq? (pare-kdr p) 'd) 1316 (eq? (pare-original-kar p) 'a) 1317 (eq? (pare-original-kdr p) 'b))) 1318 ) 1319 1320(mat module1 1321 (begin 1322 (module $foo ($a) (define $a 4) (define $b 5)) 1323 (import $foo) 1324 (eq? $a 4)) 1325 (error? 1326 (begin 1327 (module $foo ($a) (define $a 4) (define $b 5)) 1328 (import $foo) 1329 $b)) 1330 (eq? (let () 1331 (module $foo ($a) (define $a 4) (define $b 5)) 1332 (import $foo) 1333 $a) 1334 4) 1335 (error? 1336 (let () 1337 (module $foo ($a) (define $a 4) (define $b 5)) 1338 (import $foo) 1339 $b)) 1340 (begin 1341 (module $foo ($a) 1342 (define-syntax $a (identifier-syntax 4)) 1343 (define-syntax $b (identifier-syntax 5))) 1344 (import $foo) 1345 (eq? $a 4)) 1346 (error? 1347 (begin 1348 (module $foo ($a) 1349 (define-syntax $a (identifier-syntax 4)) 1350 (define-syntax $b (identifier-syntax 5))) 1351 (import $foo) 1352 $b)) 1353 (eq? (let () 1354 (module $foo ($a) 1355 (define-syntax $a (identifier-syntax 4)) 1356 (define-syntax $b (identifier-syntax 5))) 1357 (import $foo) 1358 $a) 1359 4) 1360 (error? 1361 (let () 1362 (module $foo ($a) 1363 (define-syntax $a (identifier-syntax 4)) 1364 (define-syntax $b (identifier-syntax 5))) 1365 (import $foo) 1366 $b)) 1367 (begin 1368 (module $foo (($a $b)) 1369 (define-syntax $a (identifier-syntax $b)) 1370 (define $b 400)) 1371 (import $foo) 1372 (eq? $a 400)) 1373 (error? 1374 (begin 1375 (module $foo ($a) 1376 (define-syntax $a (identifier-syntax $b)) 1377 (define $b 400)) 1378 (import $foo) 1379 $a)) 1380 (eq? (let () 1381 (module $foo (($a $b)) 1382 (define-syntax $a (identifier-syntax $b)) 1383 (define $b 400)) 1384 (import $foo) 1385 $a) 1386 400) 1387 (eq? (let () 1388 (module $foo ($a) 1389 (define-syntax $a (identifier-syntax $b)) 1390 (define $b 400)) 1391 (import $foo) 1392 $a) 1393 400) 1394 (begin 1395 (define-syntax anonymous-module 1396 (syntax-rules () 1397 ((_ (exp ...) def ...) 1398 (begin 1399 (module $tmp (exp ...) def ...) 1400 (import $tmp))))) 1401 (anonymous-module ($x) (define $x 3)) 1402 (eq? $x 3)) 1403 (eq? (let () (anonymous-module ($x) (define $x 3)) $x) 3) 1404 (begin 1405 (define $y (lambda () $x)) 1406 (anonymous-module ($x) (define $x 3)) 1407 (eq? ($y) 3)) 1408 (eq? (let () 1409 (define $y (lambda () $x)) 1410 (anonymous-module ($x) (define $x 3)) 1411 ($y)) 1412 3) 1413 (begin 1414 (anonymous-module (ok) 1415 (define $y 4) 1416 (define ok (lambda () $y))) 1417 (define $y (lambda () (ok))) 1418 (eq? ($y) 4)) 1419 ; was an error before change to treat top-level begin like a <body> 1420 (begin 1421 (define $y (lambda () (rats))) 1422 (anonymous-module (rats) 1423 (define $y 4) 1424 (define rats (lambda () $y))) 1425 (eqv? ($y) 4)) 1426 (eq? (let () 1427 (define $y (lambda () ($x))) 1428 (anonymous-module ($x) 1429 (define $y 4) 1430 (define $x (lambda () $y))) 1431 ($y)) 1432 4) 1433 (begin 1434 (anonymous-module ($a) 1435 (anonymous-module ($a) 1436 (define $a 3))) 1437 (eq? $a 3)) 1438 (begin 1439 (anonymous-module ($a) 1440 (anonymous-module (($a $b)) 1441 (define-syntax $a (identifier-syntax $b)) 1442 (define $b 77))) 1443 (eq? $a 77)) 1444 (begin 1445 (define-syntax defconst 1446 (syntax-rules () 1447 ((_ $x e) 1448 (anonymous-module (($x t)) 1449 (define-syntax $x (identifier-syntax t)) 1450 (define t e))))) 1451 (defconst $a 3) 1452 (eq? $a 3)) 1453 (error? (set! $a 4)) 1454 (begin 1455 (module $qq ($q) (defconst $q 53)) 1456 (eq? (let () (import $qq) $q) 53)) 1457 (error? (let () (import $qq) (set! $q 4))) 1458 (begin (import $qq) (eq? $q 53)) 1459 (error? (set! $q 4)) 1460 ; repeat last set of tests for built-in anonymous modules 1461 (begin 1462 (module ($x) (define $x 3)) 1463 (eq? $x 3)) 1464 (eq? (let () (module ($x) (define $x 3)) $x) 3) 1465 (begin 1466 (define $y (lambda () $x)) 1467 (module ($x) (define $x 3)) 1468 (eq? ($y) 3)) 1469 (eq? (let () 1470 (define $y (lambda () $x)) 1471 (module ($x) (define $x 3)) 1472 ($y)) 1473 3) 1474 (begin 1475 (module (ok) 1476 (define $y 4) 1477 (define ok (lambda () $y))) 1478 (define $y (lambda () (ok))) 1479 (eq? ($y) 4)) 1480 ; was an error before change to treat top-level begin like a <body> 1481 (begin 1482 (define $y (lambda () (mice))) 1483 (module (mice) 1484 (define $y 4) 1485 (define mice (lambda () $y))) 1486 (eqv? ($y) 4)) 1487 (eq? (let () 1488 (define $y (lambda () ($x))) 1489 (module ($x) 1490 (define $y 4) 1491 (define $x (lambda () $y))) 1492 ($y)) 1493 4) 1494 (begin 1495 (module ($a) 1496 (module ($a) 1497 (define $a 3))) 1498 (eq? $a 3)) 1499 (begin 1500 (module ($a) 1501 (module (($a $b)) 1502 (define-syntax $a (identifier-syntax $b)) 1503 (define $b 77))) 1504 (eq? $a 77)) 1505 (begin 1506 (define-syntax defconst 1507 (syntax-rules () 1508 ((_ $x e) 1509 (module (($x t)) 1510 (define-syntax $x (identifier-syntax t)) 1511 (define t e))))) 1512 (defconst $a 3) 1513 (eq? $a 3)) 1514 (error? (set! $a 4)) 1515 (begin 1516 (module $qq ($q) (defconst $q 53)) 1517 (eq? (let () (import $qq) $q) 53)) 1518 (error? (let () (import $qq) (set! $q 4))) 1519 (begin (import $qq) (eq? $q 53)) 1520 (error? (set! $q 4)) 1521 (begin 1522 (module $prom ((del make-$prom) frc) 1523 (define-syntax del 1524 (syntax-rules () 1525 ((_ exp) (make-$prom (lambda () exp))))) 1526 (define frc (lambda ($prom) ($prom))) 1527 (define make-$prom 1528 (lambda (th) 1529 (let ([val #f] [forced? #f]) 1530 (lambda () 1531 (if forced? 1532 val 1533 (let ([e (th)]) (set! forced? #t) (set! val e) e))))))) 1534 (module $tofu ($lazy-let) 1535 (import $prom) 1536 (define-syntax $lazy-let 1537 (lambda (form) 1538 (syntax-case form () 1539 [(_ ((v e) ...) e1 e2 ...) 1540 #'(let ([v (del e)] ...) 1541 (let-syntax ((v (identifier-syntax (frc v))) ...) 1542 e1 e2 ...))])))) 1543 (module $test ($a) 1544 (import $tofu) 1545 (define-syntax push! 1546 (syntax-rules () 1547 ((_ $x ls) (set! ls (cons $x ls))))) 1548 (define $a 1549 (lambda () 1550 (let ((ls '())) 1551 (let ((w ($lazy-let (($x (begin (push! '$x ls) '$x)) 1552 ($y (begin (push! '$y ls) '$y)) 1553 ($z (begin (push! '$z ls) '$z))) 1554 (if $x (list $x $y) $z)))) 1555 (append w ls)))))) 1556 (equal? (let () (import $test) ($a)) '($x $y $y $x))) 1557 (begin (import $test) (equal? ($a) '($x $y $y $x))) 1558 (error? (let () (module () (define $a 3) (define-syntax $a list)) 5)) 1559 (eqv? 1560 (let () 1561 (module $a ($x) (define $x 3) (set! $x (+ $x 1))) 1562 (import $a) 1563 $x) 1564 4) 1565 (eq? (let () 1566 (module $foo ($a) 1567 (module $a ($b) 1568 (define-syntax $a (identifier-syntax $b)) 1569 (define-syntax $b (identifier-syntax $c)) 1570 (define $c 7))) 1571 (import $foo) 1572 (import $a) 1573 $b) 1574 7) 1575 (eq? (let () 1576 (module $foo ($a) (module $a ($x) (define $x 3))) 1577 (import $foo) 1578 (import $a) 1579 $x) 1580 3) 1581 (begin 1582 (module $foo ($a) (module $a ($x) (define $x 3))) 1583 (import $foo) 1584 (import $a) 1585 (eq? $x 3)) 1586 (error? 1587 (begin 1588 (module $foo ($a) 1589 (module $a ($b) 1590 (define-syntax $a (identifier-syntax $b)) 1591 (define-syntax $b (identifier-syntax $c)) 1592 (define $c 7))) 1593 (import $foo) 1594 (import $a) 1595 $b)) 1596 (begin 1597 (module $foo ($a) 1598 (module $a (($b $c)) 1599 (define-syntax $a (identifier-syntax $b)) 1600 (define-syntax $b (identifier-syntax $c)) 1601 (define $c 7))) 1602 (import $foo) 1603 (import $a) 1604 (eq? $b 7)) 1605 (error? 1606 (begin 1607 (module $foo ($a) 1608 (module $a (($b $c)) 1609 (define-syntax $a (identifier-syntax $c)) 1610 (define-syntax $b (identifier-syntax $a)) 1611 (define $c 7))) 1612 (import $foo) 1613 (import $a) 1614 (eq? $b 7))) 1615 (error? 1616 (begin 1617 (module $foo ($a) 1618 (module $a (($b $a)) 1619 (define-syntax $a (identifier-syntax $c)) 1620 (define-syntax $b (identifier-syntax $a)) 1621 (define $c 7))) 1622 (import $foo) 1623 (import $a) 1624 (eq? $b 7))) 1625 (begin 1626 (module $foo ($a) 1627 (module $a (($b ($a $c))) 1628 (define-syntax $a (identifier-syntax $c)) 1629 (define-syntax $b (identifier-syntax $a)) 1630 (define $c 7))) 1631 (import $foo) 1632 (import $a) 1633 (eq? $b 7)) 1634 (begin 1635 (module $foo ($a) 1636 (module $a (($b $a $c)) 1637 (define-syntax $a (identifier-syntax $c)) 1638 (define-syntax $b (identifier-syntax $a)) 1639 (define $c 7))) 1640 (import $foo) 1641 (import $a) 1642 (eq? $b 7)) 1643 (begin 1644 (module $foo ($a) 1645 (module $a (($b $a)) 1646 (module (($a $c)) 1647 (define-syntax $a (identifier-syntax $c)) 1648 (define $c 7)) 1649 (define-syntax $b (identifier-syntax $a)))) 1650 (import $foo) 1651 (import $a) 1652 (eq? $b 7)) 1653 (error? 1654 (begin 1655 (module $foo ($a) 1656 (define-syntax $a (identifier-syntax $b)) 1657 (define-syntax $b (identifier-syntax 4))) 1658 (import $foo) 1659 $a)) 1660 (eq? (let () 1661 (module $foo ($a) 1662 (define-syntax $a (identifier-syntax $b)) 1663 (define-syntax $b (identifier-syntax $c)) 1664 (define $c 7)) 1665 (import $foo) 1666 $a) 1667 7) 1668 (eq? (let () 1669 (module $foo ($y) 1670 (module $x ($y) 1671 (define-syntax $y (identifier-syntax $z)) 1672 (define $z 4)) 1673 (import $x)) 1674 (import $foo) 1675 $y) 1676 4) 1677 (eq? (let () 1678 (module $foo ($y) 1679 (module $x (($y $z)) 1680 (define-syntax $y (identifier-syntax $z)) 1681 (define $z 4)) 1682 (import $x)) 1683 (import $foo) 1684 $y) 1685 4) 1686 (error? 1687 (begin 1688 (module $foo ($y) 1689 (module $x ($y) 1690 (define-syntax $y (identifier-syntax $z)) 1691 (define $z 4)) 1692 (import $x)) 1693 (import $foo) 1694 $y)) 1695 (begin 1696 (module $foo ($y) 1697 (module $x (($y $z)) 1698 (define-syntax $y (identifier-syntax $z)) 1699 (define $z 4)) 1700 (import $x)) 1701 (import $foo) 1702 (eq? $y 4)) 1703 (eq? (let () 1704 (module $foo ($y) 1705 (module $x ($y $z) 1706 (define-syntax $y (identifier-syntax $z)) 1707 (define $z 4)) 1708 (import $x)) 1709 (import $foo) 1710 $y) 1711 4) 1712 (error? 1713 (begin 1714 (module $foo ($y) 1715 (module $x ($y $z) 1716 (define-syntax $y (identifier-syntax $z)) 1717 (define $z 44)) 1718 (import $x)) 1719 (import $foo) 1720 (eq? $y 44))) 1721 (begin 1722 (module $foo ($y) 1723 (module $x (($y $z) $z) 1724 (define-syntax $y (identifier-syntax $z)) 1725 (define $z 44)) 1726 (import $x)) 1727 (import $foo) 1728 (eq? $y 44)) 1729 (begin 1730 (module $foo (($y $z)) 1731 (module $x ($y $z) 1732 (define-syntax $y (identifier-syntax $z)) 1733 (define $z 44)) 1734 (import $x)) 1735 (import $foo) 1736 (eq? $y 44)) 1737 (error? 1738 (let () 1739 (module $foo (($y $z)) 1740 (module (($y $z)) 1741 (define-syntax $y (identifier-syntax $z)) 1742 (define $z 4))) 1743 (import $foo) 1744 $y)) 1745 (error? ; undefined export $y 1746 (let () 1747 (module $foo (($y $z)) 1748 (define-syntax $y (identifier-syntax $z)) 1749 (module ($y)) 1750 (define $z 4)) 1751 (import $foo) 1752 $y)) 1753 (error? ; undefined export $z 1754 (let () 1755 (module $foo ($y) 1756 (module (($y $z)) 1757 (define-syntax $y (identifier-syntax $z))) 1758 (define $z 4)) 1759 (import $foo) 1760 $y)) 1761 ; following demonstrates "recursive" modules 1762 (equal? 1763 (let () 1764 (module $one ($e) 1765 (define $e (lambda ($x) (or (zero? $x) ($o (- $x 1)))))) 1766 (module $two ($o) 1767 (define $o (lambda ($x) (not ($e $x))))) 1768 (import $one) 1769 (import $two) 1770 (map (lambda ($x) (list ($o $x) ($e $x))) '(0 1 2 3 4 5))) 1771 '((#f #t) (#t #f) (#f #t) (#t #f) (#f #t) (#t #f))) 1772 ; "recursive" modules don't work at top level ... 1773 (error? 1774 (begin 1775 (module $one ($e) 1776 (define $e (lambda ($x) (or (zero? $x) ($o (- $x 1)))))) 1777 (module $two ($o) 1778 (define $o (lambda ($x) (not ($e $x))))) 1779 (import $one) 1780 (import $two) 1781 (map (lambda ($x) ($o $x)) '(0 1 2 3 4 5)))) 1782 ; ... unless encapsulated within a top-level module 1783 (begin 1784 (module ($e $o) 1785 (module $one ($e) 1786 (define $e (lambda ($x) (or (zero? $x) ($o (- $x 1)))))) 1787 (module $two ($o) 1788 (define $o (lambda ($x) (not ($e $x))))) 1789 (import $one) 1790 (import $two)) 1791 (equal? 1792 (map (lambda ($x) (list ($o $x) ($e $x))) '(0 1 2 3 4 5)) 1793 '((#f #t) (#t #f) (#f #t) (#t #f) (#f #t) (#t #f)))) 1794 ; the following set of tests, as with many others above, highlights the 1795 ; difference between the flexibility of local and rigidness of global 1796 ; export rules. for the global, we need to explicitly list the implicit 1797 ; exports; for the global, we do not. 1798 (eq? (let () 1799 (module $a ($alpha) 1800 (define-syntax $alpha (identifier-syntax $x)) 1801 (module $b ($x) (define $x 3)) 1802 (import $b)) 1803 (import $a) 1804 $alpha) 1805 3) 1806 (error? 1807 (begin 1808 (module $a ($alpha) 1809 (define-syntax $alpha (identifier-syntax $x)) 1810 (module $b ($x) (define $x 3)) 1811 (import $b)) 1812 (import $a) 1813 $alpha)) 1814 (begin 1815 (module $a (($alpha $x)) 1816 (define-syntax $alpha (identifier-syntax $x)) 1817 (module $b ($x) (define $x 3)) 1818 (import $b)) 1819 (import $a) 1820 (eq? $alpha 3)) 1821 (equal? 1822 (let () 1823 (define $x "current outer value of $x") 1824 (let () 1825 (module $a ($alpha) 1826 (define-syntax $alpha (identifier-syntax $x)) 1827 (module $b ($y) (define $y 445) (define $x 3)) 1828 (import $b)) 1829 (import $a) 1830 $alpha)) 1831 "current outer value of $x") 1832 (begin 1833 (define $x "current outer value of $x") 1834 (module $a ($alpha) 1835 (define-syntax $alpha (identifier-syntax $x)) 1836 (module $b ($y) (define $y 445) (define $x 3)) 1837 (import $b)) 1838 (import $a) 1839 (equal? $alpha "current outer value of $x")) 1840 (begin 1841 (define-syntax $beta 1842 (syntax-rules () 1843 ((_ x y) 1844 (begin 1845 (module x ($beta-a) (define $beta-a 666)) 1846 (import x) 1847 (define-syntax y (identifier-syntax $beta-a)))))) 1848 (eqv? (let () ($beta q t) t) 666)) 1849 (error? (let () ($beta q t) $beta-a)) 1850 (begin 1851 (define-syntax $gamma 1852 (syntax-rules () 1853 ((_ x y) 1854 (begin 1855 (module x ($aaa) (define $aaa 666)) 1856 (define y (lambda () (import x) $aaa)))))) 1857 (eq? (let () ($gamma q t) (t)) 666)) 1858 (error? (let () ($gamma q t) (import q) $aaa)) 1859 (begin ($gamma $q $t) #t) 1860 (eqv? ($t) 666) 1861 (error? (let () (import $q) $aaa)) 1862 (error? (begin (import $q) (eq? $aaa 666))) 1863 (error? 1864 (begin 1865 (define-syntax a 1866 (lambda (x) 1867 (syntax-case x () 1868 ((_ e) #'(define x e))))) 1869 (a 3))) 1870 (error? 1871 (begin 1872 (define-syntax a 1873 (lambda (x) 1874 (syntax-case x () 1875 ((_ e) #'(define-syntax x e))))) 1876 (a (identifier-syntax 4)))) 1877 (error? 1878 (begin 1879 (define-syntax a 1880 (lambda (x) 1881 (syntax-case x () 1882 ((_ i e) #'(module x (i) (define i e)))))) 1883 (a b 'c))) 1884 (error? ; defnie not defined 1885 (module (y) (import-only (rnrs)) (defnie x 3) (define y 4))) 1886) 1887 1888(mat module2 1889 (begin 1890 (define-syntax $define-structure 1891 (lambda (x) 1892 (define construct-name 1893 (lambda (template-identifier . args) 1894 (datum->syntax 1895 template-identifier 1896 (string->symbol 1897 (apply string-append 1898 (map (lambda (x) 1899 (if (string? x) 1900 x 1901 (symbol->string (syntax->datum x)))) 1902 args)))))) 1903 (syntax-case x () 1904 ((_ (name id1 ...)) 1905 (andmap identifier? (syntax (name id1 ...))) 1906 (with-syntax 1907 ((constructor (construct-name (syntax name) "make-" (syntax name))) 1908 (predicate (construct-name (syntax name) (syntax name) "?")) 1909 ((access ...) 1910 (map (lambda (x) (construct-name x (syntax name) "-" x)) 1911 (syntax (id1 ...)))) 1912 ((assign ...) 1913 (map (lambda (x) 1914 (construct-name x "set-" (syntax name) "-" x "!")) 1915 (syntax (id1 ...)))) 1916 (structure-length 1917 (+ (length (syntax (id1 ...))) 1)) 1918 ((index ...) 1919 (let f ((i 1) (ids (syntax (id1 ...)))) 1920 (if (null? ids) 1921 '() 1922 (cons i (f (+ i 1) (cdr ids))))))) 1923 (syntax (begin 1924 (module name (constructor access ...) 1925 (define constructor 1926 (lambda (id1 ...) 1927 (vector 'name id1 ... ))) 1928 (define access 1929 (lambda (x) 1930 (vector-ref x index))) 1931 ...) 1932 (import name)))))))) 1933 (module $foo ($foos build-$foos) 1934 ($define-structure ($foos x)) 1935 (define (build-$foos) (make-$foos 3))) 1936 (let () 1937 (import $foo) 1938 (import $foos) 1939 (define x (build-$foos)) 1940 (define y (make-$foos 4)) 1941 (equal? (list ($foos-x x) ($foos-x y)) '(3 4)))) 1942 (begin 1943 (import $foo) 1944 (import $foos) 1945 (define $x (build-$foos)) 1946 (define $y (make-$foos 4)) 1947 (equal? (list ($foos-x $x) ($foos-x $y)) '(3 4))) 1948 (let () 1949 (define-syntax $define-structure 1950 (lambda (x) 1951 (define construct-name 1952 (lambda (template-identifier . args) 1953 (datum->syntax 1954 template-identifier 1955 (string->symbol 1956 (apply string-append 1957 (map (lambda (x) 1958 (if (string? x) 1959 x 1960 (symbol->string (syntax->datum x)))) 1961 args)))))) 1962 (syntax-case x () 1963 ((_ (name id1 ...)) 1964 (andmap identifier? (syntax (name id1 ...))) 1965 (with-syntax 1966 ((constructor (construct-name (syntax name) "make-" (syntax name))) 1967 (predicate (construct-name (syntax name) (syntax name) "?")) 1968 ((access ...) 1969 (map (lambda (x) (construct-name x (syntax name) "-" x)) 1970 (syntax (id1 ...)))) 1971 ((assign ...) 1972 (map (lambda (x) 1973 (construct-name x "set-" (syntax name) "-" x "!")) 1974 (syntax (id1 ...)))) 1975 (structure-length 1976 (+ (length (syntax (id1 ...))) 1)) 1977 ((index ...) 1978 (let f ((i 1) (ids (syntax (id1 ...)))) 1979 (if (null? ids) 1980 '() 1981 (cons i (f (+ i 1) (cdr ids))))))) 1982 (syntax (begin 1983 (module name (constructor access ...) 1984 (define constructor 1985 (lambda (id1 ...) 1986 (vector 'name id1 ... ))) 1987 (define access 1988 (lambda (x) 1989 (vector-ref x index))) 1990 ...) 1991 (import name)))))))) 1992 (module $foo ($foos build-$foos) 1993 ($define-structure ($foos x)) 1994 (define (build-$foos) (make-$foos 3))) 1995 (import $foo) 1996 (import $foos) 1997 (let () 1998 (define x (build-$foos)) 1999 (define y (make-$foos 4)) 2000 (equal? (list ($foos-x x) ($foos-x y)) '(3 4)))) 2001 ) 2002 2003(mat module3 2004 (equal? (let () 2005 (module foo (thing) (define thing #f)) 2006 (define set (lambda (x) (import foo) (set! thing x))) 2007 (define get (lambda () (import foo) thing)) 2008 (let ([before (get)]) 2009 (set 37) 2010 (list before (get)))) 2011 '(#f 37)) 2012 (eqv? (let () 2013 (module foo (thing) (define thing #f)) 2014 (define get (lambda () (import foo) thing)) 2015 (import foo) 2016 (set! thing 37) 2017 (get)) 2018 37) 2019 (eqv? (let () 2020 (define x 45) 2021 (define-syntax def (identifier-syntax (define x 123))) 2022 (define-syntax fof (identifier-syntax (let () def x))) 2023 fof) 2024 45) 2025 (eqv? (let () 2026 (define x 45) 2027 (define-syntax def (identifier-syntax (define x 123))) 2028 (define-syntax fof (identifier-syntax (let () def x))) 2029 (let () fof)) 2030 45) 2031 (eqv? (let () 2032 (define x 45) 2033 (define-syntax fof (identifier-syntax (let () (define x 123) x))) 2034 (let () fof)) 2035 123) 2036 (eqv? (let () 2037 (define x 45) 2038 (define-syntax def 2039 (identifier-syntax 2040 (begin (define x 123) (set! x (+ x x))))) 2041 (define-syntax fof (identifier-syntax (let () def x))) 2042 (let () fof)) 2043 45) 2044 (eqv? (let () 2045 (define x 45) 2046 (define-syntax def 2047 (syntax-rules () 2048 ((_ id) (define id 123)))) 2049 (define-syntax fof (identifier-syntax (let () (def x) x))) 2050 (let () fof)) 2051 123) 2052 (eqv? (let () 2053 (define x 45) 2054 (define-syntax fof 2055 (identifier-syntax 2056 (let () 2057 (define-syntax def (identifier-syntax (define x 123))) 2058 def 2059 x))) 2060 (let () fof)) 2061 45) 2062 (eqv? (let () 2063 (define x 45) 2064 (define-syntax def (identifier-syntax (define x 123))) 2065 (define-syntax ref (identifier-syntax x)) 2066 (let () def ref)) 2067 45) 2068 (eqv? (let () 2069 (define x 45) 2070 (define-syntax fof 2071 (identifier-syntax 2072 (let () 2073 (define-syntax def 2074 (lambda (x) 2075 (syntax-case x () 2076 [id 2077 (identifier? #'id) 2078 (with-syntax ([var (datum->syntax #'id 'x)]) 2079 #'(define var 123))]))) 2080 def 2081 x))) 2082 (let () fof)) 2083 123) 2084 (eqv? (let () 2085 (define x 45) 2086 (define-syntax zorpon (identifier-syntax define)) 2087 (define-syntax fof (identifier-syntax (let () (zorpon x 123) x))) 2088 (let () fof)) 2089 123) 2090 (eqv? (let () 2091 (define x 45) 2092 (define-syntax def (identifier-syntax (zorpon x 123))) 2093 (define-syntax fof (identifier-syntax (let () def x))) 2094 (let () (fluid-let-syntax ((zorpon (identifier-syntax define))) fof))) 2095 45) 2096 (equal? (let () 2097 (module foo (x) (define x 3)) 2098 (define-syntax blah 2099 (lambda (x) 2100 (syntax-case x () 2101 [id 2102 (identifier? #'id) 2103 (with-syntax ([output 2104 (datum->syntax #'id 2105 '(let () (import foo) x))]) 2106 #'output)]))) 2107 (cons blah (let () blah))) 2108 '(3 . 3)) 2109 (equal? (let () 2110 (module foo (x) (define x 3)) 2111 (module bar (x) (define x 5)) 2112 (define-syntax get 2113 (lambda (x) 2114 (syntax-case x () 2115 [(_ mod) 2116 (identifier? #'mod) 2117 (with-syntax ([var (datum->syntax #'mod 'x)]) 2118 #'(let () (import mod) var))]))) 2119 (cons (get bar) (let () (get foo)))) 2120 '(5 . 3)) 2121 (equal? (let () 2122 (module foo (x) (define x 3)) 2123 (module bar (x) (define x 5)) 2124 (define-syntax get 2125 (syntax-rules () 2126 ((_ mod id) (let () (import mod) id)))) 2127 (cons (get bar x) (let () (get foo x)))) 2128 '(5 . 3)) 2129 (equal? (let ((x 1)) 2130 (module foo (x) (define x 3)) 2131 (module bar (x) (define x 5)) 2132 (define-syntax get-x 2133 (syntax-rules () 2134 ((_ mod) (let () (import mod) x)))) 2135 (cons (get-x bar) (let () (get-x foo)))) 2136 '(1 . 1)) 2137) 2138 2139(mat module4 2140 (equal? 2141 (let () 2142 (define-syntax import* 2143 (lambda (x) 2144 (syntax-case x () 2145 [(_ mid) #'(import mid)] 2146 [(_ mid s1 s2 ...) 2147 (with-syntax ((((id ...) d ...) 2148 (let f ((ls #'(s1 s2 ...))) 2149 (if (null? ls) 2150 '(()) 2151 (let ((rest (f (cdr ls)))) 2152 (syntax-case (car ls) (as) 2153 [(as id1 id2) 2154 (cons (cons #'id2 (car rest)) 2155 (cons #'(define-syntax id2 2156 (identifier-syntax id1)) 2157 (cdr rest)))] 2158 [id (identifier? #'id) 2159 (cons (cons #'id (car rest)) 2160 (cdr rest))])))))) 2161 #'(module (id ...) (import mid) d ...))]))) 2162 (module m1 (x y) (define x 'x) (define y 'y)) 2163 (list (let () (import* m1) (cons x y)) 2164 (let () (import* m1 x y) (cons x y)) 2165 (let () (import* m1 x) (define y 'yy) (cons x y)) 2166 (let ((x 'outer)) (import* m1 (as x xx) y) (list* x xx y)))) 2167 '((x . y) (x . y) (x . yy) (outer x . y))) 2168) 2169 2170(mat module5 2171 (begin 2172 (module $zip (a b c) 2173 (define a 1) 2174 (define b 123) 2175 (define-syntax c (identifier-syntax (list a b)))) 2176 (equal? (let () (import $zip) (list a b c)) 2177 '(1 123 (1 123)))) 2178 (eq? (let () (import-only $zip) a) 1) 2179 (error? (let () (import-only $zip) (list a b c))) 2180 (error? (let ((z list)) (import-only $zip) (z a b c))) 2181 (equal? 2182 (let () 2183 (module bar (q r s) 2184 (import $zip) 2185 (define q (lambda () a)) 2186 (define-syntax r (identifier-syntax b)) 2187 (define s (lambda () c))) 2188 (list 2189 (let () (import bar) (q)) 2190 (let () (import bar) r) 2191 (let () (import bar) (s)) 2192 (let () (module (r) (import bar)) r))) 2193 '(1 123 (1 123) 123)) 2194 (error? 2195 (let () 2196 (module bar (q r s) 2197 (import $zip) 2198 (define q (lambda () a)) 2199 (define-syntax r (identifier-syntax b)) 2200 (define s (lambda () c))) 2201 (let ((q "outer")) (module (r) (import bar)) (q)))) 2202 (begin 2203 (module $zoom (m1 x) 2204 (define x "this is x") 2205 (module m1 (x (z y)) 2206 (define x "this is m1's x") 2207 (define y "this is m1's y") 2208 (define-syntax z (identifier-syntax y)))) 2209 (equal? (let () (import $zoom) (let ((q x)) (import m1) (list q x z))) 2210 '("this is x" "this is m1's x" "this is m1's y"))) 2211 (error? (let () (import $zoom) (define q x) (import m1) (list q x z))) 2212 ; check that we get the right x even though x (et al.) have 2213 ; multiple properties in the implementation. 2214 (begin 2215 (module $foo (x a b c) 2216 (define x "this is foo's X") 2217 (define a "this is foo's A") 2218 (define b "this is foo's B") 2219 (define c "this is foo's C")) 2220 (equal? 2221 (list (let () (import $foo) (list x a)) 2222 (let () (import $foo) (list b c))) 2223 '(("this is foo's X" "this is foo's A") 2224 ("this is foo's B" "this is foo's C")))) 2225 (error? (let () (import $foo) (import $zip) #t)) 2226) 2227 2228(mat module6 2229 (begin 2230 (define-syntax $from1 2231 (syntax-rules () 2232 ((_ m id) 2233 (let () (import-only m) id)))) 2234 (define-syntax $from2 2235 (syntax-rules () 2236 ((_ m id) 2237 (let () (module (id) (import m)) id)))) 2238 (define-syntax $from3 2239 (syntax-rules () 2240 [(_ m id) 2241 (let ([z (cons 1 2)]) 2242 (let ([id z]) 2243 (import m) 2244 (let ([t id]) 2245 (if (eq? t z) (errorf 'from "~s undefined" 'id) t))))])) 2246 (module $frappe (wire (whip egg)) 2247 (define wire 3) 2248 (define-syntax whip (identifier-syntax egg)) 2249 (define egg 'whites)) 2250 (equal? 2251 (list (cons ($from1 $frappe wire) ($from1 $frappe whip)) 2252 (cons ($from2 $frappe wire) ($from2 $frappe whip)) 2253 (cons ($from3 $frappe wire) ($from3 $frappe whip))) 2254 '((3 . whites) (3 . whites) (3 . whites)))) 2255 (equal? 2256 (let () 2257 (module q (m from) 2258 (module m (f) (define f "this is f")) 2259 (define-syntax from 2260 (syntax-rules () [(_ m id) (let () (import-only m) id)]))) 2261 (let () (import-only q) (from m f))) 2262 "this is f") 2263 (begin 2264 (module $q (m from) 2265 (module m (f) (define f "this is f")) 2266 (define-syntax from 2267 (syntax-rules () [(_ m id) (let () (import-only m) id)]))) 2268 (equal? (let () (import-only $q) (from m f)) "this is f")) 2269 (eqv? (let () 2270 (module p ((d m) f) 2271 (define-syntax d 2272 (syntax-rules () 2273 ((_ e) (m (lambda () e))))) 2274 (define m (lambda (x) x)) 2275 (define f (lambda (th) (th)))) 2276 (let () (import-only p) (f (d 2)))) 2277 2) 2278 (begin 2279 (module $p ((d m) f) 2280 (define-syntax d 2281 (syntax-rules () 2282 ((_ e) (m (lambda () e))))) 2283 (define m (lambda (x) x)) 2284 (define f (lambda (th) (th)))) 2285 (eqv? (let () (import-only $p) (f (d 2))) 2)) 2286 (error? (let () (import-only $p) (f (d cons)))) 2287) 2288 2289(mat module7 2290 (begin (module ($x) (define $x 3) (set! $x (+ $x $x))) 2291 (eq? $x 6)) 2292 (eq? (let () (module ($x) (define $x 3) (set! $x (+ $x $x))) $x) 6) 2293) 2294 2295(mat module8 2296 (begin 2297 (module $m ($a $b) 2298 (define-syntax $a (identifier-syntax 3)) 2299 (define-syntax $b (identifier-syntax $a))) 2300 (eq? (let () 2301 (import $m) 2302 (fluid-let-syntax (($a (identifier-syntax 4))) $b)) 2303 4)) 2304 (eq? (let () 2305 (import $m) 2306 (fluid-let-syntax (($a (identifier-syntax 4))) $a)) 2307 4) 2308 (begin 2309 (import $m) 2310 (eq? (fluid-let-syntax (($a (identifier-syntax 4))) $b) 4)) 2311 (begin 2312 (define-syntax $a 2313 (syntax-rules () 2314 ((_ m y z) 2315 (begin 2316 (module m ($crazy-x) (define $crazy-x 3731)) 2317 (import m) 2318 (define y (lambda () $crazy-x)) 2319 (define-syntax z (identifier-syntax $crazy-x)))))) 2320 #t) 2321 (begin 2322 ($a $crazy-p $crazy-q $crazy-r) 2323 (eq? $crazy-r 3731)) 2324 (error? $crazy-x) 2325 (eq? ($crazy-q) 3731) 2326 (eq? $crazy-r 3731) 2327 (begin 2328 (define-syntax $a1 2329 (syntax-rules () 2330 ((_ m y) 2331 (module m 2332 ($flash-x y) 2333 (define $flash-x "flash") 2334 (define y (lambda () $flash-x)))))) 2335 #t) 2336 (begin ($a1 $flash-p $flash-q) #t) 2337 (begin (import $flash-p) (procedure? $flash-q)) 2338 (error? $flash-x) 2339 (equal? ($flash-q) "flash") 2340 (begin 2341 (define-syntax $c 2342 (syntax-rules () 2343 ((_ y) 2344 (begin 2345 (define-syntax $blast-x (identifier-syntax "blast")) 2346 (define-syntax y (identifier-syntax $blast-x)))))) 2347 #t) 2348 (begin ($c $blast-y) (equal? $blast-y "blast")) 2349 (equal? $blast-y "blast") 2350 (error? $blast-x) 2351 (begin 2352 (define-syntax $b 2353 (syntax-rules () 2354 ((_ y) (begin 2355 (define $crud-x "crud") 2356 (define y (lambda () $crud-x)))))) 2357 #t) 2358 (begin ($b $crud-y) (procedure? $crud-y)) 2359 (equal? ($crud-y) "crud") 2360 (error? $crud-x) 2361 (begin 2362 (define-syntax $b2 2363 (syntax-rules () 2364 ((_ x y) 2365 (begin 2366 (define-syntax x 2367 (identifier-syntax 2368 (begin 2369 (define $idiot-x "idiot") 2370 $idiot-x))) 2371 (define y (lambda () $idiot-x)))))) 2372 #t) 2373 (begin ($b2 $idiot-q $idiot-p) (procedure? $idiot-p)) 2374 (equal? (let () $idiot-q) "idiot") 2375 (begin $idiot-q #t) 2376 (error? ($idiot-p)) 2377 ; the following should probably generate an error, but doesn't due to 2378 ; our change in wraps (we apply only the most recent substitution) 2379 ; (error? 2380 ; (begin 2381 ; (define-syntax a 2382 ; (lambda (?) 2383 ; (with-syntax ((xx ((lambda (x) #'x) 4))) 2384 ; #'(module (x) (define xx 3))))) 2385 ; a)) 2386 (eq? (let ((junk #f)) 2387 (module (a) (import scheme) 2388 (define-syntax a 2389 (lambda (x) 2390 (syntax-case x (foo car) 2391 ((_ foo car bar-lit cons-lit) 2392 (and (free-identifier=? #'bar-lit #'bar) 2393 (free-identifier=? #'cons-lit #'cons)) 2394 #''yup))))) 2395 (module () (import scheme) 2396 (set! junk (a foo car bar cons))) 2397 junk) 2398 'yup) 2399 (error? (let ((junk #f)) 2400 (module (a) (import scheme) 2401 (define-syntax a 2402 (lambda (x) 2403 (syntax-case x (foo car) 2404 ((_ foo car bar-lit cons-lit) 2405 (and (free-identifier=? #'bar-lit #'bar) 2406 (free-identifier=? #'cons-lit #'cons)) 2407 #''yup))))) 2408 (module () (import scheme) 2409 (define car 3) 2410 (set! junk (a foo car bar cons))) 2411 junk)) 2412) 2413 2414(mat module9 2415 (eq? (let () (import-only r5rs) (cond (else 0))) 0) 2416 (eq? (let () (import-only r5rs-syntax) (cond (else 0))) 0) 2417 (eq? (let () (import-only ieee) (cond (else 0))) 0) 2418 (eq? (let () (import-only scheme) (cond (else 0))) 0) 2419 (eq? (let () (import-only $system) (cond (else 0))) 0) 2420 (eq? (eval '(cond (else 0)) (scheme-report-environment 5)) 0) 2421 (eq? (eval '(cond (else 0)) (null-environment 5)) 0) 2422 (eq? (eval '(cond (else 0)) (interaction-environment)) 0) 2423 (eq? (eval '(cond (else 0)) (ieee-environment)) 0) 2424 (equal? 2425 (let () 2426 (import-only scheme) 2427 (define-record foo ((immutable a))) 2428 (foo-a (make-foo 3))) 2429 3) 2430 (equal? (let () 2431 (module foo (a b) 2432 (define-syntax a 2433 (syntax-rules (b) 2434 ((_ b) "yup") 2435 ((_ c) (list c)))) 2436 (define-syntax b 2437 (lambda (x) 2438 (syntax-error x "misplaced aux keyword")))) 2439 (let () 2440 (import-only foo) 2441 (a (a b)))) 2442 '("yup")) 2443 (equal? (let () 2444 (import-only scheme) 2445 `(a b ,(+ 3 4) ,@(list 'd 'e))) 2446 '(a b 7 d e)) 2447 ; assuming internal-defines-as-letrec* defaults to #t 2448 (internal-defines-as-letrec*) 2449 ; following tests assume it's set to #f 2450 (begin (internal-defines-as-letrec* #f) (not (internal-defines-as-letrec*))) 2451 (error? ; cookie undefined 2452 (begin 2453 (module ($b) 2454 (module (($b getvar)) 2455 (define getvar (lambda () "it worked")) 2456 (module (($b cookie tmp)) 2457 (define cookie "secret") 2458 (define tmp cookie) 2459 (define-syntax $b 2460 (identifier-syntax 2461 (if (eq? tmp cookie) (begin (set! tmp (getvar)) tmp) tmp)))))) 2462 (string=? $b "it worked"))) 2463 (begin (internal-defines-as-letrec* #t) (internal-defines-as-letrec*)) 2464 (begin 2465 (module ($b) 2466 (module (($b getvar)) 2467 (define getvar (lambda () "it worked")) 2468 (module (($b cookie tmp)) 2469 (define tmp) 2470 (define cookie "secret") 2471 (define-syntax $b 2472 (identifier-syntax 2473 (if (eq? tmp cookie) (begin (set! tmp (getvar)) tmp) tmp))) 2474 (set! tmp cookie)))) 2475 (string=? $b "it worked")) 2476 (begin 2477 (module $foo ($b) 2478 (module bar (($b getvar)) 2479 (module baz (($b cookie tmp)) 2480 (define cookie "secret") 2481 (define tmp) 2482 (define-syntax $b 2483 (identifier-syntax 2484 (if (eq? tmp cookie) (begin (set! tmp (getvar)) tmp) tmp))) 2485 (set! tmp cookie)) 2486 (define getvar (lambda () "this also worked")) 2487 (import baz)) 2488 (import bar)) 2489 (import $foo) 2490 (string=? $b "this also worked")) 2491) 2492 2493(mat module10 2494 (begin ; make sure we the right binding is exported 2495 (module ($module10-foo) 2496 (define $module10-foo "okay") 2497 (module () (define $module10-foo 'oh-oh))) 2498 #t) 2499 (equal? $module10-foo "okay") 2500 (begin 2501 (module ($module10-bar) 2502 (module () (define $module10-bar 'oh-oh)) 2503 (define $module10-bar "fine")) 2504 #t) 2505 (equal? $module10-bar "fine") 2506 (begin 2507 (module ($module10-qwerty) 2508 (module ($module10-qwerty) 2509 (define $module10-qwerty "dandy"))) 2510 #t) 2511 (equal? $module10-qwerty "dandy") 2512 (let () 2513 (module (foo) 2514 (define foo "okay") 2515 (module () (define foo 'oh-oh))) 2516 (equal? foo "okay")) 2517 (let () 2518 (module (bar) 2519 (module () (define bar 'oh-oh)) 2520 (define bar "fine")) 2521 (equal? bar "fine")) 2522 (let () 2523 (module (qwerty) 2524 (module (qwerty) 2525 (define qwerty "dandy"))) 2526 (equal? qwerty "dandy")) 2527) 2528 2529(mat module11 2530 (error? ; identifier out of context 2531 (module (x y) 2532 (define x 3) 2533 (define-syntax y (lambda (z) x)))) 2534 (error? ; identifier out of context 2535 (let () 2536 (module (x y) 2537 (define x 3) 2538 (define-syntax y (lambda (z) x))) 2539 y)) 2540) 2541 2542(mat with-implicit 2543 (error? ; invalid syntax 2544 (with-implicit)) 2545 (error? ; invalid syntax 2546 (with-implicit foo (bar ...) e1 e2)) 2547 (error? ; invalid syntax 2548 (with-implicit (a b c))) 2549 (error? ; invalid syntax 2550 (with-implicit (a b c) . d)) 2551 (error? ; invalid syntax 2552 (with-implicit (a b c) d . e)) 2553 (error? ; invalid syntax 2554 (with-implicit (1 2 3) d e)) 2555 (error? ; invalid syntax 2556 (with-implicit (a 2 c) d e)) 2557 (error? ; 15 is not an identifier 2558 (with-syntax ([a 15]) 2559 (with-implicit (a b c) d e))) 2560 (eqv? 2561 (let ((borf 'borf-outer)) 2562 (define-syntax frob 2563 (lambda (x) 2564 (syntax-case x () 2565 [k (with-implicit (k borf) #'borf)]))) 2566 frob) 2567 'borf-outer) 2568 (equal? 2569 (let ([borf 'borf-outer]) 2570 (define-syntax frob 2571 (lambda (x) 2572 (syntax-case x () 2573 [(k e) 2574 (with-implicit (k borf) 2575 #'(let () (define borf 'borf-inner) e))]))) 2576 (list borf (frob (list borf)))) 2577 '(borf-outer (borf-inner))) 2578 (equal? 2579 (let () 2580 (define-syntax for 2581 (lambda (x) 2582 (syntax-case x () 2583 [(k (e0 e1 e2) b1 b2 ...) 2584 (with-implicit (k break continue) 2585 #'(call/cc 2586 (lambda (break) 2587 e0 2588 (let f () 2589 (when e1 2590 (call/cc (lambda (continue) b1 b2 ...)) 2591 e2 2592 (f))))))]))) 2593 (define ls-in) 2594 (define ls-out) 2595 (for ((begin (set! ls-in '(a b c d e f g h i j)) (set! ls-out '())) 2596 (not (null? ls-in)) 2597 (set! ls-in (cdr ls-in))) 2598 (when (memq (car ls-in) '(c e)) (continue)) 2599 (set! ls-out (cons (car ls-in) ls-out)) 2600 (when (memq (car ls-in) '(g j)) (break))) 2601 ls-out) 2602 '(g f d b a)) 2603) 2604 2605(mat datum 2606 (error? (datum)) 2607 (error? (datum a b c)) 2608 (error? (datum . b)) 2609 (equal? (datum (a b c)) '(a b c)) 2610 (equal? 2611 (let () 2612 (define-syntax ralph 2613 (lambda (x) 2614 (syntax-case x () 2615 [(k a b) 2616 (fixnum? (datum a)) 2617 (with-syntax ([q (datum->syntax #'k (make-list (datum a) 15))]) 2618 #'(cons b 'q))] 2619 [(_ a b) #'(cons 'a 'b)]))) 2620 (list (ralph 3 4) (ralph 3.0 4.0))) 2621 '((4 15 15 15) (3.0 . 4.0))) 2622) 2623 2624(mat alias 2625 (error? ; invalid syntax 2626 (alias x "y")) 2627 (error? ; invalid syntax 2628 (alias 3 x)) 2629 (eq? (let ((x 2)) (alias y x) y) 2) 2630 (equal? 2631 (let ((x "x")) 2632 (define-syntax fool 2633 (let () 2634 (alias y x) 2635 (lambda (z) #'y))) 2636 fool) 2637 "x") 2638 (equal? 2639 (let () 2640 (define x "x") 2641 (alias y x) 2642 y) 2643 "x") 2644 (begin 2645 (module (($alias-blue blue)) 2646 (define blue "bleu") 2647 (alias $alias-blue blue)) 2648 (equal? $alias-blue "bleu")) 2649 (begin 2650 (define $alias-blot "blot") 2651 (equal? (let () (alias y $alias-blot) y) "blot")) 2652 (begin 2653 (define $alias-f (let () (alias x $alias-blarg) (lambda () x))) 2654 (procedure? $alias-f)) 2655 (error? ; $alias-blarg not bound 2656 ($alias-f)) 2657 (begin 2658 (define $alias-blarg "blarg") 2659 (equal? ($alias-f) "blarg")) 2660 (begin 2661 (define-syntax $alias-blarg (lambda (x) "bloog")) 2662 (equal? ($alias-f) "blarg")) 2663 (begin 2664 (define $alias-g (let () (alias x lambda) (x () "g"))) 2665 (equal? ($alias-g) "g")) 2666 (begin 2667 (define $alias-x 3) 2668 (alias $alias-y $alias-x) 2669 (eq? $alias-y 3)) 2670 (eq? (let () 2671 (define $alias-x 4) 2672 (alias $alias-y $alias-x) 2673 $alias-y) 2674 4) 2675 ; the following is no longer an error: binding for label is exported 2676 ; if the alias's identifier is exported 2677 (begin 2678 (module ($alias-y) 2679 (define $alias-x 5) 2680 (alias $alias-y $alias-x)) 2681 (eq? $alias-y 5)) 2682 (begin 2683 (module ($alias-y55) 2684 (define $alias-x55 5) 2685 (alias $alias-y55 $alias-x55) 2686 (alias $alias-z55 $alias-x55)) 2687 (eq? $alias-y 5)) 2688 (error? $alias-x55) 2689 (error? $alias-z55) 2690 (begin 2691 (module (($alias-y $alias-x)) 2692 (define $alias-x 6) 2693 (alias $alias-y $alias-x)) 2694 (eq? $alias-y 6)) 2695 (begin 2696 (module ($alias-y) 2697 (module (($alias-y $alias-x)) 2698 (define $alias-x 66) 2699 (alias $alias-y $alias-x))) 2700 (eq? $alias-y 66)) 2701 (eq? (let () 2702 (module (($alias-y $alias-x)) 2703 (define $alias-x 7) 2704 (alias $alias-y $alias-x)) 2705 $alias-y) 2706 7) 2707 (eq? (let ((x 8)) 2708 (module (y) (alias y x)) 2709 y) 2710 8) 2711 (error? ; read-only environment 2712 (eval '(alias x cons) (scheme-environment))) 2713 (error? ; read-only environment 2714 (eval 2715 '(begin 2716 (import scheme) 2717 (alias $alias-cons cons) 2718 (set! $alias-cons 3)) 2719 (copy-environment (interaction-environment)))) 2720 (error? ; read-only environment 2721 (eval 2722 '(begin 2723 (import scheme) 2724 (set! cons 3)) 2725 (copy-environment (interaction-environment)))) 2726 (begin 2727 (module (($i-foo foo)) 2728 (define-record foo ()) 2729 (alias $i-foo foo)) 2730 (define-record $i-bar $i-foo (x)) 2731 ($i-bar? (make-$i-bar 3))) 2732 (begin 2733 (module ($i-foo) 2734 (module m (foo) (define-record foo ())) 2735 (module g2 (($i-foo g3)) 2736 (module g2 ((g3 foo)) 2737 (import m) 2738 (alias g3 foo)) 2739 (import g2) 2740 (alias $i-foo g3)) 2741 (import g2)) 2742 (define-record $i-bar $i-foo (x)) 2743 ($i-bar? (make-$i-bar 3))) 2744 (begin 2745 (module $alias-m ($alias:car) (import scheme) (alias $alias:car car)) 2746 (import $alias-m) 2747 (eqv? ($alias:car '(2.3 4.5 6.7)) 2.3)) 2748 (begin 2749 (library ($alias-a) 2750 (export x) 2751 (import (chezscheme)) 2752 (define y 17) 2753 (alias x y)) 2754 #t) 2755 (eqv? (let () (import ($alias-a)) x) 17) 2756 (error? ; attempt to create an alias to unbound identifier y 2757 (library ($alias-b) 2758 (export x) 2759 (import (chezscheme)) 2760 (alias x y))) 2761 (error? ; attempt to create an alias to unbound identifier y 2762 (library ($alias-c) 2763 (export y) 2764 (import (chezscheme)) 2765 (alias x y) 2766 (define y 17))) 2767 (begin 2768 (with-output-to-file "testfile-alias-d.ss" 2769 (lambda () 2770 (pretty-print 2771 '(library (testfile-alias-d) 2772 (export x) 2773 (import (chezscheme)) 2774 (alias x y) 2775 (define y 17)))) 2776 'replace) 2777 #t) 2778 (error? ; attempt to create an alias to unbound identifier y 2779 (compile-file "testfile-alias-d")) 2780 (error? ; attempt to create an alias to unbound identifier y 2781 (load "testfile-alias-d.ss")) 2782 (error? ; attempt to create an alias to unbound identifier y 2783 (library ($alias-b) 2784 (export x) 2785 (import (chezscheme)) 2786 (let () (alias x y) 'hello))) 2787 (eqv? 2788 (let () 2789 (import-only (chezscheme)) 2790 (define y 17) 2791 (alias x y) 2792 x) 2793 17) 2794 (error? ; attempt to create an alias to unbound identifier y 2795 (let () 2796 (import-only (chezscheme)) 2797 (alias x y) 2798 7)) 2799 (error? ; attempt to create an alias to unbound identifier y 2800 (let () 2801 (import-only (chezscheme)) 2802 (alias x y) 2803 (define y 3) 2804 7)) 2805 (begin 2806 (with-output-to-file "testfile-alias-e.ss" 2807 (lambda () 2808 (pretty-print 2809 '(let () 2810 (import-only (chezscheme)) 2811 (alias x y) 2812 (define y 3) 2813 7))) 2814 'replace) 2815 #t) 2816 (error? ; attempt to create an alias to unbound identifier y 2817 (compile-file "testfile-alias-e")) 2818 (error? ; attempt to create an alias to unbound identifier y 2819 (load "testfile-alias-e.ss")) 2820) 2821 2822(mat extended-import 2823 (begin 2824 (module $notscheme (cons car cdr) 2825 (define cons) 2826 (define car) 2827 (define-syntax cdr (identifier-syntax $cdr))) 2828 #t) 2829 (equivalent-expansion? 2830 (parameterize ([#%$suppress-primitive-inlining #f]) 2831 (expand ' 2832 (let () 2833 (import $notscheme) 2834 (let () 2835 (import scheme) 2836 (cons car cdr))))) 2837 (if (= (optimize-level) 3) 2838 '(#3%cons #3%car #3%cdr) 2839 '(#2%cons #2%car #2%cdr))) 2840 (equivalent-expansion? 2841 (parameterize ([#%$suppress-primitive-inlining #f]) 2842 (expand ' 2843 (let () 2844 (import $notscheme) 2845 (let () 2846 (import (only scheme car cdr)) 2847 (cons car cdr))))) 2848 (if (= (optimize-level) 3) 2849 '((#3%$top-level-value 'cons) #3%car #3%cdr) 2850 '((#2%$top-level-value 'cons) #2%car #2%cdr))) 2851 (equivalent-expansion? 2852 (parameterize ([#%$suppress-primitive-inlining #f]) 2853 (expand ' 2854 (let () 2855 (import $notscheme) 2856 (let () 2857 (import (except scheme car cdr)) 2858 (cons car cdr))))) 2859 (if (= (optimize-level) 3) 2860 '(#3%cons (#3%$top-level-value 'car) $cdr) 2861 '(#2%cons (#2%$top-level-value 'car) $cdr))) 2862 (equivalent-expansion? 2863 (parameterize ([#%$suppress-primitive-inlining #f]) 2864 (expand ' 2865 (let () 2866 (import $notscheme) 2867 (let () 2868 (import (only (except scheme cdr) car)) 2869 (cons car cdr))))) 2870 (if (= (optimize-level) 3) 2871 '((#3%$top-level-value 'cons) #3%car $cdr) 2872 '((#2%$top-level-value 'cons) #2%car $cdr))) 2873 (equivalent-expansion? 2874 (parameterize ([#%$suppress-primitive-inlining #f]) 2875 (expand ' 2876 (let () 2877 (import $notscheme) 2878 (let () 2879 (import (add-prefix (only scheme car cdr) scheme:)) 2880 (cons scheme:car cdr))))) 2881 (if (= (optimize-level) 3) 2882 '((#3%$top-level-value 'cons) #3%car $cdr) 2883 '((#2%$top-level-value 'cons) #2%car $cdr))) 2884 (equivalent-expansion? 2885 (parameterize ([#%$suppress-primitive-inlining #f]) 2886 (expand ' 2887 (let () 2888 (import $notscheme) 2889 (let () 2890 (import (drop-prefix (only scheme car cdr cons) c)) 2891 (ons ar dr))))) 2892 (if (= (optimize-level) 3) 2893 '(#3%cons #3%car #3%cdr) 2894 '(#2%cons #2%car #2%cdr))) 2895 (equivalent-expansion? 2896 (parameterize ([#%$suppress-primitive-inlining #f]) 2897 (expand ' 2898 (let () 2899 (import $notscheme) 2900 (let () 2901 (import (rename scheme [car xar] [cdr xdr])) 2902 (cons xar cdr))))) 2903 (if (= (optimize-level) 3) 2904 '(#3%cons #3%car $cdr) 2905 '(#2%cons #2%car $cdr))) 2906 (equivalent-expansion? 2907 (parameterize ([#%$suppress-primitive-inlining #f]) 2908 (expand ' 2909 (let () 2910 (import $notscheme) 2911 (let () 2912 (import (alias scheme [car xar] [cdr xdr])) 2913 (cons xar cdr))))) 2914 (if (= (optimize-level) 3) 2915 '(#3%cons #3%car #3%cdr) 2916 '(#2%cons #2%car #2%cdr))) 2917 ; no glob support yet 2918 #;(equivalent-expansion? 2919 (parameterize ([#%$suppress-primitive-inlining #f]) 2920 (expand ' 2921 (let () 2922 (import $notscheme) 2923 (let () 2924 (import (glob scheme c*r)) 2925 (cons car cdr))))) 2926 '(cons #2%car #2%cdr)) 2927 (begin 2928 (module ($i-foo) 2929 (module m (foo) (define foo 45)) 2930 (import (add-prefix m $i-))) 2931 (eq? $i-foo 45)) 2932 (begin 2933 (library ($s) (export $spam) 2934 (import (scheme)) 2935 (module m (spam) (define spam 3)) 2936 (import (prefix m $))) 2937 (import ($s)) 2938 (eqv? $spam 3)) 2939 (begin 2940 (module ($i-foo) 2941 (module m (m:$i-foo) (define m:$i-foo 57)) 2942 (import (drop-prefix m m:))) 2943 (eq? $i-foo 57)) 2944 (begin 2945 (module ($i-foo) 2946 (module m (bar) (define bar 63)) 2947 (import (rename m (bar $i-foo)))) 2948 (eq? $i-foo 63)) 2949 (begin 2950 (module ($i-foo) 2951 (module m (bar) (define bar 75)) 2952 (import (alias m (bar $i-foo)))) 2953 (eq? $i-foo 75)) 2954 (begin 2955 (module ($i-x $i-y) 2956 (module m ($i-x $i-y) (define $i-x "x") (define $i-y "y")) 2957 (import (rename m ($i-y $i-x) ($i-x $i-y)))) 2958 (equal? (list $i-x $i-y) '("y" "x"))) 2959 (error? ; duplicate identifiers $i-x and $i-y 2960 (begin 2961 (module ($i-x $i-y) 2962 (module m ($i-x $i-y) (define $i-x "x") (define $i-y "y")) 2963 (import (alias m ($i-x $i-y) ($i-y $i-x)))) 2964 (equal? (list $i-x $i-y) '("y" "x")))) 2965 (error? ; duplicate identifiers $i-x and $i-y 2966 (let () 2967 (module ($i-x $i-y) 2968 (module m ($i-x $i-y) (define $i-x "x") (define $i-y "y")) 2969 (import (alias m ($i-x $i-y) ($i-y $i-x)))) 2970 (equal? (list $i-x $i-y) '("y" "x")))) 2971 (begin 2972 (module ($i-foo) 2973 (module m (foo) (define-record foo ())) 2974 (import (rename m (foo $i-foo)))) 2975 (define-record $i-bar $i-foo (x)) 2976 ($i-bar? (make-$i-bar 3))) 2977 (let () 2978 (module ($i-foo) 2979 (module m (foo) (define-record foo ())) 2980 (import (rename m (foo $i-foo)))) 2981 (define-record $i-bar $i-foo (x)) 2982 ($i-bar? (make-$i-bar 3))) 2983 (begin 2984 (module ($i-foo) 2985 (module m (foo) (module foo ($i-x) (define $i-x 14))) 2986 (import (rename m (foo $i-foo)))) 2987 (import $i-foo) 2988 (eq? $i-x 14)) 2989 (let () 2990 (module ($i-foo) 2991 (module m (foo) (module foo ($i-x) (define $i-x 14))) 2992 (import (rename m (foo $i-foo)))) 2993 (import $i-foo) 2994 (eq? $i-x 14)) 2995 (error? ; y not visible 2996 (begin 2997 (module m (x y) (define x 3) (define y 4)) 2998 (let ((x 5) (y 6)) (import-only (only m x)) y))) 2999 (error? ; y not visible 3000 (begin 3001 (module m (x y) (define x 3) (define y 4)) 3002 (let ((x 5) (y 6)) 3003 ; equivalent of (import-only (only m x)): 3004 (begin 3005 (module g0 (x) (import-only m)) 3006 (import-only g0)) 3007 y))) 3008 (begin ; keep with next 3009 (define $i-grotto-x 7) 3010 (define $i-grotto-y 8) 3011 (define $i-grotto-z 9) 3012 (equal? (list $i-grotto-x $i-grotto-y $i-grotto-z) '(7 8 9))) 3013 (begin ; keep with preceding 3014 (module $i-grotto ($i-grotto-x $i-grotto-y $i-grotto-z) 3015 (define $i-grotto-x 3) 3016 (define $i-grotto-y 4) 3017 (define $i-grotto-z 5)) 3018 (import (only $i-grotto $i-grotto-x)) 3019 (equal? (list $i-grotto-x $i-grotto-y $i-grotto-z) '(3 8 9))) 3020 (begin 3021 (import (rename (only scheme car) [car $i-car-from-scheme])) 3022 (eq? ($i-car-from-scheme '(a b c)) 'a)) 3023 (begin 3024 (import (only (add-prefix scheme $i-scheme:) $i-scheme:list)) 3025 (equal? ($i-scheme:list 3 4 5) '(3 4 5))) 3026 (begin 3027 (import (add-prefix (only scheme list) $i-scheme:)) 3028 (equal? ($i-scheme:list 3 4 5) '(3 4 5))) 3029) 3030 3031(mat import ; check import semantics changes May 05 3032 (begin 3033 (define $imp-x 0) 3034 (module $imp-m ($imp-x) (define $imp-x 3)) 3035 (define-syntax $imp-from (syntax-rules () [(_ $imp-m $imp-x) (let () (import $imp-m) $imp-x)])) 3036 (define-syntax $imp-from-m (syntax-rules () [(_ $imp-x) (let () (import $imp-m) $imp-x)])) 3037 (define-syntax $imp-x-from (syntax-rules () [(_ $imp-m) (let () (import $imp-m) $imp-x)])) 3038 (define-syntax $imp-x-from-m (syntax-rules () [(_) (let () (import $imp-m) $imp-x)])) 3039 (define-syntax $imp-module* 3040 (syntax-rules () 3041 [(_ (x ...) d ...) 3042 (begin (module t (x ...) d ...) (import t))])) 3043 (define-syntax $imp-import* 3044 (syntax-rules () [(_ m) (import m)])) 3045 #t) 3046 (eqv? ($imp-from $imp-m $imp-x) 3) 3047 (eqv? ($imp-from-m $imp-x) 0) 3048 (eqv? ($imp-x-from $imp-m) 0) 3049 (eqv? ($imp-x-from-m) 3) 3050 (eqv? (let () ($imp-from $imp-m $imp-x)) 3) 3051 (eqv? (let () ($imp-from-m $imp-x)) 0) 3052 (eqv? (let () ($imp-x-from $imp-m)) 0) 3053 (eqv? (let () ($imp-x-from-m)) 3) 3054 (eqv? (let () (module $imp-m ($imp-x) (define $imp-x 4)) ($imp-from $imp-m $imp-x)) 4) 3055 (eqv? (let () (module $imp-m ($imp-x) (define $imp-x 4)) ($imp-from-m $imp-x)) 0) 3056 (eqv? (let () (module $imp-m ($imp-x) (define $imp-x 4)) ($imp-x-from $imp-m)) 0) 3057 (eqv? (let () (module $imp-m ($imp-x) (define $imp-x 4)) ($imp-x-from-m)) 3) 3058 (eqv? (let () (module m (x) (define x 4)) ($imp-import* m) x) 4) 3059 (eqv? (let () ($imp-module* (x) (define y 5) (define x (lambda () y))) (x)) 5) 3060 (equal? 3061 (let () 3062 (define-syntax module* 3063 (syntax-rules () 3064 [(_ (x ...) d ...) 3065 (begin (module t (x ...) d ...) (import t))])) 3066 (define-syntax import* (syntax-rules () [(_ m) (import m)])) 3067 (define x 0) 3068 (module m (x) (define x 3)) 3069 (define-syntax from (syntax-rules () [(_ m x) (let () (import m) x)])) 3070 (define-syntax from-m (syntax-rules () [(_ x) (let () (import m) x)])) 3071 (define-syntax x-from (syntax-rules () [(_ m) (let () (import m) x)])) 3072 (define-syntax x-from-m (syntax-rules () [(_) (let () (import m) x)])) 3073 (module* (a) (define b 'bee) (define a (lambda () b))) 3074 (list 3075 (let () (module m (x) (define x 4)) (from m x)) 3076 (let () (module m (x) (define x 4)) (from-m x)) 3077 (let () (module m (x) (define x 4)) (x-from m)) 3078 (let () (module m (x) (define x 4)) (x-from-m)) 3079 (let () (import* m) x) 3080 (a))) 3081 '(4 0 0 3 3 bee)) 3082 (equal? 3083 (let () 3084 (define-syntax alpha 3085 (syntax-rules () 3086 [(_ m v e) 3087 (let () 3088 (module m (v x) 3089 (define x 'introduced) 3090 (define v 'supplied)) 3091 (list e (let () (import m) (list v x))))])) 3092 (let () (alpha q x (let () (import q) x)))) 3093 '(supplied (supplied introduced))) 3094 (begin 3095 (module $imp-list ($imp-null? $imp-car $imp-cdr $imp-cons) 3096 (import (add-prefix (only scheme null? car cdr cons) $imp-))) 3097 (define-syntax $imp-a 3098 (syntax-rules () 3099 ((_ x) (define-syntax x 3100 (lambda (q) 3101 (import (only $imp-list $imp-car)) 3102 #'$imp-car))))) 3103 ($imp-a $imp-foo) 3104 (eqv? $imp-foo #%car)) 3105 (eqv? 3106 (let () 3107 (module rat (fink dog) (define fink 'lestein) (define dog 'cat)) 3108 (define-syntax a 3109 (syntax-rules () 3110 ((_ x) (define-syntax x 3111 (lambda (q) 3112 (import (only rat fink)) 3113 #'fink))))) 3114 (a foo) 3115 foo) 3116 'lestein) 3117 (eqv? 3118 (let () 3119 (module rat (fink dog) (define fink 'lestein) (define dog 'cat)) 3120 (define-syntax a 3121 (syntax-rules () 3122 ((_ x) (define-syntax x 3123 (lambda (q) 3124 (import (add-prefix rat r:)) 3125 #'r:fink))))) 3126 (a foo) 3127 foo) 3128 'lestein) 3129 (eqv? 3130 (let () 3131 (module rat (fink dog) (define fink 'lestein) (define dog 'cat)) 3132 (define-syntax a 3133 (syntax-rules () 3134 ((_ x) (define-syntax x 3135 (lambda (q) 3136 (import (except rat dog)) 3137 #'fink))))) 3138 (a foo) 3139 foo) 3140 'lestein) 3141 (eqv? 3142 (let () 3143 (module m (x) (define x 'x1)) 3144 (define-syntax a 3145 (lambda (q) 3146 #'(let ([x 'x2]) 3147 (module n (x) (import m)) 3148 (let () (import n) x)))) 3149 a) 3150 'x1) 3151 (eqv? 3152 (let () 3153 (module m (x) (define x 'x1)) 3154 (define-syntax a 3155 (lambda (q) 3156 #'(let ([x 'x2]) 3157 (import m) 3158 x))) 3159 a) 3160 'x1) 3161 (error? ; duplicate definition for x 3162 (let () 3163 (module m (x) (define x 'x1)) 3164 (define-syntax a 3165 (lambda (q) 3166 #'(let () 3167 (define x 'x2) 3168 (import m) 3169 x))) 3170 a)) 3171 (error? ; duplicate definition for x 3172 (let () 3173 (module m (x) (define x 'x1)) 3174 (define-syntax a 3175 (lambda (q) 3176 #'(let () 3177 (import m) 3178 (define x 'x2) 3179 x))) 3180 a)) 3181 (equal? 3182 (let () 3183 (import scheme) 3184 (import scheme) 3185 car) 3186 car) 3187 (error? ; "duplicate definition for car 3188 (let () 3189 (import scheme) 3190 (import (rename scheme (cdr car))) 3191 car)) 3192 (error? ; duplicate definition for car 3193 (let () 3194 (module (car) (define car 'edsel)) 3195 (import scheme) 3196 car)) 3197 (error? ; duplicate definition for car 3198 (let () 3199 (define-syntax a 3200 (lambda (q) 3201 #'(let () 3202 (module (car) (define car 'edsel)) 3203 (import scheme) 3204 car))) 3205 a)) 3206 (equal? 3207 (let () 3208 (define-syntax a 3209 (lambda (q) 3210 #'(let () 3211 (import scheme) 3212 (import scheme) 3213 car))) 3214 a) 3215 car) 3216 (error? ; duplicate definition for x 3217 (let () 3218 (define-syntax a 3219 (lambda (q) 3220 #'(let () 3221 (define x 5) 3222 (define-syntax x (identifier-syntax 5)) 3223 x))) 3224 a)) 3225 (error? ; missing definition for export(s) (xxx). 3226 (let () 3227 (define-syntax a 3228 (syntax-rules () 3229 [(_ m i) (module m (i) (import m1))])) 3230 (module m1 (xxx) (define xxx 155)) 3231 (a m2 xxx) 3232 (let () (import m2) xxx))) 3233 (equal? 3234 (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))]) 3235 (expand/optimize 3236 '(let-syntax ([a (lambda (x) #'(let () (import scheme) car))]) 3237 a))) 3238 (if (= (optimize-level) 3) '#3%car '#2%car)) 3239 (equal? 3240 (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))]) 3241 (expand/optimize 3242 '(let-syntax ([a (syntax-rules () 3243 [(_ x) 3244 (define-syntax x 3245 (lambda (q) 3246 (import scheme) 3247 #'car))])]) 3248 (a foo) 3249 foo))) 3250 (if (= (optimize-level) 3) '#3%car '#2%car)) 3251 (error? ; read-only environment 3252 (eval '(import (rnrs)) (scheme-environment))) 3253 (error? ; invalid context for import 3254 (let ([x (import)]) x)) 3255 ; check 10/27/2010 change to make sense of multiple modules/libraries 3256 ; within the same import-only form 3257 (equal? 3258 (let () 3259 (module m1 (x) (define x box)) 3260 (module m2 (y) (define y 772)) 3261 (let () 3262 (import-only m1 m2) 3263 (x y))) 3264 '#&772) 3265 (equal? 3266 (let () 3267 (module m1 (x) (define x box)) 3268 (module m2 (y) (define y 772)) 3269 (let () 3270 (import m1 m2) 3271 (x y))) 3272 '#&772) 3273 (error? ; unbound identifier list 3274 (let () 3275 (module m1 (x) (define x 29)) 3276 (module m2 (y) (define y 772)) 3277 (let () 3278 (import-only m1 m2) 3279 (list x y)))) 3280 (equal? 3281 (let () 3282 (module m1 (x) (define x 29)) 3283 (module m2 (y) (define y 772)) 3284 (let () 3285 (import m1 m2) 3286 (list x y))) 3287 '(29 772)) 3288 (equal? 3289 (let () 3290 (module m1 (x) (define x 29)) 3291 (module m2 (y) (define y 772)) 3292 (let () 3293 (import-only scheme m1 m2) 3294 (list x y))) 3295 '(29 772)) 3296 (equal? 3297 (let () 3298 (module m1 (x) (define x 29)) 3299 (module m2 (y) (define y 772)) 3300 (let () 3301 (import scheme m1 m2) 3302 (list x y))) 3303 '(29 772)) 3304 (equal? 3305 (let () 3306 (module m1 (x) (define x 29)) 3307 (module m2 (y) (define y 772)) 3308 (let () 3309 (import-only (scheme) m1 m2) 3310 (list x y))) 3311 '(29 772)) 3312 (equal? 3313 (let () 3314 (module m1 (x) (define x 29)) 3315 (module m2 (y) (define y 772)) 3316 (let () 3317 (import (scheme) m1 m2) 3318 (list x y))) 3319 '(29 772)) 3320 (equal? 3321 (let () 3322 (module m1 (x) (define x 29)) 3323 (module m2 (y) (define y 772)) 3324 (let () 3325 (import-only m1 m2 (scheme)) 3326 (list x y))) 3327 '(29 772)) 3328 (equal? 3329 (let () 3330 (module m1 (x) (define x 29)) 3331 (module m2 (y) (define y 772)) 3332 (let () 3333 (import m1 m2 (scheme)) 3334 (list x y))) 3335 '(29 772)) 3336 (begin 3337 (library ($io A) (export p) (import (rnrs)) (define p 17)) 3338 (library ($io B) (export q) (import (rnrs)) (define q (lambda (x) (cons 'q x)))) 3339 (library ($io C) (export r) (import (chezscheme) ($io B)) 3340 (import-only ($io A) (only (rnrs) define *)) 3341 (define r (* p 2))) 3342 #t) 3343 (equal? 3344 (let () 3345 (import-only ($io B) ($io C)) 3346 (q r)) 3347 '(q . 34)) 3348 (error? ; unbound identifier p 3349 (let () 3350 (import ($io A)) 3351 (import-only ($io B) ($io C)) 3352 (q p))) 3353 (begin 3354 (library ($io A) (export p) (import (rnrs)) (define p 17)) 3355 (library ($io B) (export q) (import (rnrs)) (define q (lambda (x) (cons 'q x)))) 3356 (library ($io C) (export r) (import (chezscheme) ($io B)) 3357 (import ($io A) (only (rnrs) define *)) 3358 (define r (* p 2))) 3359 #t) 3360 (equal? 3361 (let () 3362 (import ($io B) ($io C)) 3363 (q r)) 3364 '(q . 34)) 3365 (equal? 3366 (let () 3367 (import ($io A)) 3368 (import ($io B) ($io C)) 3369 (q p)) 3370 '(q . 17)) 3371 (error? ; unbound identifier p 3372 (begin 3373 (library ($io A) (export p) (import (rnrs)) (define p 17)) 3374 (library ($io B) (export q) (import (rnrs)) (define q (lambda (x) (cons 'q x)))) 3375 (library ($io C) (export r) (import (chezscheme) ($io A)) 3376 (import-only ($io B) (only (rnrs) define *)) 3377 (define r (* p 2))))) 3378 (begin 3379 (library ($io A) (export p) (import (rnrs)) (define p 17)) 3380 (library ($io B) (export q) (import (rnrs)) (define q (lambda (x) (cons 'q x)))) 3381 (library ($io C) (export r) (import (chezscheme) ($io A)) 3382 (import ($io B) (only (rnrs) define *)) 3383 (define r (* p 2))) 3384 #t) 3385 (error? ; unbound identifier * 3386 (begin 3387 (library ($io A) (export p) (import (rnrs)) (define p 17)) 3388 (library ($io B) (export q) (import (rnrs)) (define q (lambda (x) (cons 'q x)))) 3389 (library ($io C) (export r) (import (chezscheme) ($io A)) 3390 (import-only ($io B) (only (rnrs) define)) 3391 (define r (* p 2))))) 3392 (begin 3393 (library ($io A) (export p) (import (rnrs)) (define p 17)) 3394 (library ($io B) (export q) (import (rnrs)) (define q (lambda (x) (cons 'q x)))) 3395 (library ($io C) (export r) (import (chezscheme) ($io A)) 3396 (import ($io B) (only (rnrs) define)) 3397 (define r (* p 2))) 3398 #t) 3399 ; check for let-like semantics for import w/multiple subforms 3400 (eq? 3401 (let () 3402 (module A (B) (module B (x) (define x 'a-b))) 3403 (module B (x) (define x 'b)) 3404 (let () 3405 (import A B) 3406 x)) 3407 'b) 3408 (eq? 3409 (let () 3410 (module A (B) (module B (x) (define x 'a-b))) 3411 (module B (x) (define x 'b)) 3412 (let () 3413 (import-only A B) 3414 x)) 3415 'b) 3416) 3417 3418(mat export ; test stand-alone export form 3419 (error? ; export outside module or library 3420 (export)) 3421 (error? ; export outside module or library 3422 (export cons)) 3423 (error? ; export outside module or library 3424 (top-level-program 3425 (import (chezscheme)) 3426 (export))) 3427 (let () 3428 (export) 3429 #t) 3430 (error? ; nonempty export outside module or library 3431 (let () 3432 (export cons) 3433 #t)) 3434 (begin 3435 (module () 3436 (define $ex-x 3) 3437 (export (rename ($ex-x $ex-y) ($ex-y $ex-x))) 3438 (define $ex-y 4)) 3439 #t) 3440 (equal? 3441 (cons $ex-x $ex-y) 3442 '(4 . 3)) 3443 (begin 3444 (library ($ex-A) (export) (import (chezscheme)) 3445 (define $ex-x 7) 3446 (export (rename ($ex-x $ex-y) ($ex-y $ex-x))) 3447 (define $ex-y 9)) 3448 #t) 3449 (equal? 3450 (let () 3451 (import ($ex-A)) 3452 (cons $ex-x $ex-y)) 3453 '(9 . 7)) 3454 (begin 3455 (import ($ex-A)) 3456 #t) 3457 (equal? 3458 (cons $ex-x $ex-y) 3459 '(9 . 7)) 3460 (equal? 3461 (let () 3462 (module () 3463 (define $ex-x 3) 3464 (export (rename ($ex-x $ex-y) ($ex-y $ex-x))) 3465 (define $ex-y 4)) 3466 (cons $ex-x $ex-y)) 3467 '(4 . 3)) 3468 (begin 3469 (module $ex-m (x x) 3470 (define x 5) 3471 (export x)) 3472 #t) 3473 (eqv? (let () (import $ex-m) x) 5) 3474 (eqv? 3475 (let () 3476 (module (x x) 3477 (define x 5) 3478 (export x)) 3479 x) 3480 5) 3481 (eqv? 3482 (let () 3483 (module (x) 3484 (define x 5) 3485 (export x)) 3486 x) 3487 5) 3488 (error? ; duplicate export 3489 (module (x) 3490 (define x 15) 3491 (define y 117) 3492 (export (rename (y x))))) 3493 (begin 3494 ; okay to export id twice as long as it has the same binding 3495 (library ($ex-B) (export x x) (import (chezscheme)) 3496 (define x 25) 3497 (export x)) 3498 #t) 3499 (eqv? (let () (import ($ex-B)) x) 25) 3500 (begin 3501 ; okay to export id twice as long as it has the same binding 3502 (library ($ex-B) (export x (rename (x x))) (import (chezscheme)) 3503 (define x 25) 3504 (export x)) 3505 #t) 3506 (eqv? (let () (import ($ex-B)) x) 25) 3507 (begin 3508 ; okay to export id twice as long as it has the same binding 3509 (library ($ex-B) (export x (rename (y x))) (import (chezscheme)) 3510 (define x 25) 3511 (alias y x) 3512 (export x)) 3513 #t) 3514 (eqv? (let () (import ($ex-B)) x) 25) 3515 (begin 3516 (library ($ex-B) (export x) (import (chezscheme)) 3517 (define x 35) 3518 (export x)) 3519 #t) 3520 (eqv? (let () (import ($ex-B)) x) 35) 3521 (begin 3522 (import ($ex-B)) 3523 (eqv? x 35)) 3524 (error? ; duplicate export 3525 (library ($ex-C) (export x) (import (chezscheme)) 3526 (define x 5) 3527 (define y 17) 3528 (export (rename (y x))))) 3529 (equal? 3530 (let () 3531 (module f ((a x y)) 3532 (import (chezscheme)) 3533 (define x 3) 3534 (define y 4) 3535 (define-syntax a (identifier-syntax (cons x y))) 3536 (export a)) 3537 (import f) 3538 a) 3539 '(3 . 4)) 3540 (equal? 3541 (let () 3542 (module m () 3543 (define x 3) 3544 (module m1 (x y) 3545 (define x 4) 3546 (define-syntax y (identifier-syntax x)) 3547 (indirect-export y x)) 3548 (export (import m1))) 3549 (let () 3550 (import m) 3551 (list x y))) 3552 '(4 4)) 3553 (equal? 3554 (let () 3555 (module m () 3556 (define x 3) 3557 (module m1 (x y) 3558 (define x 4) 3559 (define-syntax y (identifier-syntax x)) 3560 (indirect-export y x)) 3561 (export (import (only m1 y)) x)) 3562 (let () 3563 (import m) 3564 (list x y))) 3565 '(3 4)) 3566 (begin 3567 (define-syntax $ex-export1 3568 (syntax-rules () 3569 [(_ (m id ...)) (export (import (only m id ...)))] 3570 [(_ id) (export id)])) 3571 (define-syntax $ex-export 3572 (syntax-rules () 3573 [(_ frob ...) (begin ($ex-export1 frob) ...)])) 3574 #t) 3575 (begin 3576 (module $ex-mm () 3577 ($ex-export) 3578 (define x 3) 3579 (module m1 () 3580 ($ex-export x y) 3581 (define x 4) 3582 (define-syntax y (identifier-syntax x)) 3583 (indirect-export y x)) 3584 ($ex-export (m1 y) x)) 3585 #t) 3586 (equal? 3587 (let () 3588 (import $ex-mm) 3589 (list x y)) 3590 '(3 4)) 3591 (equal? 3592 (let () 3593 (module m () 3594 ($ex-export) 3595 (define x 3) 3596 (module m1 () 3597 ($ex-export x y) 3598 (define x 4) 3599 (define-syntax y (identifier-syntax x)) 3600 (indirect-export y x)) 3601 ($ex-export (m1 y) x)) 3602 (let () 3603 (import m) 3604 (list x y))) 3605 '(3 4)) 3606 (begin 3607 (with-output-to-file "testfile-ex1a.ss" 3608 (lambda () 3609 (pretty-print 3610 '(library (testfile-ex1a) 3611 (export q) 3612 (import (chezscheme)) 3613 (define-syntax q (identifier-syntax 17))))) 3614 'replace) 3615 (with-output-to-file "testfile-ex1b.ss" 3616 (lambda () 3617 (pretty-print 3618 '(library (testfile-ex1b) 3619 (export) 3620 (import (chezscheme)) 3621 (define x 22) 3622 (export x (import (testfile-ex1a)))))) 3623 'replace) 3624 (for-each separate-compile '(ex1a ex1b)) 3625 #t) 3626 (equal? 3627 (let () (import (testfile-ex1b)) (list x q)) 3628 '(22 17)) 3629 (begin 3630 (with-output-to-file "testfile-ex2a.ss" 3631 (lambda () 3632 (pretty-print 3633 '(library (testfile-ex2a) 3634 (export q) 3635 (import (chezscheme)) 3636 (define-syntax q (identifier-syntax 17))))) 3637 'replace) 3638 (with-output-to-file "testfile-ex2b.ss" 3639 (lambda () 3640 (pretty-print 3641 '(library (testfile-ex2b) 3642 (export) 3643 (import (chezscheme)) 3644 (define x 22) 3645 (export (rename (x q)) (import (prefix (rename (testfile-ex2a) (q que)) pi)))))) 3646 'replace) 3647 (for-each separate-compile '(ex2a ex2b)) 3648 #t) 3649 (equal? 3650 (let () (import (testfile-ex2b)) (list q pique)) 3651 '(22 17)) 3652 (begin 3653 (with-output-to-file "testfile-ex3a.ss" 3654 (lambda () 3655 (pretty-print 3656 '(library (testfile-ex3a) 3657 (export q) 3658 (import (chezscheme)) 3659 (implicit-exports #f) 3660 (indirect-export a x) 3661 (define x 17) 3662 (define-syntax a (identifier-syntax (* x 2))) 3663 (indirect-export q a) 3664 (define-syntax q (identifier-syntax (+ a 1)))))) 3665 'replace) 3666 (with-output-to-file "testfile-ex3b.ss" 3667 (lambda () 3668 (pretty-print 3669 '(library (testfile-ex3b) 3670 (export) 3671 (import (chezscheme)) 3672 (define x 22) 3673 (export (rename (x q)) (import (prefix (rename (testfile-ex3a) (q que)) pi)))))) 3674 'replace) 3675 (for-each separate-compile '(ex3a ex3b)) 3676 #t) 3677 (equal? 3678 (let () (import (testfile-ex3b)) (list q pique)) 3679 '(22 35)) 3680 (begin 3681 (with-output-to-file "testfile-ex4a.ss" 3682 (lambda () 3683 (pretty-print 3684 '(library (testfile-ex4a) 3685 (export q) 3686 (import (chezscheme)) 3687 (implicit-exports #f) 3688 (define x 17) 3689 (define-syntax a (identifier-syntax (* x 2))) 3690 (define-syntax q (identifier-syntax (+ a 1)))))) 3691 'replace) 3692 (with-output-to-file "testfile-ex4b.ss" 3693 (lambda () 3694 (pretty-print 3695 '(library (testfile-ex4b) 3696 (export) 3697 (import (chezscheme)) 3698 (define x 22) 3699 (export (rename (x q)) (import (prefix (rename (testfile-ex4a) (q que)) pi)))))) 3700 'replace) 3701 (for-each separate-compile '(ex4a ex4b)) 3702 #t) 3703 (error? ; attempt to reference unexported identifier a 3704 (let () (import (testfile-ex4b)) (list q pique))) 3705) 3706 3707(define eval-test 3708 (lambda (expr) 3709 (eval expr) 3710 #t)) 3711(define load-test 3712 (lambda (expr) 3713 (with-output-to-file "testfile.ss" 3714 (lambda () (pretty-print expr)) 3715 'replace) 3716 (load "testfile.ss") 3717 #t)) 3718(define compile-test 3719 (lambda (expr) 3720 (with-output-to-file "testfile.ss" 3721 (lambda () (pretty-print expr)) 3722 'replace) 3723 (compile-file "testfile.ss") 3724 (load "testfile.so") 3725 #t)) 3726 3727(define-syntax errmat 3728 (lambda (x) 3729 (syntax-case x () 3730 [(_ name expr ...) 3731 (let ([make-name (lambda (x) (datum->syntax #'name (string->symbol (format "~s-~s" x (datum name)))))]) 3732 #`(begin 3733 (mat #,(make-name 'eval) (error? (eval-test 'expr)) ...) 3734 (mat #,(make-name 'load) (error? (load-test 'expr)) ...) 3735 (mat #,(make-name 'compile) (error? (compile-test 'expr)) ...)))]))) 3736 3737(errmat export-errors 3738 ; attempt to export multiple bindings for x 3739 (module A () 3740 (define x 5) 3741 (define y 6) 3742 (export (rename (y x)) x)) 3743 ; attempt to export multiple bindings for x 3744 (module () 3745 (module A () 3746 (define x 5) 3747 (define y 6) 3748 (export (rename (y x)) x))) 3749 ; attempt to export multiple bindings for x 3750 (let () 3751 (module A () 3752 (define x 5) 3753 (define y 6) 3754 (export (rename (y x)) x)) 3755 0) 3756 ; attempt to export multiple bindings for x 3757 (library (A) (export) (import (chezscheme)) 3758 (define x 5) 3759 (define y 6) 3760 (export (rename (y x)) x)) 3761 ; attempt to export multiple bindings for x 3762 (module A () 3763 (define x 5) 3764 (define y 6) 3765 (export x (rename (y x)))) 3766 ; attempt to export multiple bindings for x 3767 (module () 3768 (module A () 3769 (define x 5) 3770 (define y 6) 3771 (export x (rename (y x))))) 3772 ; attempt to export multiple bindings for x 3773 (let () 3774 (module A () 3775 (define x 5) 3776 (define y 6) 3777 (export x (rename (y x)))) 3778 0) 3779 ; attempt to export multiple bindings for x 3780 (library (A) (export) (import (chezscheme)) 3781 (define x 5) 3782 (define y 6) 3783 (export x (rename (y x)))) 3784 ; attempt to export multiple bindings for x 3785 (module A () 3786 (define x 5) 3787 (module B (x) (define x 6)) 3788 (export x (import B))) 3789 ; attempt to export multiple bindings for x 3790 (module () 3791 (module A () 3792 (define x 5) 3793 (module B (x) (define x 6)) 3794 (export x (import B)))) 3795 ; attempt to export multiple bindings for x 3796 (let () 3797 (module A () 3798 (define x 5) 3799 (module B (x) (define x 6)) 3800 (export x (import B))) 3801 0) 3802 ; attempt to export multiple bindings for x 3803 (library (A) (export) (import (chezscheme)) 3804 (define x 5) 3805 (module B (x) (define x 6)) 3806 (export x (import B))) 3807 ; attempt to export multiple bindings for x 3808 (module A () 3809 (define x 5) 3810 (module B (x) (define x 6)) 3811 (export (import B) x)) 3812 ; attempt to export multiple bindings for x 3813 (module () 3814 (module A () 3815 (define x 5) 3816 (module B (x) (define x 6)) 3817 (export (import B) x))) 3818 ; attempt to export multiple bindings for x 3819 (let () 3820 (module A () 3821 (define x 5) 3822 (module B (x) (define x 6)) 3823 (export (import B) x)) 3824 0) 3825 ; attempt to export multiple bindings for x 3826 (library (A) (export) (import (chezscheme)) 3827 (define x 5) 3828 (module B (x) (define x 6)) 3829 (export (import B) x)) 3830 ; attempt to export multiple bindings for x 3831 (module A () 3832 (module B (x) (define x 6)) 3833 (module C (x) (define x 7)) 3834 (export (import C) (import B))) 3835 ; attempt to export multiple bindings for x 3836 (module () 3837 (module A () 3838 (module B (x) (define x 6)) 3839 (module C (x) (define x 7)) 3840 (export (import C) (import B)))) 3841 ; attempt to export multiple bindings for x 3842 (let () 3843 (module A () 3844 (module B (x) (define x 6)) 3845 (module C (x) (define x 7)) 3846 (export (import C) (import B))) 3847 0) 3848 ; attempt to export multiple bindings for x 3849 (library (A) (export) (import (chezscheme)) 3850 (module B (x) (define x 6)) 3851 (module C (x) (define x 7)) 3852 (export (import C) (import B))) 3853 ; missing import y 3854 (module A () 3855 (module B (x) (define x 6)) 3856 (export (import (only B y)))) 3857 ; missing import y 3858 (module () 3859 (module A () 3860 (module B (x) (define x 6)) 3861 (export (import (only B y))))) 3862 ; missing import y 3863 (let () 3864 (module A () 3865 (module B (x) (define x 6)) 3866 (export (import (only B y)))) 3867 0) 3868 ; missing import y 3869 (library (A) (export) (import (chezscheme)) 3870 (module B (x) (define x 6)) 3871 (export (import (only B y)))) 3872 ; missing import y 3873 (module A () 3874 (module B (x) (define x 6)) 3875 (export (import (rename B (y z))))) 3876 ; missing import y 3877 (module () 3878 (module A () 3879 (module B (x) (define x 6)) 3880 (export (import (rename B (y z)))))) 3881 ; missing import y 3882 (let () 3883 (module A () 3884 (module B (x) (define x 6)) 3885 (export (import (rename B (y z))))) 3886 0) 3887 ; missing import y 3888 (library (A) (export) (import (chezscheme)) 3889 (module B (x) (define x 6)) 3890 (export (import (rename B (y z))))) 3891 ; library (rename B y z) not found 3892 (module A () 3893 (module B (x) (define x 6)) 3894 (export (import (rename B y z)))) 3895 ; library (rename B y z) not found 3896 (module () 3897 (module A () 3898 (module B (x) (define x 6)) 3899 (export (import (rename B y z))))) 3900 ; library (rename B y z) not found 3901 (let () 3902 (module A () 3903 (module B (x) (define x 6)) 3904 (export (import (rename B y z)))) 3905 0) 3906 ; library (rename B y z) not found 3907 (library (A) (export) (import (chezscheme)) 3908 (module B (x) (define x 6)) 3909 (export (import (rename B y z)))) 3910 ; missing expected prefix foo: x 3911 (module A () 3912 (module B (x) (define foo:y 5) (define x 6)) 3913 (export (import (drop-prefix B foo:)))) 3914 ; missing expected prefix foo: x 3915 (module () 3916 (module A () 3917 (module B (x) (define foo:y 5) (define x 6)) 3918 (export (import (drop-prefix B foo:))))) 3919 ; missing expected prefix foo: x 3920 (let () 3921 (module A () 3922 (module B (x) (define foo:y 5) (define x 6)) 3923 (export (import (drop-prefix B foo:)))) 3924 0) 3925 ; missing expected prefix foo: x 3926 (library (A) (export) (import (chezscheme)) 3927 (module B (x) (define foo:y 5) (define x 6)) 3928 (export (import (drop-prefix B foo:)))) 3929) 3930 3931(mat indirect-export ; test stand-alone indirect-export form 3932 (error? ; invalid indirect-export syntax 3933 (module $ie-f (($ie-a x)) 3934 (import (chezscheme)) 3935 (define x '$ie-x) 3936 (indirect-export ($ie-a y z)) 3937 (define y '$ie-y) 3938 (define-syntax $ie-a (identifier-syntax (list x y z))) 3939 (define z '$ie-z))) 3940 (error? ; export z undefined 3941 (module $ie-f (($ie-a x)) 3942 (import (chezscheme)) 3943 (define x '$ie-x) 3944 (indirect-export $ie-a y z) 3945 (define y '$ie-y) 3946 (define-syntax $ie-a (identifier-syntax (list x y z))))) 3947 (begin 3948 (module $ie-f ($ie-a) 3949 (import (chezscheme)) 3950 (define-syntax $ie-a (identifier-syntax (list z))) 3951 (define z '$ie-z)) 3952 #t) 3953 (error? ; attempt to reference unexported identifier z 3954 (let () (import $ie-f) $ie-a)) 3955 (begin 3956 (module $ie-f (($ie-a z)) 3957 (import (chezscheme)) 3958 (define-syntax $ie-a (identifier-syntax (list z))) 3959 (define z '$ie-z)) 3960 #t) 3961 (equal? 3962 (let () (import $ie-f) $ie-a) 3963 '($ie-z)) 3964 (begin 3965 (module $ie-f ($ie-a) 3966 (import (chezscheme)) 3967 (indirect-export $ie-a z) 3968 (define-syntax $ie-a (identifier-syntax (list z))) 3969 (define z '$ie-z)) 3970 #t) 3971 (equal? 3972 (let () (import $ie-f) $ie-a) 3973 '($ie-z)) 3974 (begin 3975 (module $ie-f () 3976 (import (chezscheme)) 3977 (export $ie-a) 3978 (indirect-export $ie-a z) 3979 (define-syntax $ie-a (identifier-syntax (list z))) 3980 (define z '$ie-z)) 3981 #t) 3982 (equal? 3983 (let () (import $ie-f) $ie-a) 3984 '($ie-z)) 3985 (begin 3986 (module $ie-f () 3987 (import (chezscheme)) 3988 (indirect-export $ie-a z) 3989 (export $ie-a) 3990 (define-syntax $ie-a (identifier-syntax (list z))) 3991 (define z '$ie-z)) 3992 #t) 3993 (equal? 3994 (let () (import $ie-f) $ie-a) 3995 '($ie-z)) 3996 (begin 3997 (module $ie-f (($ie-a x)) 3998 (import (chezscheme)) 3999 (define x '$ie-x) 4000 (indirect-export $ie-a z) 4001 (define y '$ie-y) 4002 (define-syntax $ie-a (identifier-syntax (list x y z))) 4003 (define z '$ie-z) 4004 (indirect-export $ie-a y)) 4005 #t) 4006 (equal? 4007 (let () (import $ie-f) $ie-a) 4008 '($ie-x $ie-y $ie-z)) 4009 (begin 4010 (module $ie-g () 4011 (define x 3) 4012 (define y 4) 4013 (define-syntax a (identifier-syntax (list x y))) 4014 (alias b a) 4015 (export a b) 4016 (indirect-export a x) 4017 (indirect-export b y)) 4018 #t) 4019 (equal? 4020 (let () (import $ie-g) a) 4021 '(3 4)) 4022 (begin 4023 (module $ie-h ((cons x)) 4024 (define-property cons car #'x) 4025 (define x 3)) 4026 #t) 4027 (eqv? 4028 (let () 4029 (define-syntax ref-prop 4030 (lambda (x) 4031 (lambda (r) 4032 (syntax-case x () 4033 [(_ id key) (r #'id #'key)])))) 4034 (import $ie-h) 4035 (ref-prop cons car)) 4036 3) 4037 (begin 4038 (module $ie-h (cons) 4039 (define-property cons car #'x) 4040 (define x 3)) 4041 #t) 4042 (error? ; unexported identifier x 4043 (let () 4044 (define-syntax ref-prop 4045 (lambda (x) 4046 (lambda (r) 4047 (syntax-case x () 4048 [(_ id key) (r #'id #'key)])))) 4049 (import $ie-h) 4050 (ref-prop cons car))) 4051 (begin 4052 (module $ie-h (cons) 4053 (implicit-exports #t) 4054 (define-property cons car #'x) 4055 (define x 3)) 4056 #t) 4057 (eqv? 4058 (let () 4059 (define-syntax ref-prop 4060 (lambda (x) 4061 (lambda (r) 4062 (syntax-case x () 4063 [(_ id key) (r #'id #'key)])))) 4064 (import $ie-h) 4065 (ref-prop cons car)) 4066 3) 4067 (error? ; undefine export x 4068 (library ($ie-i) 4069 (export a) 4070 (import (chezscheme)) 4071 (define-syntax a (identifier-syntax x)) 4072 (indirect-export a x))) 4073) 4074 4075(mat implicit-exports ; test stand-alone implicit-exports form 4076 (error? ; invalid syntax 4077 (implicit-exports)) 4078 (error? ; invalid syntax 4079 (+ (implicit-exports) 3)) 4080 (error? ; invalid syntax 4081 (+ (implicit-exports yes!) 3)) 4082 (error? ; invalid syntax 4083 (+ (implicit-exports no way!) 3)) 4084 (error? ; outside of module or library 4085 (implicit-exports #t)) 4086 (error? ; invalid context for definition 4087 (+ (implicit-exports #f) 3)) 4088 (begin 4089 (module $ie-A (a) (import (chezscheme)) 4090 (define-syntax a (identifier-syntax x)) 4091 (define x 3)) 4092 #t) 4093 (error? ; unexported identifier x 4094 (let () (import $ie-A) a)) 4095 (begin 4096 (module $ie-A (a) (import (chezscheme)) 4097 (implicit-exports #t) 4098 (define-syntax a (identifier-syntax x)) 4099 (define x 3)) 4100 #t) 4101 (eqv? 4102 (let () (import $ie-A) a) 4103 3) 4104 (begin 4105 (module $ie-A (a) (import (chezscheme)) 4106 (implicit-exports #f) 4107 (define-syntax a (identifier-syntax x)) 4108 (define x 3)) 4109 #t) 4110 (error? ; unexported identifier x 4111 (let () (import $ie-A) a)) 4112 (begin 4113 (library ($ie-A) (export a) (import (chezscheme)) 4114 (define-syntax a (identifier-syntax x)) 4115 (define x 3)) 4116 #t) 4117 (eqv? 4118 (let () (import ($ie-A)) a) 4119 3) 4120 (begin 4121 (library ($ie-A) (export a) (import (chezscheme)) 4122 (implicit-exports #f) 4123 (define-syntax a (identifier-syntax x)) 4124 (define x 3)) 4125 #t) 4126 (error? ; unexported identifier x 4127 (let () (import ($ie-A)) a)) 4128 (begin 4129 (library ($ie-A) (export a) (import (chezscheme)) 4130 (implicit-exports #t) 4131 (define-syntax a (identifier-syntax x)) 4132 (define x 3)) 4133 #t) 4134 (eqv? 4135 (let () (import ($ie-A)) a) 4136 3) 4137 (begin 4138 (module $ie-A (a) (import (chezscheme)) 4139 (module (a) 4140 (define-syntax a (identifier-syntax x)) 4141 (define x 3))) 4142 #t) 4143 (error? ; unexported identifier x 4144 (let () (import $ie-A) a)) 4145 (begin 4146 (module $ie-A (a) (import (chezscheme)) 4147 (module ((a x)) 4148 (define-syntax a (identifier-syntax x)) 4149 (define x 3))) 4150 #t) 4151 (eqv? 4152 (let () (import $ie-A) a) 4153 3) 4154 (begin 4155 (module $ie-A (a) (import (chezscheme)) 4156 (module (a) 4157 (implicit-exports #f) 4158 (define-syntax a (identifier-syntax x)) 4159 (define x 3))) 4160 #t) 4161 (error? ; unexported identifier x 4162 (let () (import $ie-A) a)) 4163 (begin 4164 (module $ie-A (a) (import (chezscheme)) 4165 (module (a) 4166 (implicit-exports #t) 4167 (define-syntax a (identifier-syntax x)) 4168 (define x 3))) 4169 #t) 4170 (eqv? 4171 (let () (import $ie-A) a) 4172 3) 4173 (begin 4174 (module $ie-B (a) (import (chezscheme)) 4175 (define-syntax a (identifier-syntax x)) 4176 (module (x) (module (x (a x)) (define a 4) (define x 3)))) 4177 #t) 4178 (error? ; unexported identifier x 4179 (let () (import $ie-B) a)) 4180 (begin 4181 (module $ie-B (a) (import (chezscheme)) 4182 (define-syntax a (identifier-syntax x)) 4183 (indirect-export a x) 4184 (module (x) (module (x (a x)) (define a 4) (define x 3)))) 4185 #t) 4186 (eqv? 4187 (let () (import $ie-B) a) 4188 3) 4189 (begin 4190 (module $ie-C (a) (import (chezscheme)) 4191 (module ((b x)) 4192 (define-syntax b (identifier-syntax x)) 4193 (define x 3)) 4194 (alias a b)) 4195 #t) 4196 (eqv? 4197 (let () (import $ie-C) a) 4198 3) 4199 (begin 4200 (module $ie-C (a) (import (chezscheme)) 4201 (module (b) 4202 (define-syntax b (identifier-syntax x)) 4203 (define x 3)) 4204 (alias a b)) 4205 #t) 4206 (error? ; unexported identifier x 4207 (let () (import $ie-C) a)) 4208 (begin 4209 (module $ie-C (a) (import (chezscheme)) 4210 (module (b) 4211 (indirect-export b x) 4212 (define-syntax b (identifier-syntax x)) 4213 (define x 3)) 4214 (alias a b)) 4215 #t) 4216 (eqv? 4217 (let () (import $ie-C) a) 4218 3) 4219 (begin 4220 (module $ie-D (a) 4221 (module (a (b x)) 4222 (define-syntax b (identifier-syntax (list x))) 4223 (module (a x) 4224 (module (b x) 4225 (define-syntax b (identifier-syntax x)) 4226 (define x 3)) 4227 (alias a b)))) 4228 #t) 4229 (error? ; unexported identifier x 4230 (let () (import $ie-D) a)) 4231 (begin 4232 (module $ie-E (a) 4233 (import (chezscheme)) 4234 (define-syntax a (identifier-syntax x)) 4235 (alias b a) 4236 (indirect-export b x) 4237 (define x 77)) 4238 #t) 4239 ; this works because the indirect export of x for b 4240 ; counts as an indrect export of x for a. perhaps it 4241 ; shouldn't work. 4242 (eqv? 4243 (let () (import $ie-E) a) 4244 77) 4245 ; perhaps this shouldn't work either: 4246 (eqv? 4247 (let () 4248 (define b 3) 4249 (alias a b) 4250 (fluid-let-syntax ([b (identifier-syntax 4)]) 4251 a)) 4252 4) 4253 (begin 4254 (module $ie-F (a) 4255 (import (chezscheme)) 4256 (module (a) 4257 (implicit-exports #f) 4258 (define-syntax a (identifier-syntax x))) 4259 (implicit-exports #t) 4260 (define x 77)) 4261 #t) 4262 (eqv? 4263 (let () (import $ie-F) a) 4264 77) 4265 (begin 4266 (module $ie-G (a) 4267 (implicit-exports #t) 4268 (module M1 (x) 4269 (define x 5)) 4270 (module M2 ((a x)) 4271 (implicit-exports #t) 4272 (import M1) 4273 (define-syntax a (identifier-syntax x))) 4274 (import M2)) 4275 #t) 4276 (eqv? 4277 (let () (import $ie-G) a) 4278 5) 4279 (begin 4280 (module $ie-H (a) 4281 (implicit-exports #t) 4282 (module M1 (x) 4283 (define x 5)) 4284 (module M2 (a) 4285 (implicit-exports #t) 4286 (define-syntax a (let () (import M1) (identifier-syntax x)))) 4287 (import M2)) 4288 #t) 4289 (eqv? 4290 (let () (import $ie-H) a) 4291 5) 4292 (begin 4293 (module $ie-I (a) 4294 (define x 5) 4295 (indirect-export a x) 4296 (module M2 (a) 4297 (define-syntax a (identifier-syntax x))) 4298 (import M2)) 4299 #t) 4300 (eqv? 4301 (let () (import $ie-I) a) 4302 5) 4303 (begin 4304 (module $ie-J (m) 4305 (implicit-exports #t) 4306 (module m (e) 4307 (define f 44) 4308 (define-syntax e (identifier-syntax f)))) 4309 #t) 4310 (error? ; unexported identifier f 4311 (let () 4312 (import $ie-J) 4313 (import m) 4314 e)) 4315) 4316 4317(mat marked-top-level-ids 4318 (begin 4319 (define-syntax $a 4320 (syntax-rules () 4321 ((_ x e) 4322 (begin 4323 (module ($y-marked) (define $y-marked e)) 4324 (define x (lambda () $y-marked)))))) 4325 ($a $one 1) 4326 ($a $two 2) 4327 (equal? (list ($one) ($two)) '(1 2))) 4328 (not (top-level-bound? '$y-marked)) 4329 (begin 4330 (define-syntax $a 4331 (syntax-rules () 4332 ((_ x e) 4333 (begin 4334 (define $y-marked e) 4335 (define x (lambda () $y-marked)))))) 4336 ($a $one 1) 4337 ($a $two 2) 4338 ($a $three 3) 4339 (equal? (list ($one) ($two) ($three)) '(1 2 3))) 4340 (not (top-level-bound? '$y-marked)) 4341 (not (top-level-bound? '$y-marked)) 4342 (begin 4343 (define-syntax $a 4344 (syntax-rules () 4345 ((_ x e) 4346 (begin 4347 (define $y-marked e) 4348 (define-syntax x (identifier-syntax $y-marked)))))) 4349 ($a $one 1) 4350 ($a $two 2) 4351 ($a $three 3) 4352 ($a $four 4) 4353 (equal? (list $one $two $three $four) '(1 2 3 4))) 4354 (begin ; once more, with feeling 4355 (define-syntax $a 4356 (syntax-rules () 4357 ((_ x e) 4358 (begin 4359 (define $y-marked e) 4360 (define-syntax x (identifier-syntax $y-marked)))))) 4361 ($a $one 1) 4362 ($a $two 2) 4363 ($a $three 3) 4364 ($a $four 4) 4365 (equal? (list $one $two $three $four) '(1 2 3 4))) 4366 (begin 4367 (module $foo ($a) (define-syntax $a (identifier-syntax 3))) 4368 (import $foo) 4369 (eq? $a 3)) 4370 (begin ; keep with preceding mat 4371 (define-syntax $a (identifier-syntax 4)) 4372 (eq? $a 4)) 4373 ) 4374 4375(mat top-level-begin 4376 ; mats to test change to body-like semantics for begin 4377 (begin 4378 (define ($foofrah expr ans) 4379 (with-output-to-file "testfile.ss" 4380 (lambda () (pretty-print expr)) 4381 'replace) 4382 (let* ([ss.out (with-output-to-string (lambda () (load "testfile.ss")))] 4383 [cf.out (with-output-to-string (lambda () (compile-file "testfile.ss")))] 4384 [so.out (with-output-to-string (lambda () (load "testfile.so")))]) 4385 (let ([actual 4386 (list 4387 ss.out 4388 (substring cf.out 4389 (string-length "compiling testfile.ss with output to testfile.so\n") 4390 (string-length cf.out)) 4391 so.out)]) 4392 (unless (equal? actual ans) 4393 (pretty-print actual) 4394 (errorf #f "unexpected actual value ~s instead of ~s" actual ans)))) 4395 #t) 4396 #t) 4397 ($foofrah 4398 '(begin 4399 (define-record-type (a make-a a?) (fields type mapper)) 4400 (define-syntax define-descendant 4401 (lambda (x) 4402 (syntax-case x () 4403 [(_ parent-id maker type name pred arg ...) 4404 (with-syntax ([(getter ...) (generate-temporaries #'(arg ...))]) 4405 #'(define-record-type (name maker pred) 4406 (parent parent-id) 4407 (fields (immutable arg getter) ...) 4408 (protocol 4409 (lambda (n) 4410 (lambda (arg ...) 4411 (letrec ([rec ((n 'type (lambda (receiver) (receiver (getter rec) ...))) arg ...)]) 4412 rec))))))]))) 4413 (define-descendant a make-a subname x x? y z) 4414 (write ((a-mapper (make-a 3 4)) list))) 4415 '("(3 4)" "" "(3 4)")) 4416 ($foofrah 4417 '(begin 4418 (eval-when (compile load eval) (write 1)) 4419 (eval-when (compile load eval) (write 2) (write 3)) 4420 (newline)) 4421 '("123\n" "123" "123\n")) 4422 ($foofrah 4423 '(begin 4424 (define (f) (import foo) x1) 4425 (module foo (x1) (define x1 'x1)) 4426 (pretty-print (f))) 4427 '("x1\n" "" "x1\n")) 4428 ($foofrah 4429 '(begin 4430 (define x2 'x2) 4431 (module (y2) (define y2 x2)) 4432 (pretty-print y2)) ;=> x2 4433 '("x2\n" "" "x2\n")) 4434 ($foofrah 4435 '(begin 4436 (define x3 'x3) 4437 (module foo (y2) (define y2 x3)) 4438 (import foo) 4439 (pretty-print y2)) ;=> x3 4440 '("x3\n" "" "x3\n")) 4441 ($foofrah 4442 '(eval-when (compile load) 4443 (eval-when (compile load eval) (define x4 "x4")) 4444 (define-syntax a4 (lambda (q) x4)) 4445 (display a4)) 4446 '("" "x4" "x4")) 4447 ($foofrah 4448 '(eval-when (compile load eval) 4449 (define x5 "x5") 4450 (display x5)) 4451 '("x5" "x5" "x5")) 4452 (begin 4453 (define x5 "x5") 4454 ($foofrah ; keep with preceding test 4455 '(begin 4456 (define x5 "x5new") 4457 (define-syntax a5 (lambda (q) x5)) 4458 (printf "~a ~a\n" a5 x5)) 4459 '("x5 x5new\n" "" "x5new x5new\n"))) 4460 ($foofrah 4461 '(begin 4462 (define x6 a6) 4463 (define-syntax a6 (identifier-syntax 'cool)) 4464 (pretty-print x6)) 4465 '("cool\n" "" "cool\n")) 4466 (error? ; variable a7 is not bound 4467 (eval '(begin 4468 (define x7 a7) 4469 (define-syntax a7 (identifier-syntax 'cool)) 4470 (define a7 'the-real-deal)))) 4471 ($foofrah 4472 '(begin 4473 (define x8 'not-cool) 4474 (define (f8) x8) 4475 (define x8 'just-right) 4476 (pretty-print (f8))) ;=> just-right 4477 '("just-right\n" "" "just-right\n")) 4478 ($foofrah 4479 '(begin 4480 (define x9 'not-cool) 4481 (define-syntax a9 (identifier-syntax x9)) 4482 (define x9 'just-right) 4483 (pretty-print a9)) ;=> just-right 4484 '("just-right\n" "" "just-right\n")) 4485 ($foofrah 4486 '(begin 4487 (define x10 a10) 4488 (module m10 (x y) 4489 (define-syntax x (identifier-syntax 'm10-x)) 4490 (define y a10) 4491 (define-syntax a10 (identifier-syntax 'm10-y))) 4492 (library (l10) (export x y) (import (rnrs)) 4493 (define-syntax x (identifier-syntax 'l10-x)) 4494 (define y a10) 4495 (define-syntax a10 (identifier-syntax 'l10-y))) 4496 (define-syntax a10 (identifier-syntax 'outer-x10)) 4497 (import (rename m10 (y yy)) (rename (l10) (x xx))) 4498 (pretty-print (list x y xx yy))) 4499 '("(m10-x l10-y l10-x m10-y)\n" "" "(m10-x l10-y l10-x m10-y)\n")) 4500 ($foofrah 4501 '(begin 4502 (define-syntax a 4503 (syntax-rules () 4504 [(a q) (begin (define (q) x) (define x 4))])) 4505 (a zz) 4506 (pretty-print (zz))) 4507 '("4\n" "" "4\n")) 4508 ($foofrah 4509 '(begin 4510 (eval-when (compile load eval) 4511 (module const (get put) 4512 (define ht (make-eq-hashtable)) 4513 (define get (lambda (name) (hashtable-ref ht name 0))) 4514 (define put (lambda (name value) (hashtable-set! ht name value))))) 4515 (define-syntax dc 4516 (syntax-rules () 4517 [(_ id e) (let () (import const) (put 'id e))])) 4518 (define-syntax con 4519 (syntax-rules () 4520 [(_ id) (let () (import const) (get 'id))])) 4521 (dc spam 13) 4522 (dc b (list (con spam) 's)) 4523 (pretty-print (list (con spam) (con b) (con c)))) 4524 '("(13 (13 s) 0)\n" "" "(13 (13 s) 0)\n")) 4525 (begin (define const) (define dc) (define con) #t) 4526 ($foofrah 4527 '(begin 4528 (eval-when (compile load eval) 4529 (module const (get put) 4530 (define ht (make-eq-hashtable)) 4531 (define get (lambda (name) (hashtable-ref ht name 0))) 4532 (define put (lambda (name value) (hashtable-set! ht name value))))) 4533 (define-syntax dc 4534 (syntax-rules () 4535 [(_ id e) (let () (import const) (put 'id e))])) 4536 (define-syntax con 4537 (syntax-rules () 4538 [(_ id) (let () (import const) (get 'id))])) 4539 (eval-when (compile load eval) 4540 (dc spam 13) 4541 (dc b (list (con spam) 's))) 4542 (eval-when (compile load eval) 4543 (pretty-print (list (con spam) (con b) (con c))))) 4544 '("(13 (13 s) 0)\n" "(13 (13 s) 0)\n" "(13 (13 s) 0)\n")) 4545 (begin (define const) (define dc) (define con) #t) 4546 ($foofrah 4547 '(begin 4548 (eval-when (compile load eval) 4549 (module const (get put) 4550 (define ht (make-eq-hashtable)) 4551 (define get (lambda (name) (hashtable-ref ht name 0))) 4552 (define put (lambda (name value) (hashtable-set! ht name value))))) 4553 (define-syntax dc 4554 (syntax-rules () 4555 [(_ id e) (eval-when (compile load eval) (let () (import const) (put 'id e)))])) 4556 (define-syntax con 4557 (syntax-rules () 4558 [(_ id) (eval-when (compile load eval) (let () (import const) (get 'id)))])) 4559 (dc spam 13) 4560 (dc b (list (con spam) 's)) 4561 (eval-when (compile load eval) 4562 (pretty-print (list (con spam) (con b) (con c))))) 4563 '("(13 (13 s) 0)\n" "(13 (13 s) 0)\n" "(13 (13 s) 0)\n")) 4564 (begin (define const) (define dc) (define con) #t) 4565 ($foofrah 4566 '(begin 4567 (eval-when (compile eval) 4568 (module const (get put) 4569 (define ht (make-eq-hashtable)) 4570 (define get (lambda (name) (hashtable-ref ht name 0))) 4571 (define put (lambda (name value) (hashtable-set! ht name value))))) 4572 (define-syntax dc 4573 (syntax-rules () 4574 [(_ id e) (eval-when (compile eval) (let () (import const) (put 'id e)))])) 4575 (define-syntax con 4576 (syntax-rules () 4577 [(_ id) (eval-when (compile eval) (let () (import const) (get 'id)))])) 4578 (dc spam 13) 4579 (dc b (list (con spam) 's)) 4580 (eval-when (compile eval) 4581 (pretty-print (list (con spam) (con b) (con c))))) 4582 '("(13 (13 s) 0)\n" "(13 (13 s) 0)\n" "")) 4583 (begin (define const) (define dc) (define con) #t) 4584 ($foofrah 4585 '(begin 4586 (define-syntax a 4587 (identifier-syntax 4588 (begin 4589 (eval-when (compile eval) 4590 (module const (get put) 4591 (define ht (make-eq-hashtable)) 4592 (define get (lambda (name) (hashtable-ref ht name 0))) 4593 (define put (lambda (name value) (hashtable-set! ht name value))))) 4594 (define-syntax dc 4595 (syntax-rules () 4596 [(_ id e) (eval-when (compile eval) (let () (import const) (put 'id e)))])) 4597 (define-syntax con 4598 (syntax-rules () 4599 [(_ id) (eval-when (compile eval) (let () (import const) (get 'id)))])) 4600 (dc spam 13) 4601 (dc b (list (con spam) 's)) 4602 (eval-when (compile eval) 4603 (pretty-print (list (con spam) (con b) (con c))))))) 4604 a) 4605 '("(13 (13 s) 0)\n" "(13 (13 s) 0)\n" "")) 4606 (begin (define const) (define dc) (define con) #t) 4607 (begin 4608 (with-output-to-file "testfile-lib-c.ss" 4609 (lambda () 4610 (pretty-print 4611 '(library (testfile-lib-c) 4612 (export y) 4613 (import (chezscheme) (testfile-lib-a)) 4614 (define y (lambda () x)) 4615 (printf "invoke c\n")))) 4616 'replace) 4617 (with-output-to-file "testfile-test-ac.ss" 4618 (lambda () 4619 (pretty-print 4620 '(begin 4621 (library (testfile-lib-a) 4622 (export x) 4623 (import (chezscheme)) 4624 (define x (lambda () 1)) 4625 (printf "invoke a\n")) 4626 (import (testfile-lib-c) (chezscheme)) 4627 (pretty-print (eq? (y) y))))) 4628 'replace) 4629 #t) 4630 (let ([cf '(lambda (x) 4631 (parameterize ([compile-imported-libraries #t]) 4632 (compile-file x)))]) 4633 (separate-compile cf 'test-ac) 4634 #t) 4635 (equal? 4636 (separate-eval '(load "testfile-test-ac.so")) 4637 "invoke a\ninvoke c\n#f\n") 4638 ; make sure no local-label bindings make it into compiled wraps 4639 (begin 4640 (with-output-to-file "testfile.ss" 4641 (lambda () 4642 (pretty-print 4643 '(let-syntax ([a (lambda (x) 0)]) 4644 (define-syntax $foo (lambda (x) #'cons))))) 4645 'replace) 4646 (compile-file "testfile") 4647 (load "testfile.so") 4648 #t) 4649 (equal? $foo cons) 4650 (begin 4651 (with-output-to-file "testfile.ss" 4652 (lambda () 4653 (pretty-print 4654 '(begin 4655 (define-syntax $foo-a (lambda (x) 0)) 4656 (define-syntax $foo (lambda (x) #'cons))))) 4657 'replace) 4658 (compile-file "testfile") 4659 (load "testfile.so") 4660 #t) 4661 (equal? $foo cons) 4662) 4663 4664#; 4665(mat top-level-begin-NOT 4666 ; these mats test a behavior we have at this point decided against, 4667 ; in which a syntax object for an identifier imported from a library 4668 ; via an import is inserted outside the scope of the local import 4669 ; in a compiled file, thus forcing an implicit import of the library 4670 ; when the compiled file is loaded. possibly, the library should be 4671 ; imported when a reference is actually attempted, but we shouldn't 4672 ; import eagerly on the off chance that a syntax object will be used 4673 ; in this manner, because the import will usually be unnecessary. 4674 (begin 4675 (with-output-to-file "testfile-tlb-a1.ss" 4676 (lambda () 4677 (pretty-print 4678 '(library (testfile-tlb-a1) 4679 (export tlb-a1-rats) 4680 (import (rnrs)) 4681 (define-syntax tlb-a1-rats (identifier-syntax 17))))) 4682 'replace) 4683 (with-output-to-file "testfile-tlb-a2.ss" 4684 (lambda () 4685 (pretty-print 4686 '(define-syntax tlb-a2-foo 4687 (let () 4688 (import (testfile-tlb-a1)) 4689 (lambda (x) #'(cons tlb-a1-rats 2)))))) 4690 'replace) 4691 (with-output-to-file "testfile-tlb-a3.ss" 4692 (lambda () 4693 (pretty-print 4694 '(let-syntax ([silly (lambda (x) 4695 (import (testfile-tlb-a1)) 4696 (syntax-case x () 4697 [(_ id) #'(define-syntax id (identifier-syntax (cons tlb-a1-rats 3)))]))]) 4698 (silly tlb-a3-fluffy)))) 4699 'replace) 4700 (with-output-to-file "testfile-tlb-a4.ss" 4701 (lambda () 4702 (pretty-print 4703 '(module (tlb-a4-pie) 4704 (import (testfile-tlb-a1)) 4705 (define-syntax tlb-a4-pie 4706 (lambda (x) #'(cons tlb-a1-rats 4)))))) 4707 'replace) 4708 (with-output-to-file "testfile-tlb-a5.ss" 4709 (lambda () 4710 (pretty-print 4711 '(meta define tlb-a5-spam 4712 (let () (import (testfile-tlb-a1)) #'(cons tlb-a1-rats 5))))) 4713 'replace) 4714 (with-output-to-file "testfile-tlb-a6a.ss" 4715 (lambda () 4716 (pretty-print 4717 '(library (testfile-tlb-a6a) 4718 (export tlb-a6-fop) 4719 (import (rnrs) (testfile-tlb-a1)) 4720 (define tlb-a6-fop #'(cons tlb-a1-rats 6))))) 4721 'replace) 4722 (with-output-to-file "testfile-tlb-a6b.ss" 4723 (lambda () 4724 (pretty-print 4725 '(library (testfile-tlb-a6b) 4726 (export tlb-a6-alpha) 4727 (import (rnrs) (testfile-tlb-a6a)) 4728 (define-syntax tlb-a6-alpha (lambda (x) tlb-a6-fop))))) 4729 'replace) 4730 (with-output-to-file "testfile-tlb-a6c.ss" 4731 (lambda () 4732 (pretty-print '(import (rnrs) (testfile-tlb-a6b))) 4733 (pretty-print '(write tlb-a6-alpha))) 4734 'replace) 4735 (with-output-to-file "testfile-tlb-a7.ss" 4736 (lambda () 4737 (pretty-print 4738 '(define-property spam spam (let () (import (testfile-tlb-a1)) #'(cons tlb-a1-rats 7))))) 4739 'replace) 4740 (with-output-to-file "testfile-tlb-a8.ss" 4741 (lambda () 4742 (pretty-print 4743 '(define tlb-a8-spam (let () (import (testfile-tlb-a1)) #'(cons tlb-a1-rats 8))))) 4744 'replace) 4745 (with-output-to-file "testfile-tlb-a9.ss" 4746 (lambda () 4747 (pretty-print 4748 '(let () 4749 (import (testfile-tlb-a1)) 4750 (set! tlb-a9-spam #'(cons tlb-a1-rats 9))))) 4751 'replace) 4752 (with-output-to-file "testfile-tlb-a10.ss" 4753 (lambda () 4754 (pretty-print '(import (scheme) (testfile-tlb-a1))) 4755 (pretty-print '(define-top-level-value 'tlb-a10-spam #'(cons tlb-a1-rats 10)))) 4756 'replace) 4757 (let ([cf (lambda (what) 4758 `(lambda (x) 4759 (parameterize ([compile-imported-libraries #t]) 4760 (,what x))))]) 4761 (separate-compile (cf 'compile-file) 'tlb-a2) 4762 (separate-compile (cf 'compile-file) 'tlb-a3) 4763 (separate-compile (cf 'compile-file) 'tlb-a4) 4764 (separate-compile (cf 'compile-file) 'tlb-a5) 4765 (separate-compile (cf 'compile-library) 'tlb-a6b) 4766 (separate-compile (cf 'compile-program) 'tlb-a6c) 4767 (separate-compile (cf 'compile-file) 'tlb-a7) 4768 (separate-compile (cf 'compile-file) 'tlb-a8) 4769 (separate-compile (cf 'compile-file) 'tlb-a9) 4770 (separate-compile (cf 'compile-program) 'tlb-a10)) 4771 #t) 4772 (equal? 4773 (separate-eval '(visit "testfile-tlb-a2.so") '(pretty-print tlb-a2-foo)) 4774 "(17 . 2)\n") 4775 (equal? 4776 (separate-eval '(visit "testfile-tlb-a3.so") '(pretty-print tlb-a3-fluffy)) 4777 "(17 . 3)\n") 4778 (equal? 4779 (separate-eval '(visit "testfile-tlb-a4.so") '(pretty-print tlb-a4-pie)) 4780 "(17 . 4)\n") 4781 (equal? 4782 (separate-eval '(visit "testfile-tlb-a5.so") '(pretty-print (let-syntax ([a (lambda (x) tlb-a5-spam)]) a))) 4783 "(17 . 5)\n") 4784 (equal? 4785 (separate-eval '(revisit "testfile-tlb-a6c.so")) 4786 "(17 . 6)") 4787 (equal? 4788 (separate-eval '(visit "testfile-tlb-a7.so") '(pretty-print (let-syntax ([a (lambda (x) (lambda (r) (r #'spam #'spam)))]) a))) 4789 "(17 . 7)\n") 4790 (equal? 4791 (separate-eval '(revisit "testfile-tlb-a8.so") '(pretty-print (let-syntax ([a (lambda (x) tlb-a8-spam)]) a))) 4792 "(17 . 8)\n") 4793 (equal? 4794 (separate-eval '(revisit "testfile-tlb-a9.so") '(pretty-print (let-syntax ([a (lambda (x) tlb-a9-spam)]) a))) 4795 "(17 . 9)\n") 4796 ; don't really want to fix this one: 4797 (equal? 4798 (separate-eval '(load-program "testfile-tlb-a10.so") '(pretty-print (let-syntax ([a (lambda (x) tlb-a10-spam)]) a))) 4799 "(17 . 10)\n") 4800 (begin 4801 (with-output-to-file "testfile-tlb-bQ.ss" 4802 (lambda () 4803 (pretty-print 4804 '(library (testfile-tlb-bQ) 4805 (export tlb-bq) 4806 (import (rnrs)) 4807 (define-syntax tlb-bq (identifier-syntax 17))))) 4808 'replace) 4809 (with-output-to-file "testfile-tlb-bA.ss" 4810 (lambda () 4811 (pretty-print 4812 '(library (testfile-tlb-bA) 4813 (export tlb-bset-a! tlb-bget-a) 4814 (import (rnrs)) 4815 (define a #f) 4816 (define tlb-bset-a! (lambda (x) (set! a x))) 4817 (define tlb-bget-a (lambda () a))))) 4818 'replace) 4819 (with-output-to-file "testfile-tlb-bP.ss" 4820 (lambda () 4821 (pretty-print '(import (rnrs) (rnrs eval) (testfile-tlb-bQ) (testfile-tlb-bA))) 4822 (pretty-print '(tlb-bset-a! #'tlb-bq)) 4823 (pretty-print 4824 '(eval 4825 '(let () 4826 (define-syntax alpha (lambda (x) (tlb-bget-a))) 4827 (write (cons alpha 'B))) 4828 (environment '(rnrs) '(testfile-tlb-bA) '(testfile-tlb-bQ))))) 4829 'replace) 4830 (let ([cf (lambda (what) 4831 `(lambda (x) 4832 (parameterize ([compile-imported-libraries #t]) 4833 (,what x))))]) 4834 (separate-compile (cf 'compile-program) 'tlb-bP)) 4835 #t) 4836 (equal? 4837 (separate-eval '(load-program "testfile-tlb-bP.so")) 4838 "(17 . B)") 4839) 4840 4841(mat deferred-transformer 4842 ; don't get caught being lazy on transformer evaluation 4843 (begin 4844 (define $ratfink 4845 (let ([state 0]) 4846 (lambda () (set! state (+ state 1)) (lambda (x) state)))) 4847 (procedure? $ratfink)) 4848 (eqv? (let-syntax ((f ($ratfink))) 4849 (let-syntax ((g ($ratfink))) g)) 4850 2) 4851 ) 4852 4853(mat copy-environment 4854 ; dummy test to set up nondescript record-writer for environments 4855 ; so that error messages involving environments don't include generated 4856 ; names that may change from run to run. the record-writer is reset at 4857 ; end of this mat. 4858 (equal? 4859 (let ([env-rtd (record-rtd (scheme-environment))]) 4860 (set! *saved-record-writer* (record-writer env-rtd)) 4861 (record-writer env-rtd (lambda (x p wr) (display "#<environment>" p))) 4862 (format "~s" (scheme-environment))) 4863 "#<environment>") 4864 (equal? 4865 (let ([e (copy-environment (scheme-environment))]) 4866 (eval '(define x 17) e) 4867 (eval '(define-syntax a 4868 (syntax-rules () 4869 [(_ b c) 4870 (begin 4871 (define x c) 4872 (define-syntax b (identifier-syntax x)))])) 4873 e) 4874 (eval '(a foo 33) e) 4875 (list (eval 'foo e) 4876 (eval 'x e) 4877 (top-level-value 'x e))) 4878 '(33 17 17)) 4879 (equal? 4880 (let ([e (copy-environment (scheme-environment) #t)]) 4881 (eval '(define x 17) e) 4882 (eval '(define-syntax a 4883 (syntax-rules () 4884 [(_ b c) 4885 (begin 4886 (define x c) 4887 (define-syntax b (identifier-syntax x)))])) 4888 e) 4889 (eval '(a foo 33) e) 4890 (list (eval 'foo e) 4891 (eval 'x e) 4892 (top-level-value 'x e))) 4893 '(33 17 17)) 4894 (error? 4895 (let ([e (copy-environment (scheme-environment) #f)]) 4896 (eval '(define x 17) e) 4897 (eval '(define-syntax a 4898 (syntax-rules () 4899 [(_ b c) 4900 (begin 4901 (define x c) 4902 (define-syntax b (identifier-syntax x)))])) 4903 e) 4904 (eval '(a foo 33) e) 4905 (list (eval 'foo e) 4906 (eval 'x e) 4907 (top-level-value 'x e)))) 4908 (equal? 4909 (let* ([e1 (copy-environment (scheme-environment))] 4910 [e2 (copy-environment e1)]) 4911 (define-top-level-value 'list list* e1) 4912 (list 4913 (parameterize ([optimize-level 0]) (eval '(list 1 2 3) e1)) 4914 (parameterize ([optimize-level 0]) (eval '(list 1 2 3) e2)))) 4915 '((1 2 . 3) (1 2 3))) 4916 (equal? 4917 (let* ([e1 (copy-environment (scheme-environment))] 4918 [e2 (copy-environment e1)]) 4919 (define-top-level-value 'list list* e1) 4920 (list 4921 (parameterize ([optimize-level 0]) (eval '(list 1 2 3) e1)) 4922 (parameterize ([optimize-level 0]) (eval '(list 1 2 3) e2)))) 4923 '((1 2 . 3) (1 2 3))) 4924 (error? 4925 (let* ([e1 (copy-environment (scheme-environment))] 4926 [e2 (copy-environment e1)]) 4927 (set-top-level-value! 'list list* e1) 4928 (list 4929 (parameterize ([optimize-level 0]) (eval '(list 1 2 3) e1)) 4930 (parameterize ([optimize-level 0]) (eval '(list 1 2 3) e2))))) 4931 (equal? 4932 (let ([e1 (copy-environment (scheme-environment))]) 4933 (define-top-level-value 'curly (lambda (x) (+ x 15)) e1) 4934 (let ([e2 (copy-environment e1)]) 4935 (define-top-level-value 'curly (lambda (x) (- x 15)) e2) 4936 (list (eval '(curly 5) e1) (eval '(curly 5) e2)))) 4937 '(20 -10)) 4938 (equal? 4939 (let ([e1 (copy-environment (scheme-environment))]) 4940 (set-top-level-value! 'curly (lambda (x) (+ x 15)) e1) 4941 (let ([e2 (copy-environment e1)]) 4942 (set-top-level-value! 'curly (lambda (x) (- x 15)) e2) 4943 (list (eval '(curly 5) e1) (eval '(curly 5) e2)))) 4944 '(20 -10)) 4945 (equal? 4946 (let ([e1 (copy-environment (scheme-environment))]) 4947 (define-top-level-value 'curly (lambda (x) (+ x 15)) e1) 4948 (let ([e2 (copy-environment e1)]) 4949 (define-top-level-value 'curly (lambda (x) (- x 15)) e1) 4950 (list (eval '(curly 5) e1) (eval '(curly 5) e2)))) 4951 '(-10 20)) 4952 (equal? 4953 (let ([e1 (copy-environment (scheme-environment))]) 4954 (set-top-level-value! 'curly (lambda (x) (+ x 15)) e1) 4955 (let ([e2 (copy-environment e1)]) 4956 (set-top-level-value! 'curly (lambda (x) (- x 15)) e1) 4957 (list (eval '(curly 5) e1) (eval '(curly 5) e2)))) 4958 '(-10 20)) 4959 (equal? 4960 (let ([e (copy-environment (scheme-environment))]) 4961 (eval '(define let 4) e) 4962 (define-top-level-value 'let* 6 e) 4963 (list (top-level-value 'let e) 4964 (eval '(list let*) e))) 4965 '(4 (6))) 4966 (error? 4967 (let ([e (copy-environment (scheme-environment))]) 4968 (set-top-level-value! letrec 3 e))) 4969 (error? 4970 (let ([e (copy-environment (scheme-environment))]) 4971 (set-top-level-value! 'letrec 3 e))) 4972 (error? 4973 (let ([e (copy-environment (scheme-environment))]) 4974 (eval '(set! lambda 55) e))) 4975 (error? 4976 (let ([e (copy-environment (scheme-environment) #f)]) 4977 (eval '(define cons 55) e))) 4978 (error? 4979 (let ([e (copy-environment (scheme-environment) #f)]) 4980 (eval '(set! cons 55) e))) 4981 (error? 4982 (let ([e (copy-environment (scheme-environment) #f)]) 4983 (define-top-level-value 'cons 3 e))) 4984 (error? 4985 (let ([e (copy-environment (scheme-environment) #f)]) 4986 (set-top-level-value! 'cons 3 e))) 4987 (error? 4988 (let ([e (copy-environment (scheme-environment) #f)]) 4989 (define-top-level-value 'frappule 3 e))) 4990 (error? 4991 (let ([e (copy-environment (scheme-environment) #f)]) 4992 (set-top-level-value! 'irascible 3 e))) 4993 (error? 4994 (let ([e (copy-environment (scheme-environment))]) 4995 (eval 'nonstandard-identifier e))) 4996 (equal? 4997 (let ([env-rtd (record-rtd (scheme-environment))]) 4998 (record-writer env-rtd *saved-record-writer*) 4999 (format "~s" (scheme-environment))) 5000 "#<environment *scheme*>") 5001 (equal? 5002 (let ([e (copy-environment (scheme-environment) #t '())]) 5003 (define-top-level-value 'cons list e) 5004 (list (eval '(cons 3 4) e) (top-level-bound? 'list e))) 5005 '((3 4) #f)) 5006 (error? 5007 (let ([e (copy-environment (scheme-environment) #t '())]) 5008 (eval '(quote 3) e))) 5009 (error? 5010 (let ([e (copy-environment (scheme-environment) #t '(scheme))]) 5011 (eval '(import scheme) e) 5012 (eval '(let ((x 3)) x) e))) 5013 (error? 5014 (let ([e (copy-environment (scheme-environment) #t '(import))]) 5015 (eval '(import scheme) e) 5016 (eval '(let ((x 3)) x) e))) 5017 (eqv? 5018 (let ([e (copy-environment (scheme-environment) #t '(import scheme))]) 5019 (eval '(import scheme) e) 5020 (eval '(let ((x 3)) x) e)) 5021 3) 5022 (error? 5023 (let ([e (copy-environment (scheme-environment) #t '(import scheme))]) 5024 (eval '(import scheme) e) 5025 (set-top-level-value! 'cons 72 e))) 5026 (begin 5027 (define $copy-env-tmp1 723) 5028 (define $copy-env-tmp2 -327) 5029 (define $copy-env-env 5030 (copy-environment 5031 (interaction-environment) 5032 #t 5033 (remq 'let* 5034 (remq 'cons 5035 (remq '$copy-env-tmp1 5036 (environment-symbols (interaction-environment))))))) 5037 (environment? $copy-env-env)) 5038 (equal? 5039 (eval '(let ((x (list 1 2))) (list x x $copy-env-tmp2)) $copy-env-env) 5040 '(#0=(1 2) #0# -327)) 5041 (error? (eval 'cons $copy-env-env)) 5042 (error? (eval 'let* $copy-env-env)) 5043 (error? (eval '$copy-env-tmp1 $copy-env-env)) 5044 (begin 5045 (eval '(define + -) $copy-env-env) 5046 (begin 5047 (equal? (top-level-value '+ $copy-env-env) -) 5048 (equal? (eval '+ $copy-env-env) -) 5049 (equal? (eval '#2%+ $copy-env-env) +))) 5050 (equal? 5051 (begin 5052 (eval '(set! cons 52) $copy-env-env) 5053 (top-level-value 'cons $copy-env-env)) 5054 52) 5055 5056 ; verify new (as of csv7.5) copy-environment semantics 5057 (begin 5058 (define $ce-e1 (copy-environment (scheme-environment) #t)) 5059 (eval '(module foo (eek) (define eek -7)) $ce-e1) 5060 (eval '(import foo) $ce-e1) 5061 (eval '(define-syntax ez (identifier-syntax 'tuary)) $ce-e1) 5062 (define-top-level-value 'whence 'now $ce-e1) 5063 #t) 5064 (equal? 5065 (eval '(list cons eek whence ez) $ce-e1) 5066 `(,cons -7 now tuary)) 5067 (begin 5068 (define $ce-e2 (copy-environment $ce-e1 #t)) 5069 #t) 5070 (equal? 5071 (eval '(list cons eek whence ez) $ce-e2) 5072 `(,cons -7 now tuary)) 5073 (equal? 5074 (begin 5075 (eval '(set! eek (* eek 3)) $ce-e1) 5076 (list (eval '(let () (import foo) eek) $ce-e1) 5077 (eval '(let () (import foo) eek) $ce-e2) 5078 (eval 'eek $ce-e1) 5079 (top-level-value 'eek $ce-e2))) 5080 '(-21 -21 -21 -21)) 5081 (equal? 5082 (begin 5083 (eval '(set! eek (* eek 3)) $ce-e2) 5084 (list (eval '(let () (import foo) eek) $ce-e1) 5085 (eval '(let () (import foo) eek) $ce-e2) 5086 (eval 'eek $ce-e1) 5087 (top-level-value 'eek $ce-e2))) 5088 '(-63 -63 -63 -63)) 5089 (equal? 5090 (begin 5091 (set-top-level-value! 'eek 99 $ce-e1) 5092 (list (eval '(let () (import foo) eek) $ce-e1) 5093 (eval '(let () (import foo) eek) $ce-e2) 5094 (eval 'eek $ce-e1) 5095 (top-level-value 'eek $ce-e2))) 5096 '(99 99 99 99)) 5097 (equal? 5098 (begin 5099 (set-top-level-value! 'eek 'ack $ce-e2) 5100 (list (eval '(let () (import foo) eek) $ce-e1) 5101 (eval '(let () (import foo) eek) $ce-e2) 5102 (eval 'eek $ce-e1) 5103 (top-level-value 'eek $ce-e2))) 5104 '(ack ack ack ack)) 5105 (equal? 5106 (begin 5107 (eval '(set! whence 'later) $ce-e1) 5108 (list (eval 'whence $ce-e1) 5109 (top-level-value 'whence $ce-e2))) 5110 '(later now)) 5111 (equal? 5112 (begin 5113 (set-top-level-value! 'whence 'never $ce-e2) 5114 (list (eval 'whence $ce-e1) 5115 (top-level-value 'whence $ce-e2))) 5116 '(later never)) 5117 (error? ; cannot assign immutable variable 5118 (eval '(set! cons 4) $ce-e1)) 5119 (error? ; cannot assign immutable variable 5120 (eval '(set! cons 4) $ce-e2)) 5121 (error? ; cannot assign immutable variable 5122 (set-top-level-value! 'cons 4 $ce-e1)) 5123 (error? ; cannot assign immutable variable 5124 (set-top-level-value! 'cons 4 $ce-e2)) 5125 (error? ; invalid syntax 5126 (eval '(set! foo 4) $ce-e1)) 5127 (error? ; invalid syntax 5128 (eval '(set! foo 4) $ce-e2)) 5129 (error? ; not a variable 5130 (set-top-level-value! 'foo 4 $ce-e1)) 5131 (error? ; not a variable 5132 (set-top-level-value! 'foo 4 $ce-e2)) 5133 (error? ; invalid syntax 5134 (eval '(set! ez 4) $ce-e1)) 5135 (error? ; invalid syntax 5136 (eval '(set! ez 4) $ce-e2)) 5137 (error? ; not a variable 5138 (set-top-level-value! 'ez 4 $ce-e1)) 5139 (error? ; not a variable 5140 (set-top-level-value! 'ez 4 $ce-e2)) 5141 (error? ; invalid syntax 5142 (eval '(begin (alias ard ez) (set! ard 45)) $ce-e1)) 5143 (equal? 5144 (let () 5145 (define $ce-f1 (eval '(lambda () (list cons eek whence ez)) $ce-e1)) 5146 (define $ce-f2 (eval '(lambda () (list cons eek whence ez)) $ce-e2)) 5147 (define $ce-f3 (eval '(lambda () (list cons (let () (import foo) eek))) $ce-e1)) 5148 (define $ce-f4 (eval '(lambda () (list cons (let () (import foo) eek))) $ce-e2)) 5149 (eval '(define cons 3) $ce-e1) 5150 (define-top-level-value 'eek 4 $ce-e1) 5151 (eval '(define whence 5) $ce-e1) 5152 (define-top-level-value 'ez 6 $ce-e1) 5153 (define-top-level-value 'cons 'a $ce-e2) 5154 (eval '(define eek 'b) $ce-e2) 5155 (define-top-level-value 'whence 'c $ce-e2) 5156 (eval '(define ez 'd) $ce-e2) 5157 (list 5158 ($ce-f1) 5159 ($ce-f2) 5160 ($ce-f3) 5161 ($ce-f4) 5162 (eval '(list cons eek whence ez) $ce-e1) 5163 (eval '(list cons eek whence ez) $ce-e2) 5164 (list cons (eval '(let () (import foo) eek) $ce-e1)) 5165 (list cons (eval '(let () (import foo) eek) $ce-e2)))) 5166 `((,cons ack 5 tuary) 5167 (,cons ack c tuary) 5168 (,cons ack) 5169 (,cons ack) 5170 (3 4 5 6) 5171 (a b c d) 5172 (,cons ack) 5173 (,cons ack))) 5174 (equal? 5175 (let () 5176 (eval '(define foo 'not-a-module) $ce-e1) 5177 (list (eval 'foo $ce-e1) 5178 (eval '(let () (import foo) eek) $ce-e2))) 5179 '(not-a-module ack)) 5180 (equal? 5181 (let ([e (copy-environment (interaction-environment) #f '(cons $ce-e1))]) 5182 (list (eval 'cons e) (eval '$ce-e1 e))) 5183 (list cons $ce-e1)) 5184 (let ([e1 (copy-environment (scheme-environment) #t '())]) 5185 (define-top-level-value 'darth 'vader e1) 5186 (let ([e2 (copy-environment e1 #f)]) 5187 (let ([e3 (copy-environment e2 #t)]) 5188 (define (f) (map (lambda (e) (top-level-value 'darth e)) (list e1 e2 e3))) 5189 (and (equal? (environment-symbols e1) '(darth)) 5190 (equal? (environment-symbols e2) '(darth)) 5191 (equal? (environment-symbols e3) '(darth)) 5192 (equal? (f) '(vader vader vader)) 5193 (eq? (set-top-level-value! 'darth 'maul e1) (void)) 5194 (equal? (f) '(maul vader vader)) 5195 (eq? (set-top-level-value! 'darth 'poodle e3) (void)) 5196 (equal? (f) '(maul vader poodle)))))) 5197 ) 5198 5199(mat environment-mutable? 5200 (not (environment-mutable? (scheme-environment))) 5201 (environment-mutable? (interaction-environment)) 5202 (environment-mutable? (copy-environment (scheme-environment))) 5203 ) 5204 5205(mat trace-define-syntax 5206 (equivalent-expansion? 5207 (parameterize ([trace-output-port (open-output-string)] 5208 [print-gensym #f]) 5209 (let ([x (expand 5210 '(let () 5211 (trace-define-syntax frob 5212 (syntax-rules () 5213 [(_ rot gut) (gut rot)])) 5214 (frob 17 $tds-foo)))]) 5215 (list x (get-output-string (trace-output-port))))) 5216 '(($tds-foo 17) "|(frob (frob 17 $tds-foo))\n|($tds-foo 17)\n")) 5217) 5218 5219(mat meta 5220 (error? ; x out of context 5221 (let () (meta define x 3) x)) 5222 (error? ; x out of context 5223 (module () (meta define x 3) x)) 5224 (begin 5225 (module ($meta-z) 5226 (meta define x #'"jolly") 5227 (define-syntax y (lambda (z) x)) 5228 (define $meta-z y)) 5229 (equal? $meta-z "jolly")) 5230 (begin 5231 (module (mat-meta-bar) 5232 (module foo (macro-helper a b) 5233 (meta define table 5234 ; pretend this is a "big computation": 5235 (map cons '(#\a #\b #\c) '(1 2 3))) 5236 (meta define lookup 5237 (lambda (c) 5238 (cond [(assq c table) => cdr] [else #f]))) 5239 (meta define macro-helper 5240 (lambda (x) 5241 (syntax-case x () 5242 [(k c) 5243 (with-syntax ([n (lookup (datum c))]) 5244 #'(list '(k c) a n))]))) 5245 (define a 'is) 5246 (define-syntax b 5247 (lambda (x) (macro-helper x)))) 5248 (define mat-meta-bar 5249 (lambda () 5250 (import foo) 5251 (define-syntax d 5252 (lambda (x) (macro-helper x))) 5253 (list a (b #\b) (d #\c))))) 5254 (equal? (mat-meta-bar) '(is ((b #\b) is 2) ((d #\c) is 3)))) 5255 (error? ; lookup out-of-context (in definition of c) 5256 (begin 5257 (module (mat-meta-bar) 5258 (module foo (macro-helper a b c) 5259 (meta define table 5260 ; pretend this is a "big computation": 5261 (map cons '(#\a #\b #\c) '(1 2 3))) 5262 (meta define lookup 5263 (lambda (c) 5264 (cond [(assq c table) => cdr] [else #f]))) 5265 (meta define macro-helper 5266 (lambda (x) 5267 (syntax-case x () 5268 [(k c) 5269 (with-syntax ([n (lookup (datum c))]) 5270 #'(list '(k c) a n))]))) 5271 (define a 'is) 5272 (define-syntax b 5273 (lambda (x) (macro-helper x))) 5274 (define c 5275 (lambda (s) 5276 (map lookup (string->list s))))) 5277 (define mat-meta-bar 5278 (lambda () 5279 (import foo) 5280 (define-syntax d 5281 (lambda (x) (macro-helper x))) 5282 (list a (b #\b) (c "aq") (d #\c))))) 5283 (equal? (mat-meta-bar) '(is ((b #\b) is 2) (1 #f) ((d #\c) is 3))))) 5284 (begin 5285 (module mat-meta-foo (macro-helper a b) 5286 (meta define table 5287 ; pretend this is a "big computation": 5288 (map cons '(#\a #\b #\c) '(1 2 3))) 5289 (meta define lookup 5290 (lambda (c) 5291 (cond [(assq c table) => cdr] [else #f]))) 5292 (meta define macro-helper 5293 (lambda (x) 5294 (syntax-case x () 5295 [(k c) 5296 (with-syntax ([n (lookup (datum c))]) 5297 #'(list '(k c) a n))]))) 5298 (define a 'is) 5299 (define-syntax b 5300 (lambda (x) (macro-helper x)))) 5301 #t) 5302 (equal? 5303 (let () 5304 (define mat-meta-bar1 5305 (lambda () 5306 (import mat-meta-foo) 5307 (define-syntax d 5308 (lambda (x) (macro-helper x))) 5309 (list a (b #\b) (d #\c)))) 5310 (mat-meta-bar1)) 5311 '(is ((b #\b) is 2) ((d #\c) is 3))) 5312 (begin 5313 (define mat-meta-bar2 5314 (lambda () 5315 (import mat-meta-foo) 5316 (define-syntax d 5317 (lambda (x) (macro-helper x))) 5318 (list a (b #\b) (d #\c)))) 5319 (procedure? mat-meta-bar2)) 5320 (equal? (mat-meta-bar2) '(is ((b #\b) is 2) ((d #\c) is 3))) 5321 (error? ; out-of-context (run-time reference to meta variable) 5322 (let () 5323 (module foo (macro-helper a b c) 5324 (meta define table 5325 ; pretend this is a "big computation": 5326 (map cons '(#\a #\b #\c) '(1 2 3))) 5327 (meta define lookup 5328 (lambda (c) 5329 (cond [(assq c table) => cdr] [else #f]))) 5330 (meta define macro-helper 5331 (lambda (x) 5332 (syntax-case x () 5333 [(k c) 5334 (with-syntax ([n (lookup (datum c))]) 5335 #'(list '(k c) a n))]))) 5336 (define a 'is) 5337 (define-syntax b 5338 (lambda (x) (macro-helper x))) 5339 (define c 5340 (lambda (s) 5341 (map lookup (string->list s))))) 5342 (define bar 5343 (lambda () 5344 (import foo) 5345 (define-syntax d 5346 (lambda (x) (macro-helper x))) 5347 (list a (b #\b) (c "aq") (d #\c)))) 5348 (bar))) 5349 (begin 5350 (module (mat-meta-q mat-meta-a) 5351 (meta define mat-meta-q 13) 5352 (define-syntax mat-meta-a 5353 (lambda (x) 5354 (set! mat-meta-q (* mat-meta-q 2)) 5355 (with-syntax ((n mat-meta-q)) 5356 #'(list n (- mat-meta-q 6)))))) 5357 (meta define mat-meta-x (begin (set! mat-meta-q (+ mat-meta-q 4)) mat-meta-q)) 5358 (meta module () (set! mat-meta-q (+ mat-meta-q 10))) 5359 (define-syntax ans 5360 (lambda (x) 5361 (with-syntax ([d (cons (quotient (+ mat-meta-q mat-meta-x) 2) mat-meta-a)]) 5362 #''d))) 5363 (equal? ans '(35 54 48))) 5364 (equal? 5365 (let () 5366 (module (mat-meta-q mat-meta-a) 5367 (meta define mat-meta-q 13) 5368 (define-syntax mat-meta-a 5369 (lambda (x) 5370 (set! mat-meta-q (* mat-meta-q 2)) 5371 (with-syntax ((n mat-meta-q)) 5372 #'(list n (- mat-meta-q 6)))))) 5373 (meta define mat-meta-x (begin (set! mat-meta-q (+ mat-meta-q 4)) mat-meta-q)) 5374 (meta module () (set! mat-meta-q (+ mat-meta-q 10))) 5375 (define-syntax ans 5376 (lambda (x) 5377 (with-syntax ([d (cons (quotient (+ mat-meta-q mat-meta-x) 2) mat-meta-a)]) 5378 #''d))) 5379 ans) 5380 '(35 54 48)) 5381 (begin 5382 (module (mat-meta-zeta) 5383 (meta module frobrat (boz) (define boz 3)) 5384 (define-syntax rot (lambda (x) (import frobrat) boz)) 5385 (define mat-meta-zeta rot)) 5386 (eq? mat-meta-zeta 3)) 5387 (begin 5388 (module (mat-meta-gorp) 5389 (meta define f (lambda (x) (if (= x 0) '() (cons x (f (- x 1)))))) 5390 (define-syntax mat-meta-gorp 5391 (lambda (x) 5392 (syntax-case x () 5393 [(_ n) 5394 (with-syntax ([(num ...) (f (datum n))]) 5395 #'(list num ...))])))) 5396 (equal? (mat-meta-gorp 5) '(5 4 3 2 1))) 5397 (error? ; f not bound (referenced in alpha before definition complete) 5398 (module (mat-meta-gorp) 5399 (meta define f 5400 (lambda (x) 5401 (define-syntax alpha 5402 (lambda (x) 5403 (f x) ; f not bound (yet) 5404 #'())) 5405 (if (= x 0) 5406 alpha 5407 (cons x (f (- x 1)))))) 5408 (define-syntax mat-meta-gorp 5409 (lambda (x) 5410 (syntax-case x () 5411 [(_ n) 5412 (with-syntax ([(num ...) (f (datum n))]) 5413 #'(list num ...))]))))) 5414 (begin 5415 (define-syntax $cftest 5416 (syntax-rules () 5417 [(_ e0 e1 e2) 5418 (begin 5419 (collect (collect-maximum-generation)) ; close ports left open by load/compile-file w/mat's error handler 5420 (let ((op (open-output-file "testfile.ss" 'replace))) 5421 (pretty-print 'e0 op) 5422 (close-output-port op)) 5423 (compile-file "testfile.ss") 5424 (and e1 (begin (load "testfile.ss") e2)))])) 5425 #t) 5426 ($cftest 5427 (begin 5428 (meta define meta-$bun 3) 5429 (define meta-$burger 4)) 5430 (equal? meta-$bun 3) 5431 (equal? meta-$burger 4)) 5432 (error? 5433 ($cftest 5434 (meta define meta-$lettuce 3) 5435 (equal? meta-$bun 3) 5436 (equal? meta-$burger 4))) 5437 ; check to make sure meta still works if we change interaction environment 5438 (eqv? 5439 (parameterize ([interaction-environment (copy-environment (interaction-environment))]) 5440 (eval ' 5441 (let () 5442 (meta define foo 3) 5443 (meta define bar (* 3 7)) 5444 (define-syntax a (lambda (x) (+ foo bar))) 5445 a))) 5446 24) 5447) 5448 5449(mat meta2 5450 (error? ; x out-of-context 5451 (begin 5452 (meta define x 3) 5453 x)) 5454 (begin 5455 (meta define x 3) 5456 (define-syntax y (lambda (z) x)) 5457 (eq? y 3)) 5458 5459 ; top-level module tests 5460 (error? ; x out-of-context 5461 (module m (x) (meta define x 3) (pretty-print x))) 5462 (error? ; x out-of-context 5463 (begin 5464 (module m (x) (meta define x 3)) 5465 (let () (import m) x))) 5466 (begin 5467 (module m (x) (meta define x 3)) 5468 (eq? (let () (import m) (define-syntax y (lambda (z) x)) y) 3)) 5469 (error? ; x out-of-context 5470 (begin 5471 (module m (x) (meta define x 3)) 5472 (import m) 5473 x)) 5474 (begin 5475 (module mm-m (mm-x) (meta define mm-x 3)) 5476 (import mm-m) 5477 (define-syntax mm-y (lambda (z) mm-x)) 5478 (eq? mm-y 3)) 5479 (begin 5480 (module ($meta-z) 5481 (meta define x #'"jolly") 5482 (define-syntax y (lambda (z) x)) 5483 (define $meta-z y)) 5484 (equal? $meta-z "jolly")) 5485 5486 ; local tests 5487 (error? ;=> out-of-context or unbound error 5488 (let () 5489 (module m (x) (meta define x 3) (pretty-print x)) 5490 4)) 5491 (error? ;=> out-of-context or unbound error 5492 (let () 5493 (module m (x) (meta define x 3)) 5494 (let () (import m) x))) 5495 (eq? 5496 (let () 5497 (module m (x) (meta define x 3)) 5498 (let () (import m) (define-syntax y (lambda (z) x)) y)) 5499 3) 5500 (let () 5501 (module ($meta-z) 5502 (meta define x #'"jolly") 5503 (define-syntax y (lambda (z) x)) 5504 (define $meta-z y)) 5505 (equal? $meta-z "jolly")) 5506 (error? ;=> q out-of-context 5507 (let () 5508 (meta define p 3) 5509 (define-syntax a 5510 (lambda (x) 5511 (meta define q 4) 5512 `(,#'quote (,p ,q)))) 5513 a)) 5514 (equal? 5515 (let () 5516 (meta define p 3) 5517 (define-syntax a 5518 (lambda (x) 5519 (meta define q 4) 5520 (define-syntax b (lambda (x) q)) 5521 `(,#'quote (,p ,b)))) 5522 a) 5523 '(3 4)) 5524 5525 (begin 5526 (define $mm-p "p") 5527 (define $mm-q "q") 5528 (define $mm-r "r") 5529 (meta module 5530 ($mm-a $mm-b $mm-c) 5531 (define t '()) 5532 (define $mm-a (lambda (k v) (set! t (cons (cons k v) t)) #'(void))) 5533 (define $mm-b (lambda (k) (cdr (assq k t)))) 5534 (define-syntax $mm-c 5535 (lambda (x) 5536 (syntax-case x (get put) 5537 [(_ get n) ($mm-b (datum n))] 5538 [(_ put n v) ($mm-a (datum n) #'v)]))) 5539 (set! t `((1 . ,#'$mm-q) (2 . ,#'$mm-r)))) 5540 ($mm-c put 7 $mm-p) 5541 (equal? 5542 (list ($mm-c get 1) ($mm-c get 2) ($mm-c get 7)) 5543 '("q" "r" "p"))) 5544 (equal? 5545 (let ([p "p!"] [q "q!"] [r "r!"]) 5546 (meta module (a b c) 5547 (define t '()) 5548 (define a (lambda (k v) (set! t (cons (cons k v) t)) #'(void))) 5549 (define b (lambda (k) (cdr (assq k t)))) 5550 (define-syntax c 5551 (lambda (x) 5552 (syntax-case x (get put) 5553 [(_ get n) (b (datum n))] 5554 [(_ put n v) (a (datum n) #'v)]))) 5555 (set! t `((1 . ,#'q) (2 . ,#'r)))) 5556 (c put 7 p) 5557 (list (c get 1) (c get 2) (c get 7))) 5558 '("q!" "r!" "p!")) 5559 5560 ; assuming internal-defines-as-letrec* defaults to #t 5561 (internal-defines-as-letrec*) 5562 ; following tests assume it's set to #f 5563 (begin (internal-defines-as-letrec* #f) (not (internal-defines-as-letrec*))) 5564 ; top-level module tests 5565 (error? ; undefined variable merry 5566 (module sam (frodo) 5567 (define merry 'merry) 5568 (define frodo (cons merry merry)))) 5569 (error? ; undefined variable frodo 5570 (module sam (frodo) 5571 (define merry 'merry) 5572 (define frodo 'frodo) 5573 (define pippin (cons frodo frodo)))) 5574 (begin (internal-defines-as-letrec* #t) (internal-defines-as-letrec*)) 5575 (eq? (let () 5576 (module (x !y ?y) (define x (call/cc values)) 5577 (define y 0) 5578 (define !y (lambda (v) (set! y v))) 5579 (define ?y (lambda () y))) 5580 (!y (+ (?y) 1)) 5581 (x values) 5582 (?y)) 5583 1) 5584 (begin 5585 (module (x !y ?y) 5586 (define x (call/cc values)) 5587 (define y 0) 5588 (define !y (lambda (v) (set! y v))) 5589 (define ?y (lambda () y))) 5590 (!y (+ (?y) 1)) 5591 (x values) 5592 (eq? (?y) 1)) 5593 (begin 5594 (meta define hobbits '()) 5595 (module () 5596 (meta module () 5597 (set! hobbits (cons 'merry hobbits))) 5598 (meta module () 5599 (set! hobbits (cons 'lobelia hobbits)) 5600 (set! hobbits (cons 'frodo hobbits)) 5601 (set! hobbits (cons 'bilbo hobbits))) 5602 (meta begin 5603 (set! hobbits (cons 'pippin hobbits)))) 5604 (define-syntax hobbit-report 5605 (lambda (x) `(,#'quote ,(datum->syntax #'* hobbits)))) 5606 (equal? hobbit-report '(pippin bilbo frodo lobelia merry))) 5607 (let () 5608 (meta define hobbits '()) 5609 (module () 5610 (meta module () 5611 (set! hobbits (cons 'merry hobbits))) 5612 (meta module () 5613 (set! hobbits (cons 'lobelia hobbits)) 5614 (set! hobbits (cons 'frodo hobbits)) 5615 (set! hobbits (cons 'bilbo hobbits))) 5616 (meta begin 5617 (set! hobbits (cons 'pippin hobbits)))) 5618 (define-syntax hobbit-report 5619 (lambda (x) `(,#'quote ,(datum->syntax #'* hobbits)))) 5620 (equal? hobbit-report '(pippin bilbo frodo lobelia merry))) 5621 (begin 5622 (meta define $whatsit) 5623 (meta begin (set! $whatsit #xc7c7c7c7)) 5624 (define-syntax $mm-a (lambda (x) $whatsit)) 5625 (eqv? $mm-a #xc7c7c7c7)) 5626 (error? ; no expr in body 5627 (let () (meta begin (void)))) 5628 (error? ; invalid meta definition ((void)) 5629 (meta (void))) 5630 (error? ; invalid meta definition ((void)) 5631 (module () (meta (void)))) 5632 (error? ; invalid meta definition ((void)) 5633 (let () (meta (void)))) 5634 (begin 5635 (define hobbits '()) 5636 (module () 5637 (module () 5638 (set! hobbits (cons 'merry hobbits))) 5639 (module () 5640 (set! hobbits (cons 'lobelia hobbits)) 5641 (set! hobbits (cons 'frodo hobbits)) 5642 (set! hobbits (cons 'bilbo hobbits))) 5643 (set! hobbits (cons 'pippin hobbits))) 5644 (equal? hobbits '(pippin bilbo frodo lobelia merry))) 5645 (let () 5646 (define hobbits '()) 5647 (module () 5648 (module () 5649 (set! hobbits (cons 'merry hobbits))) 5650 (module () 5651 (set! hobbits (cons 'lobelia hobbits)) 5652 (set! hobbits (cons 'frodo hobbits)) 5653 (set! hobbits (cons 'bilbo hobbits))) 5654 (set! hobbits (cons 'pippin hobbits))) 5655 (equal? hobbits '(pippin bilbo frodo lobelia merry))) 5656 5657 ; assuming internal-defines-as-letrec* true 5658 (internal-defines-as-letrec*) 5659 (begin 5660 (define hobbits '()) 5661 (module sam (frodo) 5662 (define merry (set! hobbits (cons 'merry hobbits))) 5663 (define frodo (set! hobbits (cons 'frodo hobbits))) 5664 (define pippin (set! hobbits (cons 'pippin hobbits)))) 5665 (equal? hobbits '(pippin frodo merry))) 5666 (let () 5667 (define hobbits '()) 5668 (module sam (frodo) 5669 (define merry (set! hobbits (cons 'merry hobbits))) 5670 (define frodo (set! hobbits (cons 'frodo hobbits))) 5671 (define pippin (set! hobbits (cons 'pippin hobbits)))) 5672 (equal? hobbits '(pippin frodo merry))) 5673 (begin 5674 (define hobbits '()) 5675 (module sam (frodo) 5676 (define merry (set! hobbits (cons 'merry hobbits))) 5677 (module (frodo) 5678 (define lobelia (set! hobbits (cons 'lobelia hobbits))) 5679 (define frodo (set! hobbits (cons 'frodo hobbits))) 5680 (define bilbo (set! hobbits (cons 'bilbo hobbits)))) 5681 (define pippin (set! hobbits (cons 'pippin hobbits)))) 5682 (equal? hobbits '(pippin bilbo frodo lobelia merry))) 5683 (let () 5684 (define hobbits '()) 5685 (module sam (frodo) 5686 (define merry (set! hobbits (cons 'merry hobbits))) 5687 (module (frodo) 5688 (define lobelia (set! hobbits (cons 'lobelia hobbits))) 5689 (define frodo (set! hobbits (cons 'frodo hobbits))) 5690 (define bilbo (set! hobbits (cons 'bilbo hobbits)))) 5691 (define pippin (set! hobbits (cons 'pippin hobbits)))) 5692 (equal? hobbits '(pippin bilbo frodo lobelia merry))) 5693 (begin 5694 (module sam (frodo) 5695 (define merry 'merry) 5696 (define frodo (cons merry merry))) 5697 (equal? (let () (import sam) frodo) '(merry . merry))) 5698 (error? ; undefined variable merry 5699 (module sam (frodo) 5700 (define frodo (cons merry merry)) 5701 (define merry 'merry))) 5702 (error? ; undefined variable frodo 5703 (module sam (frodo) 5704 (define merry 'merry) 5705 (define pippin (cons frodo frodo)) 5706 (define frodo 'frodo))) 5707 (begin 5708 (module sam (frodo) 5709 (define merry 'merry) 5710 (define frodo (lambda () pippin)) 5711 (define pippin (cons frodo frodo))) 5712 (let () (import sam) (eq? (car (frodo)) frodo))) 5713 (let () 5714 (module (x !y ?y) 5715 (define x (call/cc values)) 5716 (define y 0) 5717 (define !y (lambda (v) (set! y v))) 5718 (define ?y (lambda () y))) 5719 (!y (+ (?y) 1)) 5720 (x values) 5721 (eq? (?y) 1)) 5722 (begin 5723 (module (x !y ?y) 5724 (define x (call/cc values)) 5725 (define y 0) 5726 (define !y (lambda (v) (set! y v))) 5727 (define ?y (lambda () y))) 5728 (!y (+ (?y) 1)) 5729 (x values) 5730 (eq? (?y) 1)) 5731 5732 ; test for proper evaluation of meta defines and inits at compile-file time, 5733 ; visit time, revisit time, and load time 5734 (begin 5735 (with-output-to-file "testfile.ss" 5736 (lambda () 5737 (pretty-print 5738 '(meta module $mm-m (a) 5739 (define q 3) 5740 (define-syntax qinc! (identifier-syntax (set! q (+ q 1)))) 5741 (define-syntax (a x) qinc! q) 5742 qinc! 5743 (set! q (* q q))))) 5744 'replace) 5745 (compile-file "testfile") 5746 #t) 5747 (eq? (let () (import $mm-m) a) 17) 5748 (eq? (let () (import $mm-m) a) 18) 5749 (begin (visit "testfile.so") #t) 5750 (eq? (let () (import $mm-m) a) 17) 5751 (eq? (let () (import $mm-m) a) 18) 5752 (begin (load "testfile.so") #t) 5753 (eq? (let () (import $mm-m) a) 17) 5754 (eq? (let () (import $mm-m) a) 18) 5755 (begin (revisit "testfile.so") #t) 5756 (eq? (let () (import $mm-m) a) 19) 5757) 5758 5759(mat quasisyntax 5760 (error? ; invalid syntax 5761 quasisyntax) 5762 (error? ; invalid syntax 5763 (quasisyntax)) 5764 (error? ; invalid syntax 5765 (quasisyntax . a)) 5766 (error? ; invalid syntax 5767 (quasisyntax a b c)) 5768 (error? ; misplaced 5769 (unsyntax x)) 5770 (error? ; misplaced 5771 (unsyntax-splicing x)) 5772 (error? ; misplaced 5773 (unsyntax x y)) 5774 (error? ; misplaced 5775 (unsyntax-splicing x y)) 5776 (error? ; misplaced 5777 (unsyntax)) 5778 (error? ; misplaced 5779 (unsyntax-splicing)) 5780 (error? ; misplaced 5781 unsyntax) 5782 (error? ; misplaced 5783 unsyntax-splicing) 5784 (begin (define-syntax qs-foo 5785 (lambda (x) 5786 (syntax-case x () 5787 [(_ x ...) 5788 #`(list #,(length #'(x ...)) 'x ...)]))) 5789 #t) 5790 (equal? (qs-foo 3 2 1) '(3 3 2 1)) 5791 (equal? (qs-foo 3 2 1) '(3 3 2 1)) 5792 (begin (define-syntax qs-foo 5793 (lambda (x) 5794 (syntax-case x () 5795 [(_ x ...) 5796 (quasisyntax (list (unsyntax (length #'(x ...))) 'x ...))]))) 5797 #t) 5798 (equal? (qs-foo 3 2 1) '(3 3 2 1)) 5799 (equal? (qs-foo 3 2 1) '(3 3 2 1)) 5800 (begin (define-syntax qs-foo 5801 (lambda (x) 5802 (syntax-case x () 5803 [(_ x ...) 5804 #`'#`(a #,a b #,@b #,#(#,@#'(x ...)) #,@#(#,#'(x ...)))]))) 5805 #t) 5806 (equal? 5807 (qs-foo 3 2 1) 5808 '(quasisyntax 5809 (a (unsyntax a) b (unsyntax-splicing b) 5810 (unsyntax #3(3 2 1)) (unsyntax-splicing #1((3 2 1)))))) 5811 (begin (define-syntax qs-foo 5812 (lambda (x) 5813 (syntax-case x () 5814 [(_ x ...) 5815 #`'(a #(#,#'(x ...) #,@#'(x ...) unsyntax unsyntax-splicing ,a ,@b) (a . #,#'(x ...)) . c)]))) 5816 #t) 5817 (equal? 5818 (qs-foo 3 2 1) 5819 '(a #8((3 2 1) 3 2 1 unsyntax unsyntax-splicing ,a ,@b) 5820 (a 3 2 1) 5821 . 5822 c)) 5823 (begin (define-syntax qs-foo 5824 (lambda (x) 5825 (syntax-case x () 5826 [(_ x ...) 5827 #`'#(a (#,#'(x ...) #,@#'(x ...) unsyntax unsyntax-splicing ,a ,@b) (a . #,#'(x ...)))]))) 5828 #t) 5829 (equal? 5830 (qs-foo 3 2 1) 5831 '#3(a ((3 2 1) 3 2 1 unsyntax unsyntax-splicing ,a ,@b) 5832 (a 3 2 1))) 5833 ; test zero and two+ unsyntax-splicing subforms 5834 (begin (define-syntax qs-foo 5835 (lambda (x) 5836 (syntax-case x () 5837 [(_ x ...) 5838 #`'((unsyntax) 0 (unsyntax #'(a x ... b) #'(x ...)) c)]))) 5839 #t) 5840 (equal? (qs-foo 3 2 1) '(0 (a 3 2 1 b) (3 2 1) c)) 5841 (begin (define-syntax qs-foo 5842 (lambda (x) 5843 (syntax-case x () 5844 [(_ x ...) 5845 #`'#((unsyntax) 0 (unsyntax #'(a x ... b) #'(x ...)) c)]))) 5846 #t) 5847 (equal? (qs-foo 3 2 1) '#(0 (a 3 2 1 b) (3 2 1) c)) 5848 ; test zero and two+ unsyntax-splicing subforms 5849 (begin (define-syntax qs-foo 5850 (lambda (x) 5851 (syntax-case x () 5852 [(_ x ...) 5853 #`'((unsyntax-splicing) 0 (unsyntax-splicing #'(a x ... b) #'(x ...)) c)]))) 5854 #t) 5855 (equal? (qs-foo 3 2 1) '(0 a 3 2 1 b 3 2 1 c)) 5856 (begin (define-syntax qs-foo 5857 (lambda (x) 5858 (syntax-case x () 5859 [(_ x ...) 5860 #`'#((unsyntax-splicing) 0 (unsyntax-splicing #'(a x ... b) #'(x ...)) c)]))) 5861 #t) 5862 (equal? (qs-foo 3 2 1) '#(0 a 3 2 1 b 3 2 1 c)) 5863 ; make sure out-of-place unsyntax/unsyntax-splicing keywords are left alone 5864 (begin (define-syntax qs-foo 5865 (lambda (x) 5866 (syntax-case x () 5867 [(_ x ...) #`'unsyntax]))) 5868 #t) 5869 (equal? (qs-foo 3 2 1) 'unsyntax) 5870 (begin (define-syntax qs-foo 5871 (lambda (x) 5872 (syntax-case x () 5873 [(_ x ...) #`'unsyntax-splicing]))) 5874 #t) 5875 (equal? (qs-foo 3 2 1) 'unsyntax-splicing) 5876 (begin (define-syntax qs-foo 5877 (lambda (x) 5878 (syntax-case x () 5879 [(_ x ...) 5880 #`'(a . (unsyntax #'(x ...) #'(x ...)))]))) 5881 #t) 5882 (equal? (qs-foo 3 2 1) '(a . (unsyntax (syntax (3 2 1)) (syntax (3 2 1))))) 5883 (begin (define-syntax qs-foo 5884 (lambda (x) 5885 (syntax-case x () 5886 [(_ x ...) 5887 #`'(a . (unsyntax-splicing #'(x ...)))]))) 5888 #t) 5889 (equal? (qs-foo 3 2 1) '(a . (unsyntax-splicing (syntax (3 2 1))))) 5890 ; test noninterference with quasiquote 5891 (begin (define-syntax qs-foo 5892 (lambda (x) 5893 (syntax-case x () 5894 [(_ x1 x2 ...) 5895 #``(a ,@(reverse (list #,@#'(x2 ...))) ,#,#'x1)]))) 5896 #t) 5897 (equal? 5898 (qs-foo 3 2 1) 5899 '(a 1 2 3)) 5900 ; tests adpated from Andre van Tonder posts to srfi 93 discussion 5901 (equal? 5902 (let () 5903 (define-syntax swap! 5904 (lambda (e) 5905 (syntax-case e () 5906 [(_ a b) 5907 (let ([a #'a] [b #'b]) 5908 (quasisyntax 5909 (let ([temp (unsyntax a)]) 5910 (set! (unsyntax a) (unsyntax b)) 5911 (set! (unsyntax b) temp))))]))) 5912 (let ([temp 1] [set! 2]) 5913 (swap! set! temp) 5914 (cons temp set!))) 5915 '(2 . 1)) 5916 (eq? 5917 (let () 5918 (define-syntax case 5919 (lambda (x) 5920 (syntax-case x () 5921 [(_ e c1 c2 ...) 5922 (quasisyntax 5923 (let ([t e]) 5924 (unsyntax 5925 (let f ([c1 #'c1] [cmore #'(c2 ...)]) 5926 (if (null? cmore) 5927 (syntax-case c1 (else) 5928 [(else e1 e2 ...) #'(begin e1 e2 ...)] 5929 [((k ...) e1 e2 ...) 5930 #'(if (memv t '(k ...)) 5931 (begin e1 e2 ...))]) 5932 (syntax-case c1 () 5933 [((k ...) e1 e2 ...) 5934 (quasisyntax 5935 (if (memv t '(k ...)) 5936 (begin e1 e2 ...) 5937 (unsyntax 5938 (f (car cmore) 5939 (cdr cmore)))))]))))))]))) 5940 (case 'a [(b c) 'no] [(d a) 'yes])) 5941 'yes) 5942 (eqv? 5943 (let () 5944 (define-syntax let-in-order 5945 (lambda (form) 5946 (syntax-case form () 5947 [(_ ((i e) ...) e0 e1 ...) 5948 (let f ([ies #'((i e) ...)] [its #'()]) 5949 (syntax-case ies () 5950 [() (quasisyntax (let (unsyntax its) e0 e1 ...))] 5951 [((i e) . ies) 5952 (with-syntax ([t (car (generate-temporaries '(t)))]) 5953 (quasisyntax 5954 (let ([t e]) 5955 (unsyntax 5956 (f #'ies 5957 (quasisyntax 5958 ((i t) 5959 (unsyntax-splicing its))))))))]))]))) 5960 (let-in-order ((x 1) (y 2)) (+ x y))) 5961 3) 5962 (equal? 5963 (let-syntax ([test-ellipses-over-unsyntax 5964 (lambda (e) 5965 (let ([a #'a]) 5966 (with-syntax ([(b ...) #'(1 2 3)]) 5967 (quasisyntax '((b #,a) ...)))))]) 5968 (test-ellipses-over-unsyntax)) 5969 '((1 a) (2 a) (3 a))) 5970 (equal? 5971 (let-syntax ([test (lambda (_) 5972 (quasisyntax '(list #,(+ 1 2) 4)))]) 5973 (test)) 5974 '(list 3 4)) 5975 (equal? 5976 (let-syntax ([test (lambda (_) 5977 (let ([name #'a]) 5978 (quasisyntax '(list #,name '#,name))))]) 5979 (test)) 5980 '(list a 'a)) 5981 (equal? 5982 (let-syntax ([test (lambda (_) 5983 (quasisyntax 5984 '(a #,(+ 1 2) #,@(map abs '(4 -5 6)) b)))]) 5985 (test)) 5986 '(a 3 4 5 6 b)) 5987 (equal? 5988 (let-syntax ([test (lambda (_) 5989 (quasisyntax 5990 '((foo #,(- 10 3)) 5991 #,@(cdr '(5)) 5992 . 5993 #,(car '(7)))))]) 5994 (test)) 5995 '((foo 7) . 7)) 5996 (equal? 5997 (let-syntax ([test (lambda (_) 5998 (quasisyntax 5999 '#(10 5 #,(sqrt 4) #,@(map sqrt '(16 9)) 8)))]) 6000 (test)) 6001 '#(10 5 2 4 3 8)) 6002 (eqv? 6003 (let-syntax ([test (lambda (_) (quasisyntax #,(+ 2 3)))]) 6004 (test)) 6005 5) 6006 (equal? 6007 (let-syntax ([test (lambda (_) 6008 (quasisyntax 6009 '(a (quasisyntax 6010 (b #,(+ 1 2) #,(foo #,(+ 1 3) d) e)) 6011 f)))]) 6012 (test)) 6013 '(a (quasisyntax (b #,(+ 1 2) #,(foo 4 d) e)) f)) 6014 6015 (equal? 6016 (let-syntax ([test (lambda (_) 6017 (let ([name1 #'x] [name2 #'y]) 6018 (quasisyntax 6019 '(a (quasisyntax (b #,#,name1 #,#'#,name2 d)) 6020 e))))]) 6021 (test)) 6022 '(a (quasisyntax (b #,x #,#'y d)) e)) 6023 ; Bawden's extensions: 6024 (equal? 6025 (let-syntax ([test (lambda (_) 6026 (quasisyntax '(a (unsyntax 1 2) b)))]) 6027 (test)) 6028 '(a 1 2 b)) 6029 (equal? 6030 (let-syntax ([test (lambda (_) 6031 (quasisyntax 6032 '(a (unsyntax-splicing '(1 2) '(3 4)) b)))]) 6033 (test)) 6034 '(a 1 2 3 4 b)) 6035 (equal? 6036 (let-syntax ([test (lambda (_) 6037 (let ([x #'(a b c)]) 6038 (quasisyntax 6039 '(quasisyntax (#,#,x #,@#,x #,#,@x #,@#,@x)))))]) 6040 (test)) 6041 '(quasisyntax 6042 (#,(a b c) 6043 #,@(a b c) 6044 (unsyntax a b c) 6045 (unsyntax-splicing a b c)))) 6046) 6047 6048(mat meta-cond 6049 (begin 6050 (define $meta-cond-expr 6051 '(meta-cond 6052 [(= (optimize-level) 3) $mc-a $mc-b $mc-c] 6053 [(= (optimize-level) 2) $mc-d] 6054 [else $mc-e $mc-f])) 6055 #t) 6056 (equivalent-expansion? 6057 (parameterize ([optimize-level 3]) (expand $meta-cond-expr)) 6058 '(begin $mc-a $mc-b $mc-c)) 6059 (equivalent-expansion? 6060 (parameterize ([optimize-level 2]) (expand $meta-cond-expr)) 6061 '$mc-d) 6062 (equivalent-expansion? 6063 (parameterize ([optimize-level 0]) (expand $meta-cond-expr)) 6064 '(begin $mc-e $mc-f)) 6065 (equal? 6066 (parameterize ([optimize-level 0]) ; should have no effect 6067 (with-output-to-string 6068 (lambda () 6069 (meta-cond 6070 [(= (optimize-level) 3) (pretty-print 'level3)] 6071 [(= (optimize-level) 2) (pretty-print 'level2)])))) 6072 (case (optimize-level) 6073 [(2) "level2\n"] 6074 [(3) "level3\n"] 6075 [else ""])) 6076) 6077 6078(mat make-compile-time-value 6079 (error? ; incorrect number of arguments 6080 (let () 6081 (define-syntax a 6082 (lambda (x) 6083 (lambda (r) 6084 (r)))) 6085 a)) 6086 (error? ; not an identifier 6087 (let () 6088 (define-syntax a 6089 (lambda (x) 6090 (lambda (r) 6091 (r #'(a))))) 6092 a)) 6093 (error? ; not an identifier 6094 (let () 6095 (define-syntax a 6096 (lambda (x) 6097 (lambda (r) 6098 (r #'(a) #'frip)))) 6099 a)) 6100 (error? ; not an identifier 6101 (let () 6102 (define-syntax a 6103 (lambda (x) 6104 (lambda (r) 6105 (r #'a "frip")))) 6106 a)) 6107 (error? ; incorrect number of arguments 6108 (let () 6109 (define-syntax a 6110 (lambda (x) 6111 (lambda (r) 6112 (r #'a #'frip "extra stuff")))) 6113 a)) 6114 (error? ; not a compile-time value 6115 (compile-time-value-value 17)) 6116 (begin 6117 (with-output-to-file "testfile-mctv0.ss" 6118 (lambda () 6119 (pretty-print 6120 '(library (testfile-mctv0) (export get-ctv get-property) (import (chezscheme)) 6121 (define-syntax get-ctv 6122 (lambda (x) 6123 (lambda (r) 6124 (syntax-case x () 6125 [(_ q) #`'#,(datum->syntax #'* (r #'q))])))) 6126 (define-syntax get-property 6127 (lambda (x) 6128 (lambda (r) 6129 (syntax-case x () 6130 [(_ q prop) #`'#,(datum->syntax #'* (r #'q #'prop))]))))))) 6131 'replace) 6132 (for-each separate-compile '(mctv0)) 6133 #t) 6134 (begin 6135 (import (testfile-mctv0)) 6136 #t) 6137 (compile-time-value? (make-compile-time-value 'fred)) 6138 (begin 6139 (define-syntax frob (make-compile-time-value 'rabf)) 6140 #t) 6141 (eq? (get-ctv frob) 'rabf) 6142 (error? ; invalid syntax 6143 frob) 6144 (error? ; invalid syntax 6145 (frob kupe)) 6146 (eq? 6147 (let () 6148 (define-syntax frob (make-compile-time-value 'shuddle)) 6149 (get-ctv frob)) 6150 'shuddle) 6151 (eq? 6152 (let-syntax ([frob (make-compile-time-value 'skupo)]) 6153 (get-ctv frob)) 6154 'skupo) 6155 (equal? 6156 (let ([frob "not the global frob ..."]) 6157 (list frob (get-ctv frob))) 6158 '("not the global frob ..." #f)) 6159 (eq? (get-ctv frob) 'rabf) 6160 (error? ; invalid syntax 6161 (let () 6162 (define-syntax frob (make-compile-time-value 'shuddle)) 6163 frob)) 6164 (error? ; invalid syntax 6165 (let () 6166 (define-syntax frob (make-compile-time-value 'shuddle)) 6167 (frob))) 6168 (error? ; duplicate definition 6169 (module mctv-m1 (x) 6170 (define x 3) 6171 (define-syntax x (make-compile-time-value 'xxx)))) 6172 (error? ; duplicate definition 6173 (module mctv-m1 (x) 6174 (define-syntax x (make-compile-time-value 'xxx)) 6175 (define-syntax x (make-compile-time-value 'xxx)))) 6176 (begin 6177 (module mctv-m1 (x) 6178 (define-syntax x (make-compile-time-value 'xxx))) 6179 #t) 6180 (eq? (let () (import mctv-m1) (get-ctv x)) 'xxx) 6181 (begin 6182 (library (mctv l1) (export x) (import (chezscheme) (testfile-mctv0)) 6183 (define-syntax x (make-compile-time-value 'xow))) 6184 #t) 6185 (eq? (let () (import (mctv l1)) (get-ctv x)) 'xow) 6186 (eq? (compile-time-value-value (top-level-syntax 'x (environment '(mctv l1)))) 'xow) 6187 (begin 6188 (with-output-to-file "testfile-mctv1.ss" 6189 (lambda () 6190 (pretty-print 6191 '(library (testfile-mctv1) (export x) (import (chezscheme)) 6192 (define-syntax x (make-compile-time-value 'xuko1))))) 6193 'replace) 6194 (for-each separate-compile '(mctv1)) 6195 #t) 6196 (eq? (let () (import (testfile-mctv1)) (get-ctv x)) 'xuko1) 6197 (compile-time-value? (top-level-syntax 'x (environment '(testfile-mctv1)))) 6198 (eq? (compile-time-value-value (top-level-syntax 'x (environment '(testfile-mctv1)))) 'xuko1) 6199 (begin 6200 (with-output-to-file "testfile-mctv1a.ss" 6201 (lambda () 6202 (pretty-print 6203 '(library (testfile-mctv1a) (export x) (import (chezscheme)) 6204 (define-syntax x (make-compile-time-value 'xuko1))))) 6205 'replace) 6206 (for-each separate-compile '(mctv1a)) 6207 #t) 6208 (eq? (compile-time-value-value (top-level-syntax 'x (environment '(testfile-mctv1a)))) 'xuko1) 6209 (eq? (let () (import (testfile-mctv1a)) (get-ctv x)) 'xuko1) 6210 (begin 6211 (with-output-to-file "testfile-mctv2.ss" 6212 (lambda () 6213 (pretty-print 6214 '(module mctv-m2 (x) 6215 (define-syntax x (make-compile-time-value 'xuko2))))) 6216 'replace) 6217 (for-each separate-compile '(mctv2)) 6218 (load "testfile-mctv2.so") 6219 #t) 6220 (eq? (let () (import mctv-m2) (get-ctv x)) 'xuko2) 6221 (begin 6222 (with-output-to-file "testfile-mctv3.ss" 6223 (lambda () 6224 (pretty-print 6225 '(define-syntax mctv3-x (make-compile-time-value 'xuko3)))) 6226 'replace) 6227 (for-each separate-compile '(mctv3)) 6228 (load "testfile-mctv3.so") 6229 #t) 6230 (eq? (get-ctv mctv3-x) 'xuko3) 6231 (begin 6232 (with-output-to-file "testfile-mctv4.ss" 6233 (lambda () 6234 (printf "#! /usr/bin/env scheme-script\n") 6235 (pretty-print '(import (chezscheme) (testfile-mctv0))) 6236 (pretty-print '(define spod)) 6237 (pretty-print '(define qrtz)) 6238 (pretty-print '(define xptz)) 6239 (pretty-print '(define-syntax x (make-compile-time-value 'xuko4))) 6240 (pretty-print '(define-property x spod "shuff")) 6241 (pretty-print '(define-property x qrtz "dmnd")) 6242 (pretty-print '(printf "~s ~s ~s ~s ~s\n" 6243 (get-property get-property spod) 6244 (get-property x spod) 6245 (get-property x qrtz) 6246 (get-property x xptz) 6247 (get-ctv x)))) 6248 'replace) 6249 (for-each (lambda (x) (separate-compile 'compile-program x)) '(mctv4)) 6250 #t) 6251 (equal? 6252 (with-output-to-string 6253 (lambda () 6254 (load-program "testfile-mctv4.ss"))) 6255 "#f \"shuff\" \"dmnd\" #f xuko4\n") 6256 (equal? 6257 (with-output-to-string 6258 (lambda () 6259 (load-program "testfile-mctv4.so"))) 6260 "#f \"shuff\" \"dmnd\" #f xuko4\n") 6261 (eqv? 6262 (let () 6263 (define foo 3) 6264 (define-syntax alpha (make-compile-time-value #'foo)) 6265 (define-syntax beta 6266 (lambda (x) 6267 (lambda (r) 6268 (r #'alpha)))) 6269 (let () 6270 (define foo 4) 6271 beta)) 6272 3) 6273 (eqv? 6274 (let () 6275 (define foo 3) 6276 (define-syntax alpha 6277 (lambda (x) 6278 (syntax-case x () 6279 [(_ id) #'(define-syntax id (make-compile-time-value #'foo))]))) 6280 (let () 6281 (define foo 4) 6282 (alpha beta) 6283 (define-syntax gamma 6284 (lambda (x) 6285 (lambda (r) 6286 (r #'beta)))) 6287 gamma)) ;=> 3 6288 3) 6289 #; ; decided not to have rebuild-macro-output delve into records... 6290 (eqv? 6291 (let () 6292 (meta define-record-type rats (fields cheese)) 6293 (define foo 3) 6294 (define-syntax alpha 6295 (lambda (x) 6296 (syntax-case x () 6297 [(_ id) 6298 #`(define-syntax id 6299 (make-compile-time-value '#,(make-rats #'foo)))]))) 6300 (let () 6301 (define foo 4) 6302 (alpha beta) 6303 (define-syntax gamma 6304 (lambda (x) 6305 (lambda (r) 6306 #`(let () 6307 (define foo 5) 6308 #,(rats-cheese (r #'beta)))))) 6309 gamma)) 6310 3) 6311 #; ; decided not to have rebuild-macro-output delve into records... 6312 (eqv? 6313 (let () 6314 (meta define-record-type rats (fields cheese)) 6315 (define foo 3) 6316 (define-syntax alpha 6317 (lambda (x) 6318 (syntax-case x () 6319 [(_ id) 6320 #`(module (id) 6321 (define foo 3.5) 6322 (define-syntax id 6323 (make-compile-time-value '#,(make-rats #'foo))))]))) 6324 (let () 6325 (define foo 4) 6326 (alpha beta) 6327 (define-syntax gamma 6328 (lambda (x) 6329 (lambda (r) 6330 #`(let () 6331 (define foo 5) 6332 #,(rats-cheese (r #'beta)))))) 6333 gamma)) 6334 3.5) 6335 (eqv? 6336 (let () 6337 (meta define make-rats list) 6338 (meta define rats-cheese car) 6339 (define foo 3) 6340 (define-syntax alpha 6341 (lambda (x) 6342 (syntax-case x () 6343 [(_ id) 6344 #`(module (id) 6345 (define foo 3.5) 6346 (define-syntax id 6347 (make-compile-time-value #'#,(make-rats #'foo))))]))) 6348 (let () 6349 (define foo 4) 6350 (alpha beta) 6351 (define-syntax gamma 6352 (lambda (x) 6353 (lambda (r) 6354 #`(let () 6355 (define foo 5) 6356 #,(syntax-case (r #'beta) () 6357 [(foo) #'foo]))))) 6358 gamma)) 6359 3.5) 6360) 6361 6362(mat define-property 6363 (begin 6364 (library (dp get-property) (export get-property) (import (scheme)) 6365 (define-syntax get-property 6366 (lambda (x) 6367 (lambda (r) 6368 (syntax-case x () 6369 [(_ q prop) #`'#,(datum->syntax #'* (r #'q #'prop))]))))) 6370 (import (dp get-property)) 6371 #t) 6372 (begin 6373 (define-property cons frotz 'spamgle) 6374 (equal? 6375 (cons (get-property cons frotz) (get-property cons fratz)) 6376 '(spamgle . #f))) 6377 (equal? 6378 (cons (get-property cons frotz) (get-property cons fratz)) 6379 '(spamgle . #f)) 6380 (equal? 6381 (let () 6382 (import scheme) 6383 (cons (get-property cons frotz) (get-property cons fratz))) 6384 (if (free-identifier=? #'cons (let () (import scheme) #'cons)) 6385 '(spamgle . #f) 6386 '(#f . #f))) 6387 (equal? 6388 (let () 6389 (define-property cons fratz 'yubah) 6390 (cons (get-property cons frotz) (get-property cons fratz))) 6391 '(spamgle . yubah)) 6392 (equal? 6393 (cons (get-property cons frotz) (get-property cons fratz)) 6394 '(spamgle . #f)) 6395 ; restore 6396 (begin 6397 (meta-cond 6398 [(free-identifier=? #'cons (let () (import scheme) #'cons)) 6399 (import (only scheme cons))] 6400 [else (define cons (let () (import scheme) cons))]) 6401 #t) 6402 (equal? 6403 (cons (get-property cons frotz) (get-property cons fratz)) 6404 '(#f . #f)) 6405 (equal? 6406 (let () 6407 (import scheme) 6408 (cons (get-property cons frotz) (get-property cons fratz))) 6409 '(#f . #f)) 6410 (equal? 6411 (let () 6412 (import scheme) 6413 (define-property list type "procedure") 6414 (list (get-property list type) (get-property car type))) 6415 '("procedure" #f)) 6416 (equal? 6417 (let () 6418 (define list (lambda x x)) 6419 (define-property list type "procedure") 6420 (list (get-property list type) (get-property car type))) 6421 '("procedure" #f)) 6422 (error? ; multiple definitions for list 6423 (let () 6424 (define-property list type "procedure") 6425 (define list (lambda x x)) 6426 (list (get-property list type) (get-property car type)))) 6427 (error? ; multiple definitions for list 6428 (module m (list) 6429 (define-property list type "procedure") 6430 (define list (lambda x x)) 6431 (list (get-property list type) (get-property car type)))) 6432 (error? ; immutable environment 6433 (eval '(define-property frot rat 3) (scheme-environment))) 6434 (error? ; immutable environment 6435 (eval '(define-property cons rat 3) (scheme-environment))) 6436 (error? ; no visible binding 6437 (eval '(let () (define-property frot cons 3) 3) (scheme-environment))) 6438 (error? ; no visible binding 6439 (eval '(let () (define-property cons rat 3) 3) (scheme-environment))) 6440 (error? ; no visible binding 6441 (library (dp err1) (export x) (import (scheme)) 6442 (define-property x cons "frap"))) 6443 (error? ; no visible binding 6444 (library (dp err1) (export x) (import (scheme)) 6445 (define-property cons frip "frap"))) 6446 (error? ; no visible binding 6447 (module (x) (import-only (scheme)) 6448 (define-property x cons "frap"))) 6449 (error? ; no visible binding 6450 (module (x) (import-only (scheme)) 6451 (define-property cons frip "frap"))) 6452 (not (get-property list type)) 6453 (equal? 6454 (let () 6455 (define type) 6456 (define-property list type "proc") 6457 (list 6458 (get-property list type) 6459 (let () (define type) (get-property list type)))) 6460 '("proc" #f)) 6461 (equal? 6462 (let () 6463 (module (type iface list) 6464 (define type) 6465 (define iface) 6466 (define-property list type "a proc") 6467 (define-property list iface -1)) 6468 (list 6469 (get-property list type) 6470 (get-property list iface))) 6471 '("a proc" -1)) 6472 (equal? 6473 (let () 6474 (module (type list) 6475 (define type) 6476 (define iface) 6477 (define-property list type "a proc") 6478 (define-property list iface -1)) 6479 (list 6480 (get-property list type) 6481 (get-property list iface))) 6482 '("a proc" #f)) 6483 (equal? 6484 (let () 6485 (module (iface list) 6486 (define type) 6487 (define iface) 6488 (define-property list type "a proc") 6489 (define-property list iface -1)) 6490 (list 6491 (get-property list type) 6492 (get-property list iface))) 6493 '(#f -1)) 6494 (equal? 6495 (let () 6496 (module (list) 6497 (define type) 6498 (define iface) 6499 (define-property list type "a proc") 6500 (define-property list iface -1)) 6501 (list 6502 (get-property list type) 6503 (get-property list iface))) 6504 '(#f #f)) 6505 (equal? 6506 (let () 6507 (module (type iface) 6508 (define type) 6509 (define iface) 6510 (define-property list type "a proc") 6511 (define-property list iface -1)) 6512 (list 6513 (get-property list type) 6514 (get-property list iface))) 6515 '(#f #f)) 6516 (begin 6517 (define dp-out (open-output-string)) 6518 (module dp-m1 (x) 6519 (import (scheme) (dp get-property)) 6520 (define x 444) 6521 (define-property x frob "x-frob") 6522 (define-property x spam "x-spam") 6523 (fprintf dp-out "~s ~s ~s ~s\n" 6524 (get-property x spam) 6525 (get-property x frob) 6526 (get-property x rats) 6527 x)) 6528 (equal? 6529 (get-output-string dp-out) 6530 "\"x-spam\" \"x-frob\" #f 444\n")) 6531 (equal? 6532 (let () 6533 (import dp-m1) 6534 (list 6535 (get-property x spam) 6536 (get-property x frob) 6537 (get-property x rats) 6538 x)) 6539 '("x-spam" "x-frob" #f 444)) 6540 (begin 6541 (define dp-out (open-output-string)) 6542 (module dp-m1 () 6543 (import (scheme) (dp get-property)) 6544 (define-property dp-out spam "dp-out-spam") 6545 (define-property dp-out frob "dp-out-frob") 6546 (fprintf dp-out "~s ~s ~s\n" 6547 (get-property dp-out spam) 6548 (get-property dp-out frob) 6549 (get-property dp-out rats))) 6550 (and 6551 (equal? 6552 (get-output-string dp-out) 6553 "\"dp-out-spam\" \"dp-out-frob\" #f\n") 6554 (not (get-property dp-out spam)) 6555 (not (get-property dp-out frob)))) 6556 (equal? 6557 (let () 6558 (import dp-m1) 6559 (list 6560 (get-property x spam) 6561 (get-property x frob) 6562 (get-property x rats))) 6563 '(#f #f #f)) 6564 (begin 6565 (module dp-m1 (m2 (f x y)) 6566 (import (scheme) (dp get-property)) 6567 (define y "yval") 6568 (define-property y a "y-a") 6569 (module m2 (x) 6570 (define x "xval") 6571 (define-property x a "x-a") 6572 (define-property y b "y-b")) 6573 (import m2) 6574 (define-property x b "x-b") 6575 (define-syntax f 6576 (identifier-syntax 6577 (list (list x (get-property x a) (get-property x b)) 6578 (list y (get-property y a) (get-property y b)))))) 6579 #t) 6580 (equal? 6581 (let () (import dp-m1) f) 6582 '(("xval" "x-a" "x-b") ("yval" "y-a" #f))) 6583 (equal? 6584 (let () 6585 (import dp-m1) 6586 (import m2) 6587 (list 6588 (get-property x a) 6589 (get-property x b) 6590 (get-property x c) 6591 x)) 6592 '("x-a" #f #f "xval")) 6593 (begin 6594 (library (dp l1) (export x spam frob rats) (import (scheme) (dp get-property)) 6595 (define spam) 6596 (define frob) 6597 (define rats) 6598 (define x (make-parameter 444)) 6599 (define-property x spam "x-spam") 6600 (define-property x frob "x-frob") 6601 (printf "~s ~s ~s ~s\n" 6602 (get-property x spam) 6603 (get-property x frob) 6604 (get-property x rats) 6605 (x))) 6606 #t) 6607 (begin (define dp-f) #t) 6608 (equal? 6609 (with-output-to-string 6610 (lambda () 6611 (set! dp-f 6612 (eval 6613 '(lambda () 6614 (import (dp l1)) 6615 (printf "~s ~s ~s ~s\n" 6616 (get-property x spam) 6617 (get-property x frob) 6618 (get-property x rats) 6619 (x))))))) 6620 "\"x-spam\" \"x-frob\" #f 444\n") 6621 (equal? 6622 (with-output-to-string 6623 (lambda () 6624 (dp-f))) 6625 "\"x-spam\" \"x-frob\" #f 444\n") 6626 (begin 6627 (library (dp l1) (export x spam frob rats) (import (scheme) (dp get-property)) 6628 (define spam) 6629 (define frob) 6630 (define rats) 6631 (define-syntax x 6632 (identifier-syntax 6633 (list 6634 (get-property x spam) 6635 (get-property x frob) 6636 (get-property x rats)))) 6637 (define-property x spam "x-spam") 6638 (define-property x frob "x-frob") 6639 (printf "~s ~s ~s ~s\n" 6640 (get-property x spam) 6641 (get-property x frob) 6642 (get-property x rats) 6643 x)) 6644 #t) 6645 (begin (define dp-f) #t) 6646 (equal? 6647 (with-output-to-string 6648 (lambda () 6649 (set! dp-f 6650 (eval 6651 '(lambda () 6652 (import (dp l1)) 6653 (printf "~s ~s ~s ~s\n" 6654 (get-property x spam) 6655 (get-property x frob) 6656 (get-property x rats) 6657 x)))))) 6658 "") 6659 (equal? 6660 (with-output-to-string 6661 (lambda () 6662 (dp-f))) 6663 "\"x-spam\" \"x-frob\" #f (\"x-spam\" \"x-frob\" #f)\n") 6664 (begin 6665 (library (dp l1) (export x qq spam frob rats) (import (scheme) (dp get-property)) 6666 (define spam) 6667 (define frob) 6668 (define rats) 6669 (define qq (make-parameter 33)) 6670 (define-syntax x 6671 (identifier-syntax 6672 (list 6673 (get-property x spam) 6674 (get-property x frob) 6675 (get-property x rats)))) 6676 (define-property x spam "x-spam") 6677 (define-property x frob "x-frob") 6678 (printf "~s ~s ~s ~s\n" 6679 (get-property x spam) 6680 (get-property x frob) 6681 (get-property x rats) 6682 x)) 6683 #t) 6684 (begin (define dp-f) #t) 6685 (equal? 6686 (with-output-to-string 6687 (lambda () 6688 (set! dp-f 6689 (eval 6690 '(lambda () 6691 (import (dp l1)) 6692 (printf "~s ~s ~s ~s ~s\n" 6693 (get-property x spam) 6694 (get-property x frob) 6695 (get-property x rats) 6696 x (qq))))))) 6697 "\"x-spam\" \"x-frob\" #f (\"x-spam\" \"x-frob\" #f)\n") 6698 (equal? 6699 (with-output-to-string 6700 (lambda () 6701 (dp-f))) 6702 "\"x-spam\" \"x-frob\" #f (\"x-spam\" \"x-frob\" #f) 33\n") 6703 (begin 6704 (library (dp l1) (export qq spam frob rats) (import (scheme) (dp get-property)) 6705 (define spam) 6706 (define frob) 6707 (define rats) 6708 (define qq (make-parameter 77)) 6709 (define x (make-parameter 444)) 6710 (define-property x spam "x-spam") 6711 (define-property x frob "x-frob") 6712 (printf "~s ~s ~s ~s\n" 6713 (get-property x spam) 6714 (get-property x frob) 6715 (get-property x rats) 6716 (x))) 6717 #t) 6718 (begin (define dp-f) #t) 6719 (equal? 6720 (with-output-to-string 6721 (lambda () 6722 (set! dp-f 6723 (eval 6724 '(lambda (x) 6725 (import (dp l1)) 6726 (printf "~s ~s ~s ~s\n" 6727 (get-property x spam) 6728 (get-property x frob) 6729 (get-property x rats) 6730 (qq))))))) 6731 "\"x-spam\" \"x-frob\" #f 444\n") 6732 (equal? 6733 (with-output-to-string 6734 (lambda () 6735 (dp-f 0))) 6736 "#f #f #f 77\n") 6737 (begin 6738 (module (dp-a) 6739 (module (dp-a) 6740 (define-syntax dp-a (identifier-syntax 3))) 6741 (define-property dp-a spam 55)) 6742 (and (eqv? dp-a 3) 6743 (eqv? (get-property dp-a spam) 55))) 6744 (begin 6745 (module (dp-b) 6746 (module ((dp-b q)) 6747 (define q 3) 6748 (define-syntax dp-b (identifier-syntax q))) 6749 (define-property dp-b spam 55)) 6750 (and (eqv? dp-b 3) 6751 (eqv? (get-property dp-b spam) 55))) 6752 (let () 6753 (module (dp-c) 6754 (module (dp-c) 6755 (define-syntax dp-c (identifier-syntax 3))) 6756 (define-property dp-c spam 55)) 6757 (and (eqv? dp-c 3) 6758 (eqv? (get-property dp-c spam) 55))) 6759 (let () 6760 (module (dp-c) 6761 (module ((dp-c q)) 6762 (define q 3) 6763 (define-syntax dp-c (identifier-syntax q))) 6764 (define-property dp-c spam 55)) 6765 (and (eqv? dp-c 3) 6766 (eqv? (get-property dp-c spam) 55))) 6767 (begin 6768 (library (dp l2) (export dp-d dp-e spam) (import (scheme)) 6769 (define spam) 6770 (module (dp-d) 6771 (module (dp-d) 6772 (define-syntax dp-d (identifier-syntax 3))) 6773 (define-property dp-d spam 55)) 6774 (module (dp-e) 6775 (module ((dp-e q)) 6776 (define q 13) 6777 (define-syntax dp-e (identifier-syntax q))) 6778 (define-property dp-e spam 155))) 6779 (let () 6780 (import (dp l2)) 6781 (and (eqv? dp-d 3) 6782 (eqv? (get-property dp-d spam) 55) 6783 (eqv? dp-e 13) 6784 (eqv? (get-property dp-e spam) 155)))) 6785 (begin 6786 (import (dp l2)) 6787 (and (eqv? dp-d 3) 6788 (eqv? (get-property dp-d spam) 55) 6789 (eqv? dp-e 13) 6790 (eqv? (get-property dp-e spam) 155))) 6791 (begin 6792 (with-output-to-file "testfile-dp0.ss" 6793 (lambda () 6794 (pretty-print '(define $dp0-x "dp0-x")) 6795 (pretty-print '(define-property $dp0-x dp0 17))) 6796 'replace) 6797 (with-output-to-file "testfile-dp1.ss" 6798 (lambda () 6799 (pretty-print 6800 '(library (testfile-dp1) 6801 (export cons a b spud) 6802 (import (scheme)) 6803 (define spud) 6804 (define a "a") 6805 (define b "b") 6806 (define-property cons spud "spud-cons") 6807 (define-property a spud "spud-a") 6808 (define-property b spud "spud-b")))) 6809 'replace) 6810 (with-output-to-file "testfile-dp2.ss" 6811 (lambda () 6812 (pretty-print 6813 '(module dp2 (cons a b putz) 6814 (import (scheme)) 6815 (define putz) 6816 (define a "a") 6817 (define b "b") 6818 (define-property cons putz "putz-cons") 6819 (define-property a putz "putz-a") 6820 (define-property b putz "putz-b")))) 6821 'replace) 6822 (for-each separate-compile '(dp0 dp1 dp2)) 6823 #t) 6824 (begin (load "testfile-dp0.so") #t) 6825 (equal? $dp0-x "dp0-x") 6826 (equal? (get-property $dp0-x dp0) 17) 6827 (equal? 6828 (let () 6829 (import (testfile-dp1)) 6830 (list (cons a b) (get-property cons spud) (get-property a spud) (get-property b spud))) 6831 '(("a" . "b") "spud-cons" "spud-a" "spud-b")) 6832 (begin (load "testfile-dp2.so") #t) 6833 (equal? 6834 (let () 6835 (import dp2) 6836 (list (cons a b) (get-property cons putz) (get-property a putz) (get-property b putz))) 6837 '(("a" . "b") "putz-cons" "putz-a" "putz-b")) 6838 ; illustrate use of define-property for storing parent record info, 6839 ; while still allowing the record name to be a variable whose value 6840 ; is the record type descriptor 6841 (equal? 6842 (let () 6843 (module (drt) 6844 (define drt-key) 6845 (define-syntax drt 6846 (lambda (x) 6847 (define construct-name 6848 (lambda (template-identifier . args) 6849 (datum->syntax template-identifier 6850 (string->symbol 6851 (apply string-append 6852 (map (lambda (x) 6853 (if (string? x) 6854 x 6855 (symbol->string (syntax->datum x)))) 6856 args)))))) 6857 (define do-drt 6858 (lambda (rname fname* prtd) 6859 (with-syntax ([rname rname] 6860 [rtd (make-record-type-descriptor 6861 (syntax->datum rname) prtd #f #f #f 6862 (list->vector (map (lambda (fname) `(immutable ,(syntax->datum fname))) fname*)))] 6863 [make-rname (construct-name rname "make-" rname)] 6864 [rname? (construct-name rname rname "?")] 6865 [(rname-fname ...) 6866 (map (lambda (fname) (construct-name fname rname "-" fname)) 6867 fname*)] 6868 [(i ...) (enumerate fname*)]) 6869 #'(begin 6870 (define rname 'rtd) 6871 (define rcd (make-record-constructor-descriptor 'rtd #f #f)) 6872 (define-property rname drt-key 'rtd) 6873 (define make-rname (record-constructor rcd)) 6874 (define rname? (record-predicate 'rtd)) 6875 (define rname-fname (record-accessor 'rtd i)) 6876 ...)))) 6877 (syntax-case x (parent) 6878 [(_ rname fname ...) 6879 (for-all identifier? #'(rname fname ...)) 6880 (do-drt #'rname #'(fname ...) #f)] 6881 [(_ rname (parent pname) fname ...) 6882 (for-all identifier? #'(rname pname fname ...)) 6883 (lambda (r) 6884 (let ([prtd (r #'pname #'drt-key)]) 6885 (unless prtd (syntax-error #'pname "unrecognized parent record typd")) 6886 (do-drt #'rname #'(fname ...) prtd)))])))) 6887 (drt foo x y) 6888 (drt bar (parent foo) z) 6889 (let ([b (make-bar 1 2 3)]) 6890 (list 6891 (record-type-descriptor? foo) 6892 (record-type-descriptor? bar) 6893 (foo? b) (bar? b) 6894 (foo-x b) 6895 (foo-y b) 6896 (bar-z b)))) 6897 '(#t #t #t #t 1 2 3)) 6898 ; on no! 6899 (equal? 6900 (let () 6901 (define type-key) 6902 (define-syntax declare 6903 (syntax-rules () 6904 [(_ type id) 6905 (identifier? #'id) 6906 (define-property id type-key #'type)])) 6907 (define-syntax type-of 6908 (lambda (x) 6909 (syntax-case x () 6910 [(_ id) 6911 (identifier? #'id) 6912 (lambda (r) 6913 #`'#,(r #'id #'type-key))]))) 6914 (let ([x 3]) 6915 (define p (lambda (x) x)) 6916 (declare fixnum? x) 6917 (declare procedure? p) 6918 (list (type-of x) (type-of p)))) 6919 '(fixnum? procedure?)) 6920 ; make sure library is visited and invoked when needed by 6921 ; top-level-xxx procedures, even when properties are defined 6922 (begin 6923 (with-output-to-file "testfile-dp3.ss" 6924 (lambda () 6925 (pretty-print 6926 '(library (testfile-dp3) (export dp3-x frop) (import (chezscheme)) 6927 (define frop) 6928 (define dp3-x 3) 6929 (define-property dp3-x frop "blob")))) 6930 'replace) 6931 (for-each separate-compile '(dp3)) 6932 #t) 6933 (begin (import (testfile-dp3)) #t) 6934 (top-level-bound? 'dp3-x) 6935 (equal? (get-property dp3-x frop) "blob") 6936 (begin 6937 (with-output-to-file "testfile-dp4.ss" 6938 (lambda () 6939 (pretty-print 6940 '(library (testfile-dp4) (export dp4-x frop) (import (chezscheme)) 6941 (define frop) 6942 (define dp4-x 3) 6943 (define-property dp4-x frop "blob")))) 6944 'replace) 6945 (for-each separate-compile '(dp4)) 6946 #t) 6947 (begin (import (testfile-dp4)) #t) 6948 (eqv? (top-level-value 'dp4-x) 3) 6949 (equal? (get-property dp4-x frop) "blob") 6950 (begin 6951 (with-output-to-file "testfile-dp5.ss" 6952 (lambda () 6953 (pretty-print 6954 '(library (testfile-dp5) (export dp5-x frop) (import (chezscheme)) 6955 (define frop) 6956 (define dp5-x 3) 6957 (define-property dp5-x frop "blob")))) 6958 'replace) 6959 (for-each separate-compile '(dp5)) 6960 #t) 6961 (begin (import (testfile-dp5)) #t) 6962 ; same as last, but reverse order of checks 6963 (equal? (get-property dp5-x frop) "blob") 6964 (eqv? (top-level-value 'dp5-x) 3) 6965 (begin 6966 (with-output-to-file "testfile-dp6.ss" 6967 (lambda () 6968 (pretty-print 6969 '(library (testfile-dp6) (export dp6-x frop) (import (chezscheme)) 6970 (define frop) 6971 (define-syntax dp6-x (identifier-syntax 3)) 6972 (define-property dp6-x frop "blob")))) 6973 'replace) 6974 (for-each separate-compile '(dp6)) 6975 #t) 6976 (begin (import (testfile-dp6)) #t) 6977 (top-level-syntax? 'dp6-x) 6978 (equal? (get-property dp6-x frop) "blob") 6979 (begin 6980 (with-output-to-file "testfile-dp7.ss" 6981 (lambda () 6982 (pretty-print 6983 '(library (testfile-dp7) (export dp7-x frop) (import (chezscheme)) 6984 (define frop) 6985 (define-syntax dp7-x (identifier-syntax 3)) 6986 (define-property dp7-x frop "blob")))) 6987 'replace) 6988 (for-each separate-compile '(dp7)) 6989 #t) 6990 (begin (import (testfile-dp7)) #t) 6991 ; same as last, but reverse order of checks 6992 (equal? (get-property dp7-x frop) "blob") 6993 (top-level-syntax? 'dp7-x) 6994 (begin 6995 (with-output-to-file "testfile-dp8.ss" 6996 (lambda () 6997 (pretty-print 6998 '(library (testfile-dp8) (export dp8-x frop) (import (chezscheme)) 6999 (define frop) 7000 (define-syntax dp8-x (identifier-syntax 3)) 7001 (define-property dp8-x frop "blob")))) 7002 'replace) 7003 (for-each separate-compile '(dp8)) 7004 #t) 7005 (begin (import (testfile-dp8)) #t) 7006 ; same as last, but reverse order of checks 7007 (procedure? (top-level-syntax 'dp8-x)) 7008 (equal? (get-property dp8-x frop) "blob") 7009 (begin 7010 (with-output-to-file "testfile-dp9.ss" 7011 (lambda () 7012 (pretty-print 7013 '(library (testfile-dp9) (export dp9-x frop) (import (chezscheme)) 7014 (define frop) 7015 (define-syntax dp9-x (identifier-syntax 3)) 7016 (define-property dp9-x frop "blob")))) 7017 'replace) 7018 (for-each separate-compile '(dp9)) 7019 #t) 7020 (begin (import (testfile-dp9)) #t) 7021 (error? ; not a variable 7022 (set-top-level-value! 'dp9-x 11)) 7023 (equal? (get-property dp9-x frop) "blob") 7024 (begin 7025 (with-output-to-file "testfile-dp10.ss" 7026 (lambda () 7027 (pretty-print 7028 '(library (testfile-dp10) (export dp10-x frop) (import (chezscheme)) 7029 (define frop) 7030 (define dp10-x 3) 7031 (define-property dp10-x frop "blob")))) 7032 'replace) 7033 (for-each separate-compile '(dp10)) 7034 #t) 7035 (begin (import (testfile-dp10)) #t) 7036 (error? ; immutable 7037 (set-top-level-value! 'dp10-x 11)) 7038 (equal? (get-property dp10-x frop) "blob") 7039 (begin 7040 (with-output-to-file "testfile-dp11.ss" 7041 (lambda () 7042 (pretty-print 7043 '(library (testfile-dp11) (export dp11-x frop) (import (chezscheme)) 7044 (define frop) 7045 (define dp11-x 3) 7046 (define-property dp11-x frop "blob")))) 7047 'replace) 7048 (for-each separate-compile '(dp11)) 7049 #t) 7050 (begin (import (testfile-dp11)) #t) 7051 (not (top-level-mutable? 'dp11-x)) 7052 (equal? (get-property dp11-x frop) "blob") 7053 (equal? 7054 (syntax-case '(a b c) () 7055 [(_ . x) 7056 (let () 7057 (define-property x goofy 'stuff) 7058 (define-property x amazingly 'unlikely) 7059 (list (get-property x goofy) 7060 (get-property x amazingly) 7061 #'x))]) 7062 '(stuff unlikely (b c))) 7063 (begin 7064 (library (docstring) 7065 (export define-docstring get-docstring) 7066 (import (chezscheme)) 7067 (define check-docstring 7068 (lambda (x s) 7069 (unless (string? s) 7070 (syntax-error x "invalid docstring definition")) 7071 s)) 7072 (define-syntax define-docstring 7073 (lambda (x) 7074 (syntax-case x () 7075 [(_ id expr) 7076 #`(define-property id check-docstring 7077 (check-docstring #'#,x expr))]))) 7078 (define-syntax get-docstring 7079 (lambda (x) 7080 (lambda (r) 7081 (syntax-case x () 7082 [(_ id) 7083 (or (r #'id #'check-docstring) "no documentation available")]))))) 7084 #t) 7085 (equal? 7086 (let () 7087 (import (docstring)) 7088 (define-docstring cons "cons takes three arguments") 7089 (get-docstring cons)) 7090 "cons takes three arguments") 7091 (equal? 7092 (let () 7093 (import (docstring)) 7094 (define-docstring else "else is cool") 7095 (cond [else (get-docstring else)])) 7096 "else is cool") 7097 ((lambda (x ls) (and (member x ls) #t)) 7098 (parameterize ([#%$suppress-primitive-inlining #f]) 7099 (expand 7100 '(let () 7101 (import scheme) 7102 (define-property cons car 3) 7103 cons))) 7104 `(#%cons #2%cons #3%cons)) 7105 (begin 7106 (define dp-x #f) 7107 (define dp-y #f) 7108 (define-property dp-x dp-y "xy") 7109 (define-syntax a 7110 (lambda (z) 7111 (define-property dp-x z "xz") 7112 #'(get-property dp-x dp-y))) 7113 (equal? a "xy")) 7114 (begin 7115 (define dp-x #f) 7116 (define dp-y #f) 7117 (define-property dp-x dp-y "outer") 7118 (define-syntax a 7119 (lambda (z) 7120 (define-property dp-x dp-y "inner") 7121 #'(get-property dp-x dp-y))) 7122 (not a)) 7123 (equal? 7124 (let ([x #f] [y #f]) 7125 (define-property x y "xy") 7126 (define-syntax a 7127 (lambda (z) 7128 (define-property x z "xz") 7129 #'(get-property x y))) 7130 a) 7131 "xy") 7132 (eq? 7133 (let ([x #f] [y #f]) 7134 (define-property x y "outer") 7135 (define-syntax a 7136 (lambda (z) 7137 (define-property x y "inner") 7138 #'(get-property x y))) 7139 a) 7140 #f) 7141 (eq? 7142 (let ([x #f]) 7143 (define-syntax a 7144 (syntax-rules (x) 7145 [(_ x) 'yes] 7146 [(_ y) 'no])) 7147 (let () 7148 (define-property x q 0) 7149 (a x))) 7150 'yes) 7151 (begin 7152 (library (dp l3) (export x) 7153 (import (chezscheme)) 7154 (define x 5) 7155 (define-property x car 17)) 7156 (import (dp l3)) 7157 (and (eqv? x 5) (eqv? (let () (import (chezscheme)) (get-property x car)) 17))) 7158 (begin 7159 (library (dp l4) (export sort) 7160 (import (chezscheme)) 7161 (define-property sort car 53)) 7162 (library (dp l5) (export sort) 7163 (import (chezscheme)) 7164 (define-property sort cdr 87)) 7165 (import (dp l4)) 7166 (import (dp l5)) 7167 (and (procedure? sort) 7168 (eq? sort #%sort) 7169 (eqv? (let () (import (only (chezscheme) car)) (get-property sort car)) 53) 7170 (eqv? (let () (import (only (chezscheme) cdr)) (get-property sort cdr)) 87))) 7171 (begin 7172 (with-output-to-file "testfile-dp12.ss" 7173 (lambda () 7174 (pretty-print 7175 '(library (testfile-dp12) (export dp12-dq) (import (chezscheme)) 7176 (define-syntax dp12-dq (identifier-syntax "dq")) 7177 (define-property dp12-dq car "dqp")))) 7178 'replace) 7179 (for-each separate-compile '(dp12)) 7180 #t) 7181 (begin (import (testfile-dp12)) #t) 7182 (equal? (list dp12-dq (let () (import (chezscheme)) (get-property dp12-dq car))) '("dq" "dqp")) 7183 (equal? 7184 (let () 7185 (define x 0) 7186 (module m1 (x) (define-property x car "xcar")) 7187 (module m2 (x) (define-property x cdr "xcdr")) 7188 (let ([q1 (let () (import m1) (list x (get-property x car) (get-property x cdr)))] 7189 [q2 (let () (import m2) (list x (get-property x car) (get-property x cdr)))] 7190 [q3 (let () (import m1) (import m2) (list x (get-property x car) (get-property x cdr)))] 7191 [q4 (let () (import m2) (import m1) (list x (get-property x car) (get-property x cdr)))]) 7192 (list x q1 q2 q3 q4 (get-property x car) (get-property x cdr)))) 7193 '(0 (0 "xcar" #f) (0 #f "xcdr") (0 "xcar" "xcdr") (0 "xcar" "xcdr") #f #f)) 7194 (equal? 7195 (let () 7196 (define x 0) 7197 (module m1 (x) (define-property x car "xcar")) 7198 (import m1) 7199 (module m2 (x) (define-property x cdr "xcdr")) 7200 (import m2) 7201 (list x (get-property x car) (get-property x cdr))) 7202 '(0 "xcar" "xcdr")) 7203 (begin 7204 (module $dp13 (foo) 7205 (define foo 17) 7206 (module ((foo bar)) 7207 (define-property foo cons #'bar) 7208 (define bar 35))) 7209 #t) 7210 (eqv? 7211 (let () 7212 (import $dp13) 7213 (define-syntax a 7214 (lambda (x) 7215 (lambda (r) 7216 (syntax-case x () 7217 [(_ id) (r #'id #'cons)])))) 7218 (a foo)) 7219 35) 7220 (eqv? 7221 (let () 7222 (module m (x) (define x 3) (define-property x x 4)) 7223 (import m) 7224 (get-property x x)) 7225 4) 7226 (eqv? 7227 (let () 7228 (module m (x) (define x 3) (define-property x x 4)) 7229 (import (alias m (x y))) 7230 (get-property x x)) 7231 4) 7232 (eqv? 7233 (let () 7234 (module m (x) (define x 3) (define-property x x 4)) 7235 (import (alias m (x y))) 7236 (get-property x y)) 7237 4) 7238 (eqv? 7239 (let () 7240 (module m (x) (define x 3) (define-property x x 4)) 7241 (import (alias m (x y))) 7242 (get-property y x)) 7243 4) 7244 (eqv? 7245 (let () 7246 (module m (x) (define x 3) (define-property x x 4)) 7247 (import (alias m (x y))) 7248 (get-property y y)) 7249 4) 7250 (eqv? 7251 (let () 7252 (module m (x) (define x 3) (define-property x x 4)) 7253 (import (rename m (x y))) 7254 (get-property y y)) 7255 4) 7256 (begin 7257 (module $dp14 (x) (define x 3) (define-property x x 4)) 7258 #t) 7259 (eqv? 7260 (let () 7261 (import $dp14) 7262 (get-property x x)) 7263 4) 7264 (eqv? 7265 (let () 7266 (import (alias $dp14 (x y))) 7267 (get-property x x)) 7268 4) 7269 (eqv? 7270 (let () 7271 (import (alias $dp14 (x y))) 7272 (get-property x y)) 7273 4) 7274 (eqv? 7275 (let () 7276 (import (alias $dp14 (x y))) 7277 (get-property y x)) 7278 4) 7279 (eqv? 7280 (let () 7281 (import (alias $dp14 (x y))) 7282 (get-property y y)) 7283 4) 7284 (eqv? 7285 (let () 7286 (import (rename $dp14 (x y))) 7287 (get-property y y)) 7288 4) 7289 (equal? 7290 (let ([y 14]) 7291 (define k1) 7292 (define k2) 7293 (module () 7294 (export x (rename (y x))) 7295 (define x 3) 7296 (define-property x k1 4) 7297 (define-property x k2 5) 7298 (alias y x)) 7299 (list x y (get-property x k1) (get-property x k2) (get-property y k1) (get-property y k2))) 7300 '(3 14 4 5 #f #f)) 7301 (error? ; attempt to export different bindings for x 7302 (let ([y 14]) 7303 (define k1) 7304 (define k2) 7305 (module () 7306 (export x (rename (y x))) 7307 (define x 3) 7308 (define-property x k1 4) 7309 (alias y x) 7310 (define-property x k2 5)) 7311 (list x y (get-property x k1) (get-property y k2)))) 7312 (begin 7313 (with-output-to-file "testfile-A.ss" 7314 (lambda () 7315 (pretty-print 7316 '(library (testfile-A) 7317 (export $testfile-A-x $testfile-A-prop-id) 7318 (import (scheme)) 7319 (define $testfile-A-x (cons 'a 'b)) 7320 (define $testfile-A-prop-id) 7321 (define-property $testfile-A-x $testfile-A-prop-id (cons 'c 'd))))) 7322 'replace) 7323 (with-output-to-file "testfile-B.ss" 7324 (lambda () 7325 (pretty-print 7326 '(library (testfile-B) 7327 (export) 7328 (import (scheme) (testfile-A)) 7329 (export (import (testfile-A)))))) 7330 'replace) 7331 (with-output-to-file "testfile-C.ss" 7332 (lambda () 7333 (pretty-print 7334 '(library (testfile-C) 7335 (export) 7336 (import (scheme) (testfile-A) (testfile-B)) 7337 (export (import (testfile-A)) (import (testfile-B)))))) 7338 'replace) 7339 (for-each separate-compile '(A B C)) 7340 #t) 7341 (equal? 7342 (let () 7343 (import (testfile-C)) 7344 (list $testfile-A-x (get-property $testfile-A-x $testfile-A-prop-id))) 7345 '((a . b) (c . d))) 7346) 7347 7348(mat library1 7349 (error? (compile-library "/file/not/there")) 7350 (error? (load-library "/file/not/there")) 7351 (error? ; abc is not a string 7352 (load-library 'abc)) 7353 (error? ; xxx is not a procedure 7354 (load-library "/file/not/there" 'xxx)) 7355 (error? ; 3 is not a string 7356 (parameterize ([source-directories '("/tmp" ".")]) (load-library 3))) 7357 (error? ; 3 is not a string 7358 (parameterize ([source-directories '("/tmp" ".")]) (load-library 3 values))) 7359 (begin 7360 (library ($l1-a) (export $l1-x) (import (scheme)) 7361 (module $l1-x (($l1-a $l1-b) $l1-c $l1-e) 7362 (define $l1-d 4) 7363 (define-syntax $l1-a (identifier-syntax (cons $l1-b $l1-y))) 7364 (define $l1-b 55) 7365 (define $l1-c (lambda () (* $l1-d $l1-y))) 7366 (define $l1-f 44) 7367 (define-syntax $l1-e (identifier-syntax $l1-f))) 7368 (define $l1-y 14)) 7369 #t) 7370 (equal? 7371 (let () (import ($l1-a)) (import $l1-x) (list $l1-a ($l1-c))) 7372 '((55 . 14) 56)) 7373 (begin 7374 (import ($l1-a)) 7375 #t) 7376 (begin 7377 (import $l1-x) 7378 #t) 7379 (equal? $l1-a '(55 . 14)) 7380 (equal? ($l1-c) 56) 7381 (error? ; unbound variable $l1-b 7382 $l1-b) 7383 (error? ; unbound variable $l1-d 7384 $l1-d) 7385 (error? ; unbound variable $l1-y 7386 $l1-y) 7387 (error? ; unexported identifier $l1-f 7388 $l1-e) 7389 (error? ; unbound variable $l1-f 7390 $l1-f) 7391 (equal? 7392 (let () (import ($l1-a)) (import $l1-x) (list $l1-a ($l1-c))) 7393 '((55 . 14) 56)) 7394 (begin 7395 (library ($l1-b) (export $l1-x) (import (scheme)) 7396 (module $l1-x ($l1-a $l1-c $l1-e) 7397 (define $l1-d 4) 7398 (define $l1-a (lambda () (cons $l1-b $l1-y))) 7399 (define $l1-b 55) 7400 (define $l1-c (lambda () (* $l1-d $l1-y))) 7401 (define $l1-f 44) 7402 (define $l1-e (lambda () $l1-f))) 7403 (define $l1-y 14)) 7404 #t) 7405 (equal? 7406 (let () (import ($l1-b)) (import $l1-x) (vector ($l1-a) ($l1-c) ($l1-e))) 7407 '#((55 . 14) 56 44)) 7408 (begin 7409 (import ($l1-b)) 7410 #t) 7411 (begin 7412 (import $l1-x) 7413 #t) 7414 (equal? ($l1-a) '(55 . 14)) 7415 (equal? ($l1-c) 56) 7416 (equal? ($l1-e) 44) 7417 (error? ; unbound variable $l1-b 7418 $l1-b) 7419 (error? ; unbound variable $l1-d 7420 $l1-d) 7421 (error? ; unbound variable $l1-y 7422 $l1-y) 7423 (error? ; unbound variable $l1-f 7424 $l1-f) 7425 (equal? 7426 (let () (import ($l1-b)) (import $l1-x) (vector ($l1-a) ($l1-c) ($l1-e))) 7427 '#((55 . 14) 56 44)) 7428 (begin 7429 (library ($l1-c) (export (rename (q $l1-q) (a:x $l1-x)) $l1-p) 7430 (import (scheme) (rename ($l1-a) ($l1-x a:x)) (rename ($l1-b) ($l1-x b:x))) 7431 (import (drop-prefix a:x $l1-) (prefix (drop-prefix b:x $l1-) b:)) 7432 (define-syntax q (identifier-syntax (list a (c) (b:a) (b:c) ($l1-p) (r)))) 7433 (define $l1-p (lambda () (vector a (c) (b:a) (b:c)))) 7434 (define r (lambda () (cons* a (c) (b:a) (b:c))))) 7435 #t) 7436 (equal? 7437 (let () (import ($l1-c)) $l1-q) 7438 '((55 . 14) 56 (55 . 14) 56 7439 #4((55 . 14) 56 (55 . 14) 56) 7440 ((55 . 14) 56 (55 . 14) . 56))) 7441 (equal? 7442 (let () (import ($l1-c) ($l1-a)) (import $l1-x) (list $l1-a $l1-q)) 7443 '((55 . 14) 7444 ((55 . 14) 56 (55 . 14) 56 7445 #4((55 . 14) 56 (55 . 14) 56) 7446 ((55 . 14) 56 (55 . 14) . 56)))) 7447 7448 (begin 7449 (library ($l1-d) (export $l1-x $l1-getx $l1-setx!) (import (scheme)) 7450 (define x 0) 7451 (define-syntax $l1-x (identifier-syntax x)) 7452 (define $l1-getx (lambda () x)) 7453 (define $l1-setx! (lambda (v) (set! x v)))) 7454 #t) 7455 (eqv? 7456 (let () (import ($l1-d)) ($l1-setx! 'hello) ($l1-getx)) 7457 'hello) 7458 (error? ; unexported identifier x 7459 (let () (import ($l1-d)) $l1-x)) 7460 (error? ; unexported identifier x 7461 (expand '(let () (import ($l1-d)) $l1-x))) 7462 (error? ; immutable variable $l1-x 7463 (let () (import ($l1-d)) (set! $l1-getx void))) 7464 (error? ; immutable variable $l1-x 7465 (expand '(let () (import ($l1-d)) (set! $l1-getx void)))) 7466 (begin 7467 (import ($l1-d)) 7468 #t) 7469 (eqv? 7470 (begin ($l1-setx! 'hello) ($l1-getx)) 7471 'hello) 7472 (error? ; unexported identifier x 7473 $l1-x) 7474 (error? ; unexported identifier x 7475 (expand '$l1-x)) 7476 (error? ; immutable variable $l1-x 7477 (set! $l1-getx void)) 7478 (error? ; immutable variable $l1-x 7479 (expand '(set! $l1-getx void))) 7480 7481 (error? 7482 (library ($l1-e) (export $l1-x) (import (scheme)) 7483 (define $l1-x 0) 7484 (set! $l1-x 1))) 7485 (error? 7486 (expand 7487 '(library ($l1-e) (export $l1-x) (import (scheme)) 7488 (define $l1-x 0) 7489 (set! $l1-x 1)))) 7490 7491 (begin 7492 (with-output-to-file "testfile.ss" 7493 (lambda () 7494 (pretty-print 7495 '(library ($l1-f) (export $l1-x $l1-y) (import (scheme)) 7496 (define-syntax $l1-x (identifier-syntax q)) 7497 (define-syntax q 7498 (begin 7499 (printf "An expand-time greeting from $l1-f\n") 7500 (lambda (x) 77))) 7501 (define $l1-y (lambda () (* q 2))) 7502 (printf "A run-time greeting from $l1-f\n"))) 7503 (pretty-print 7504 '(library ($l1-g) (export $l1-x $l1-z $l1-w) (import (scheme) ($l1-f)) 7505 (define-syntax $l1-z 7506 (begin 7507 (printf "An expand-time greeting from $l1-g\n") 7508 (lambda (x) ($l1-y)))) 7509 (define $l1-w 7510 (begin 7511 (printf "A run-time greeting from $l1-g\n") 7512 (lambda (x) (cons* x $l1-x ($l1-y))))))) 7513 (pretty-print 7514 '(library ($l1-h) (export $l1-x $l1-y $l1-v) (import (scheme) ($l1-f) ($l1-g)) 7515 (define $l1-v (list $l1-x ($l1-y) $l1-z ($l1-w 13))) 7516 (printf "A run-time greeting from $l1-h\n")))) 7517 'replace) 7518 (compile-file "testfile") 7519 #t) 7520 ; look, ma, no need to load... 7521 (equal? 7522 (let () (import ($l1-h)) $l1-v) 7523 '(77 154 154 (13 77 . 154))) 7524 (begin 7525 (library ($l1-h) (export $l1-x $l1-y $l1-v) (import (scheme)) 7526 (define $l1-x "these aren't") 7527 (define $l1-y "the exports") 7528 (define $l1-v "you're looking for")) 7529 #t) 7530 (begin (load "testfile.so") #t) 7531 (equal? 7532 (let () (import ($l1-h)) $l1-v) 7533 '(77 154 154 (13 77 . 154))) 7534 7535 (begin 7536 (with-output-to-file "testfile.ss" 7537 (lambda () 7538 (pretty-print 7539 '(library ($l1-f) (export $l1-x $l1-y) (import (scheme)) 7540 (define-syntax $l1-x (identifier-syntax q)) 7541 (define-syntax q 7542 (begin 7543 (printf "An expand-time greeting from $l1-f\n") 7544 (lambda (x) 77))) 7545 (define $l1-y (lambda () (* q 2))) 7546 (printf "A run-time greeting from $l1-f\n"))) 7547 (pretty-print 7548 '(library ($l1-g) (export $l1-x $l1-z $l1-w) (import (scheme) ($l1-f)) 7549 (define-syntax $l1-z 7550 (begin 7551 (printf "An expand-time greeting from $l1-g\n") 7552 (lambda (x) ($l1-y)))) 7553 (define $l1-w 7554 (begin 7555 (printf "A run-time greeting from $l1-g\n") 7556 (lambda (x) (cons* x $l1-z $l1-x ($l1-y))))))) 7557 (pretty-print 7558 '(library ($l1-h) (export $l1-x $l1-y $l1-v) (import (scheme) ($l1-f) ($l1-g)) 7559 (define $l1-v (list $l1-x ($l1-y) $l1-z ($l1-w 13))) 7560 (printf "A run-time greeting from $l1-h\n")))) 7561 'replace) 7562 (compile-file "testfile") 7563 #t) 7564 ; look, ma, no need to load... 7565 (equal? 7566 (let () (import ($l1-h)) $l1-v) 7567 '(77 154 154 (13 154 77 . 154))) 7568 (begin 7569 (library ($l1-h) (export $l1-x $l1-y $l1-v) (import (scheme)) 7570 (define $l1-x "these aren't") 7571 (define $l1-y "the exports") 7572 (define $l1-v "you're looking for")) 7573 #t) 7574 (begin (load "testfile.so") #t) 7575 (equal? 7576 (let () (import ($l1-h)) $l1-v) 7577 '(77 154 154 (13 154 77 . 154))) 7578 7579 (error? ; unknown library ($l1-ham) 7580 (begin 7581 (library ($l1-spam) (export) (import ($l1-ham))) 7582 (library ($l1-ham) (export) (import ($l1-spam))))) 7583 7584 (begin 7585 (with-output-to-file "testfile.ss" 7586 (lambda () 7587 (pretty-print 7588 '(library ($l1-i) (export $l1-x $l1-y) (import (scheme)) 7589 (define $l1-x 'i-am-x) 7590 (define-syntax $l1-y (identifier-syntax 'i-am-y)))) 7591 (pretty-print 7592 '(library ($l1-j) (export $l1-x $l1-y) 7593 (import ($l1-i) (only (scheme) errorf)) 7594 (errorf #f "this error shouldn't happen"))) 7595 (pretty-print 7596 '(library ($l1-k) (export $l1-z) (import (scheme) ($l1-j)) 7597 (define $l1-z (list 'i-am-z $l1-x $l1-y))))) 7598 'replace) 7599 (compile-file "testfile") 7600 #t) 7601 (equal? 7602 (let () (import ($l1-k)) $l1-z) 7603 '(i-am-z i-am-x i-am-y)) 7604 (begin (load "testfile.so") #t) 7605 (equal? 7606 (let () (import ($l1-k)) $l1-z) 7607 '(i-am-z i-am-x i-am-y)) 7608 7609 (begin 7610 (library ($l1-l) (export $l1-x) (import (scheme)) 7611 (define $l1-x 'i-am-$l1-l.$l1-x)) 7612 #t) 7613 (eq? 7614 (let () 7615 (import ($l1-l)) 7616 (define-syntax a (lambda (x) #`'#,(datum->syntax #'* $l1-x))) 7617 a) 7618 'i-am-$l1-l.$l1-x) 7619 7620 (begin 7621 (with-output-to-file "testfile-a1.ss" 7622 (lambda () 7623 (pretty-print 7624 '(library (testfile-a1) 7625 (export $l1-a) 7626 (import (scheme)) 7627 (define $l1-a 'a1)))) 7628 'replace) 7629 (with-output-to-file "testfile-b1.ss" 7630 (lambda () 7631 (pretty-print 7632 '(library (testfile-b1) 7633 (export $l1-a $l1-b) 7634 (import (scheme) (testfile-a1)) 7635 (define $l1-b 'b1)))) 7636 'replace) 7637 (with-output-to-file "testfile-c1.ss" 7638 (lambda () 7639 (pretty-print 7640 '(library (testfile-c1) 7641 (export $l1-a $l1-b $l1-c) 7642 (import (scheme) (testfile-b1)) 7643 (define ($l1-c) (list $l1-a $l1-b 'c1))))) 7644 'replace) 7645 (with-output-to-file "testfile-d1.ss" 7646 (lambda () 7647 (pretty-print '(import (scheme) (testfile-b1))) 7648 (pretty-print '(define ($l1-d) (list $l1-a $l1-b 'd1)))) 7649 'replace) 7650 (with-output-to-file "testfile-e1.ss" 7651 (lambda () 7652 (pretty-print 7653 '(library (testfile-e1) 7654 (export $l1-e) 7655 (import (scheme) (testfile-b1)) 7656 (alias $l1-e $l1-a)))) 7657 'replace) 7658 (with-output-to-file "testfile-f1.ss" 7659 (lambda () 7660 (pretty-print 7661 '(library (testfile-f1) 7662 (export $l1-f) 7663 (import (scheme)) 7664 (define-syntax $l1-f (identifier-syntax "macro-f"))))) 7665 'replace) 7666 (with-output-to-file "testfile-g1.ss" 7667 (lambda () 7668 (pretty-print 7669 '(library (testfile-g1) 7670 (export $l1-f) 7671 (import (scheme) (testfile-f1))))) 7672 'replace) 7673 (with-output-to-file "testfile-h1.ss" 7674 (lambda () 7675 (pretty-print '(import (scheme) (testfile-g1))) 7676 (pretty-print '(define ($l1-h) (list $l1-f)))) 7677 'replace) 7678 (for-each separate-compile '(a1 b1 c1 d1 e1 f1 g1 h1)) 7679 #t) 7680 (equal? (begin (load "testfile-d1.so") ($l1-d)) '(a1 b1 d1)) 7681 (begin (import (testfile-c1)) #t) 7682 (equal? ($l1-c) '(a1 b1 c1)) 7683 (begin (import (testfile-e1)) #t) 7684 (equal? $l1-e 'a1) 7685 (equal? (begin (load "testfile-h1.so") ($l1-h)) '("macro-f")) 7686 7687 (begin 7688 (with-output-to-file "testfile-a2.ss" 7689 (lambda () 7690 (pretty-print 7691 '(library (testfile-a2) 7692 (export $l1-a) 7693 (import (scheme)) 7694 (define $l1-a 'a2)))) 7695 'replace) 7696 (with-output-to-file "testfile-b2.ss" 7697 (lambda () 7698 (pretty-print 7699 '(library (testfile-b2) 7700 (export $l1-a $l1-b) 7701 (import (scheme) (testfile-a2)) 7702 (define $l1-b 'b2)))) 7703 'replace) 7704 (with-output-to-file "testfile-c2.ss" 7705 (lambda () 7706 (pretty-print 7707 '(library (testfile-c2) 7708 (export $l1-a $l1-b $l1-c) 7709 (import (scheme) (testfile-b2)) 7710 (define ($l1-c) (list $l1-a $l1-b 'c2))))) 7711 'replace) 7712 (with-output-to-file "testfile-d2.ss" 7713 (lambda () 7714 (pretty-print '(import (scheme) (testfile-b2))) 7715 (pretty-print '(define ($l1-d) (list $l1-a $l1-b 'd2)))) 7716 'replace) 7717 (for-each separate-compile '(a2 b2 c2 d2 a2)) 7718 #t) 7719 (error? ; expected different compilation instance 7720 ; program complains about b2 rather than b2 about a2 7721 ; now that load-library reloads source when dependency changes 7722 ; would be nice if program were reloaded from source as well 7723 (load "testfile-d2.so")) 7724 ; no longer fails now that load-library reloads source when dependency changes 7725 #;(error? ; expected different compilation instance 7726 (import (testfile-c2))) 7727 (begin 7728 (library ($l1-m) (export $l1-x) (import (scheme)) (define $l1-x 333)) 7729 (library ($l1-n) (export $l1-x) (import (scheme)) (import ($l1-m))) 7730 #t) 7731 (eqv? 7732 (let () (import ($l1-n)) $l1-x) 7733 333) 7734 (begin 7735 (define-syntax $from1 7736 (syntax-rules () 7737 ((_ m id) 7738 (let () (import-only m) id)))) 7739 (define-syntax $from2 7740 (syntax-rules () 7741 ((_ m id) 7742 (let () (module (id) (import m)) id)))) 7743 (define-syntax $from3 7744 (syntax-rules () 7745 [(_ m id) 7746 (let ([z (cons 1 2)]) 7747 (let ([id z]) 7748 (import m) 7749 (let ([t id]) 7750 (if (eq? t z) (errorf 'from "~s undefined" 'id) t))))])) 7751 (library ($frappe) (export wire whip) (import (scheme)) 7752 (define wire 3) 7753 (define-syntax whip (identifier-syntax egg)) 7754 (define egg 'whites)) 7755 (equal? 7756 (list (cons ($from1 ($frappe) wire) ($from1 ($frappe) whip)) 7757 (cons ($from2 ($frappe) wire) ($from2 ($frappe) whip)) 7758 (cons ($from3 ($frappe) wire) ($from3 ($frappe) whip))) 7759 '((3 . whites) (3 . whites) (3 . whites)))) 7760 (begin 7761 (library ($q) (export m from) (import (scheme)) 7762 (module m (f) (define f "this is f")) 7763 (define-syntax from 7764 (syntax-rules () [(_ m id) (let () (import-only m) id)]))) 7765 (equal? (let () (import-only ($q)) (from m f)) "this is f")) 7766 (begin 7767 (library ($p) (export d f) (import (scheme)) 7768 (define-syntax d 7769 (syntax-rules () 7770 ((_ e) (m (lambda () e))))) 7771 (define m (lambda (x) x)) 7772 (define f (lambda (th) (th)))) 7773 (eqv? (let () (import-only ($p)) (f (d 2))) 2)) 7774 ; this works for libraries because m is implicitly exported 7775 (eqv? (let () (import-only ($p)) (f (d 1/3))) 1/3) 7776 (error? ; cons undefined 7777 (let () (import-only ($p)) (f (d cons)))) 7778 (error? ; invalid syntax 7779 (library (a) (export x:eval) (import (add-prefix (rnrs eval) x)))) 7780 (error? ; invalid syntax 7781 (library (a) (export val) (import (drop-prefix (rnrs eval) x)))) 7782 (error? ; invalid syntax 7783 (library (a) (export meaning) (import (alias (rnrs eval) [eval meaning])))) 7784 (begin 7785 (define $l1-q1) 7786 (define $l1-q2) 7787 (define-syntax $l1-qlib 7788 (syntax-rules () 7789 [(_ name (export ex ...) (import im ...) body ...) 7790 (begin 7791 (library name (export ex ... q) 7792 (import im ... (rename (only (rnrs) cons) (cons list))) 7793 (define q list) body ...) 7794 (let () (import name) (set! $l1-q1 q)))])) 7795 ($l1-qlib ($l1-libfoo) (export q) (import (rnrs)) (define q list)) 7796 (let () (import ($l1-libfoo)) (set! $l1-q2 q)) 7797 (equal? (list $l1-q1 $l1-q2) (list cons list))) 7798 ; check for existence of chezscheme library 7799 (begin 7800 (library ($l1-r1) (export $l1-x) (import (chezscheme)) 7801 (define $l1-x (sort < '(1 3 2 0 5)))) 7802 (library ($l1-r2) (export $l1-y) (import (chezscheme) ($l1-r1)) 7803 (define $l1-y (cons $l1-x (void)))) 7804 (equal? (let () (import ($l1-r2)) $l1-y) `((0 1 2 3 5) . ,(void)))) 7805 (error? ; invalid context for library form 7806 (module (a) (library (a) (export) (import)))) 7807 (error? ; invalid syntax for library form 7808 (module (a) (library a (import) (export x) (define x 3)) (import a) x)) 7809 (error? ; invalid context for top-level-program form 7810 (module (a) (top-level-program (import)))) 7811 (error? ; invalid syntax for top-level-program form 7812 (module (a) (top-level-program (display "hello")))) 7813 (error? ; invalid context for library form 7814 (lambda () (library (a) (export) (import)))) 7815 (error? ; invalid syntax for library form 7816 (lambda () (library a (import) (export x) (define x 3)) (import a) x)) 7817 (error? ; invalid context for top-level-program form 7818 (lambda () (top-level-program (import)))) 7819 (error? ; invalid syntax for top-level-program form 7820 (lambda () (top-level-program (display "hello")))) 7821 (error? ; defnie not defined 7822 (library ($l1-s) (export y) (import (rnrs)) (defnie x 3) (define y 4))) 7823 7824 (begin 7825 (library ($l1-s) 7826 (export m) 7827 (import (chezscheme)) 7828 (module m (x set-x!) 7829 (define x 0) 7830 (define set-x! (lambda () (set! x 1))))) 7831 #t) 7832 (error? ; attempt to reference assigned hence unexported 7833 (let () (import ($l1-s)) (import m) x)) 7834 (error? ; attempt to reference assigned hence unexported 7835 (let () (import ($l1-s)) (import m) (set! x 2))) 7836 (error? ; invalid version 7837 (let () (import-only (chezscheme csv7 (6))) record-field-mutator)) 7838 (equal? 7839 (let () (import-only (chezscheme csv7)) record-field-mutator) 7840 csv7:record-field-mutator) 7841 7842 ; test macros generating libraries 7843 (begin 7844 (let-syntax ([make-A (syntax-rules () 7845 [(_) (library (A) 7846 (export $library-x) 7847 (import (chezscheme)) 7848 (define $library-x 3))])]) 7849 (make-A)) 7850 #t) 7851 (error? ; out-of-context library reference (A) 7852 (equal? (let () (import (A)) $library-x) 3)) 7853 (begin 7854 (let-syntax ([make-A (lambda (x) 7855 (syntax-case x () 7856 [(k) (with-implicit (k A) 7857 #'(library (A) 7858 (export $library-x) 7859 (import (chezscheme)) 7860 (define $library-x 3)))]))]) 7861 (make-A)) 7862 #t) 7863 (error? ; unbound $library-x 7864 (equal? (let () (import (A)) $library-x) 3)) 7865 (begin 7866 (let-syntax ([make-A (lambda (x) 7867 (syntax-case x () 7868 [(k id ...) 7869 (with-implicit (k A) 7870 #'(library (A) 7871 (export id ...) 7872 (import (chezscheme)) 7873 (define id 3) 7874 ...))]))]) 7875 (make-A $library-x)) 7876 #t) 7877 (eqv? (let () (import (A)) $library-x) 3) 7878 (let-syntax ([make-A (syntax-rules () 7879 [(_) (begin 7880 (library (A) 7881 (export x) 7882 (import (chezscheme)) 7883 (define x 3)) 7884 (let () (import (A)) 7885 (eqv? x 3)))])]) 7886 (make-A)) 7887 (let-syntax ([make-A (syntax-rules () 7888 [(_) (begin 7889 (library (A) 7890 (export x) 7891 (import (chezscheme)) 7892 (define x 3)) 7893 (define-syntax q 7894 (syntax-rules () 7895 [(_) (let () 7896 (import (A)) 7897 x)])) 7898 (eqv? (q) 3))])]) 7899 (make-A)) 7900 7901 (begin 7902 (with-output-to-file "testfile-a14.ss" 7903 (lambda () 7904 (pretty-print 7905 '(library (testfile-a14) (export f) (import (chezscheme)) 7906 (define f (lambda (n) (if (fx= n 0) 1 (fx* n (f (fx- n 1)))))) 7907 (printf "invoked a\n")))) 7908 'replace) 7909 (with-output-to-file "testfile-b14.ss" 7910 (lambda () 7911 (pretty-print 7912 '(library (testfile-b14) (export g) (import (chezscheme) (testfile-a14)) 7913 (define g (lambda (n) (f n))) 7914 (printf "invoked b\n")))) 7915 'replace) 7916 (with-output-to-file "testfile-c14.ss" 7917 (lambda () 7918 (pretty-print '(import (chezscheme) (testfile-b14))) 7919 (pretty-print '(pretty-print (g 10)))) 7920 'replace) 7921 #t) 7922 (equal? 7923 (with-output-to-string 7924 (lambda () (load "testfile-c14.ss"))) 7925 "invoked a\ninvoked b\n3628800\n") 7926 ; test for proper propagation and non-propagation of constants across library boundaries 7927 (begin 7928 (with-output-to-file "testfile-a15.ss" 7929 (lambda () 7930 (pretty-print 7931 '(library (testfile-a15) (export a b c d e f g fa fb fc fd fe ff fg) 7932 (import (chezscheme)) 7933 (define-record-type foo (nongenerative) (fields x)) 7934 (define a '()) 7935 (define b 'sym) 7936 (define c 3/4) 7937 (define d '(x . y)) 7938 (define e (record-type-descriptor foo)) 7939 (define f (make-foo 3)) 7940 (define g "hello!") 7941 (define fa (lambda () a)) 7942 (define fb (lambda () b)) 7943 (define fc (lambda () c)) 7944 (define fd (lambda () d)) 7945 (define fe (lambda () e)) 7946 (define ff (lambda () f)) 7947 (define fg (lambda () g))))) 7948 'replace) 7949 (with-output-to-file "testfile-b15.ss" 7950 (lambda () 7951 (pretty-print 7952 '(library (testfile-b15) (export a b c d e f g fa fb fc fd fe ff fg) 7953 (import (chezscheme) (prefix (testfile-a15) %)) 7954 (define a %a) 7955 (define b %b) 7956 (define c %c) 7957 (define d %d) 7958 (define e %e) 7959 (define f %f) 7960 (define g %g) 7961 (define fa (lambda () (%fa))) 7962 (define fb (lambda () (%fb))) 7963 (define fc (lambda () (%fc))) 7964 (define fd (lambda () (%fd))) 7965 (define fe (lambda () (%fe))) 7966 (define ff (lambda () (%ff))) 7967 (define fg (lambda () (%fg)))))) 7968 'replace) 7969 (with-output-to-file "testfile-c15.ss" 7970 (lambda () 7971 (pretty-print '(define $c15-ls1 7972 (let () 7973 (import (testfile-a15)) 7974 (list a b c d e f g (fa) (fb) (fc) (fd) (fe) (ff) (fg))))) 7975 (pretty-print '(define $c15-ls2 7976 (let () 7977 (import (testfile-b15)) 7978 (list a b c d e f g (fa) (fb) (fc) (fd) (fe) (ff) (fg))))) 7979 (pretty-print '(pretty-print (map eq? $c15-ls1 $c15-ls2))) 7980 (pretty-print '(pretty-print (map eqv? $c15-ls1 $c15-ls2))) 7981 (pretty-print '(pretty-print (map equal? $c15-ls1 $c15-ls2)))) 7982 'replace) 7983 (for-each separate-compile '(a15 b15 c15)) 7984 #t) 7985 ((lambda (x ls) (and (member x ls) #t)) 7986 (with-output-to-string 7987 (lambda () (load "testfile-c15.so"))) 7988 '("(#t #t #f #t #t #t #t #t #t #f #t #t #t #t)\n(#t #t #t #t #t #t #t #t #t #t #t #t #t #t)\n(#t #t #t #t #t #t #t #t #t #t #t #t #t #t)\n" 7989 "(#t #t #t #t #t #t #t #t #t #t #t #t #t #t)\n(#t #t #t #t #t #t #t #t #t #t #t #t #t #t)\n(#t #t #t #t #t #t #t #t #t #t #t #t #t #t)\n")) 7990 (begin 7991 (library ($l3) (export f) (import (chezscheme)) (define (f x) x)) 7992 #t) 7993 (equal? 7994 (let () (import ($l3)) (f (f 3))) 7995 3) 7996 (begin 7997 ;; (export import-spec ...) empty case 7998 (library ($empty) (export) (import (chezscheme)) (export (import))) 7999 #t) 8000 (begin 8001 (library ($l4-A) (export a) (import (chezscheme)) (define a 1)) 8002 (library ($l4-B) (export b) (import (chezscheme)) (define b 2)) 8003 #t) 8004 (equal? '(1 2) (let () (import ($l4-A) ($l4-B)) (list a b))) 8005 (begin 8006 ;; (export import-spec ...) multiple imports case 8007 (library ($l4-C) (export) (import (chezscheme)) (export (import ($l4-A) ($l4-B)))) 8008 (equal? '(1 2) (let () (import ($l4-C)) (list a b)))) 8009 ) 8010 8011(mat library2 8012 ; test to make sure that libraries needed by the transformers of local 8013 ; macros are invoked immediately and not required as run-time requirements. 8014 (begin 8015 (with-output-to-file "testfile-a3.ss" 8016 (lambda () 8017 (pretty-print 8018 '(library (testfile-a3) (export q) (import (rnrs) (only (scheme) putprop)) (define q 3) (putprop 'testfile-a3 'invoke #t)))) 8019 'replace) 8020 (with-output-to-file "testfile-b3.ss" 8021 (lambda () 8022 (pretty-print 8023 '(library (testfile-b3) (export x) (import (testfile-a3) (rnrs) (only (scheme) putprop)) 8024 (define x (let () (define-syntax p (lambda (x) (putprop 'testfile-b3 'visit #t) q)) p))))) 8025 'replace) 8026 (for-each separate-compile '(a3 b3)) 8027 #t) 8028 (equal? 8029 (let () 8030 (import (testfile-b3)) 8031 (list x (getprop 'testfile-a3 'invoke #f) (getprop 'testfile-b3 'visit #f))) 8032 '(3 #f #f)) 8033 (begin 8034 (with-output-to-file "testfile-a4.ss" 8035 (lambda () 8036 (pretty-print 8037 '(library (testfile-a4) (export q) (import (rnrs) (only (scheme) putprop)) 8038 (define q (lambda (x) (if (= x 0) 1 (* x (q (- x 1)))))) 8039 (putprop 'testfile-a4 'invoke #t)))) 8040 'replace) 8041 (with-output-to-file "testfile-b4.ss" 8042 (lambda () 8043 (pretty-print 8044 '(library (testfile-b4) (export x) (import (testfile-a4) (rnrs) (only (scheme) putprop)) 8045 (define x (let () (define-syntax p (lambda (x) (putprop 'testfile-b4 'visit #t) (q 3))) (list p (q 4))))))) 8046 'replace) 8047 (for-each separate-compile '(a4 b4)) 8048 #t) 8049 (equal? 8050 (let () 8051 (import (testfile-b4)) 8052 (list x (getprop 'testfile-a4 'invoke #f) (getprop 'testfile-b4 'visit #f))) 8053 '((6 24) #t #f)) 8054 (begin 8055 (with-output-to-file "testfile-a5.ss" 8056 (lambda () 8057 (pretty-print 8058 '(library (testfile-a5) (export q) (import (rnrs) (only (scheme) putprop)) (define q 3) (putprop 'testfile-a5 'invoke #t)))) 8059 'replace) 8060 (with-output-to-file "testfile-b5.ss" 8061 (lambda () 8062 (pretty-print 8063 '(library (testfile-b5) (export x) (import (testfile-a5) (rnrs) (only (scheme) putprop)) 8064 (define x (let-syntax ([p (lambda (x) (putprop 'testfile-b5 'visit #t) q)]) p))))) 8065 'replace) 8066 (for-each separate-compile '(a5 b5)) 8067 #t) 8068 (equal? 8069 (let () 8070 (import (testfile-b5)) 8071 (list x (getprop 'testfile-a5 'invoke #f) (getprop 'testfile-b5 'visit #f))) 8072 '(3 #f #f)) 8073 (begin 8074 (with-output-to-file "testfile-a6.ss" 8075 (lambda () 8076 (pretty-print 8077 '(library (testfile-a6) (export q) (import (rnrs) (only (scheme) putprop)) (define q 3) (putprop 'testfile-a6 'invoke #t)))) 8078 'replace) 8079 (with-output-to-file "testfile-b6.ss" 8080 (lambda () 8081 (pretty-print 8082 '(library (testfile-b6) (export x) (import (testfile-a6) (rnrs) (only (scheme) putprop)) 8083 (let-syntax ([p (lambda (x) (putprop 'testfile-b6 'visit #t) q)]) (define x p))))) 8084 'replace) 8085 (for-each separate-compile '(a6 b6)) 8086 #t) 8087 (equal? 8088 (let () 8089 (import (testfile-b6)) 8090 (list x (getprop 'testfile-a6 'invoke #f) (getprop 'testfile-b6 'visit #f))) 8091 '(3 #f #f)) 8092 8093 ; test cyclic dependency check 8094 ; this mat and next four are connected 8095 (begin 8096 (with-output-to-file "testfile-a7.ss" 8097 (lambda () 8098 (pretty-print 8099 '(library (testfile-a7) (export x) (import (rnrs) (testfile-b7)) (define x y)))) 8100 'replace) 8101 (with-output-to-file "testfile-b7.ss" 8102 (lambda () 8103 (pretty-print 8104 '(library (testfile-b7) (export y) (import (rnrs) (testfile-a7)) (define y x)))) 8105 'replace) 8106 #t) 8107 (error? ; possible cyclic dependency 8108 (let () (import (testfile-a7) (testfile-b7)) (list x y))) 8109 (error? ; possible cyclic dependency 8110 (let () (import (testfile-b7) (testfile-a7)) (list x y))) 8111 ; make sure errors didn't leave libraries in a state where they can't be redefined 8112 (begin 8113 (with-output-to-file "testfile-a7.ss" 8114 (lambda () 8115 (pretty-print 8116 '(library (testfile-a7) (export x) (import (rnrs) (testfile-b7)) (define x y)))) 8117 'replace) 8118 (with-output-to-file "testfile-b7.ss" 8119 (lambda () 8120 (pretty-print 8121 '(library (testfile-b7) (export y) (import (rnrs)) (define y 17)))) 8122 'replace) 8123 #t) 8124 (equal? 8125 (let () (import (testfile-a7) (testfile-b7)) (list x y)) 8126 '(17 17)) 8127 8128 ; import cycles 8129 (error? ; cyclic dependency on import 8130 (library ($l2-lib1) (export) (import ($l2-lib1)))) 8131 (begin ; make sure we can redefine after cyclic import error 8132 (library ($l2-lib1) (export a) (import (rnrs)) (define a "a")) 8133 #t) 8134 (equal? (let () (import ($l2-lib1)) a) "a") 8135 8136 (begin 8137 (delete-file "testfile-a8.so") 8138 (with-output-to-file "testfile-a8.ss" 8139 (lambda () 8140 (pretty-print 8141 '(library (testfile-a8) (export a) (import (testfile-a8))))) 8142 'replace) 8143 #t) 8144 (error? ; cyclic dependency on import 8145 (import (testfile-a8))) 8146 (begin ; make sure we can redefine after cyclic import error 8147 (with-output-to-file "testfile-a8.ss" 8148 (lambda () 8149 (pretty-print 8150 '(library (testfile-a8) (export cons) (import (rnrs))))) 8151 'replace) 8152 #t) 8153 (equal? (let () (import (testfile-a8)) cons) (let () (import (rnrs)) cons)) 8154 8155 (begin 8156 (delete-file "testfile.a9.so") 8157 (with-output-to-file "testfile-a9.ss" 8158 (lambda () 8159 (pretty-print 8160 '(library (testfile-a9) (export a) (import (testfile-a9))))) 8161 'replace) 8162 #t) 8163 (error? ; cyclic dependency on import 8164 (compile-file "testfile-a9")) 8165 (begin ; make sure we can redefine after cyclic import error 8166 (with-output-to-file "testfile-a9.ss" 8167 (lambda () 8168 (pretty-print 8169 '(library (testfile-a9) (export cons) (import (rnrs))))) 8170 'replace) 8171 (compile-file "testfile-a9") 8172 (load "testfile-a9.so") 8173 #t) 8174 (equal? (let () (import (testfile-a9)) cons) (let () (import (rnrs)) cons)) 8175 8176 (begin 8177 (delete-file "testfile-a10.so") 8178 (delete-file "testfile-b10.so") 8179 (with-output-to-file "testfile-a10.ss" 8180 (lambda () 8181 (pretty-print 8182 '(library (testfile-a10) (export a) (import (testfile-b10))))) 8183 'replace) 8184 (with-output-to-file "testfile-b10.ss" 8185 (lambda () 8186 (pretty-print 8187 '(library (testfile-b10) (export a) (import (testfile-a10))))) 8188 'replace) 8189 #t) 8190 (error? ; cyclic dependency on import (indirect) 8191 (import (testfile-a10))) 8192 (begin ; make sure we can redefine after cyclic import error 8193 (with-output-to-file "testfile-a10.ss" 8194 (lambda () 8195 (pretty-print 8196 '(library (testfile-a10) (export a) (import (testfile-b10))))) 8197 'replace) 8198 (with-output-to-file "testfile-b10.ss" 8199 (lambda () 8200 (pretty-print 8201 '(library (testfile-b10) (export a) (import (rnrs)) (define a "eh?")))) 8202 'replace) 8203 #t) 8204 (equal? (let () (import (testfile-a10)) a) "eh?") 8205 8206 ; invoke cycles 8207 (begin 8208 (library ($l2-lib2) (export a) 8209 (import (rnrs) (rnrs eval)) 8210 (define a (eval 'a (environment '($l2-lib2))))) 8211 #t) 8212 (error? ; cyclic dependency on invoke 8213 (let () (import ($l2-lib2)) a)) 8214 8215 (begin 8216 (delete-file "testfile-a11.so") 8217 (delete-file "testfile-b11.so") 8218 (with-output-to-file "testfile-a11.ss" 8219 (lambda () 8220 (pretty-print 8221 '(library (testfile-a11) (export a) (import (testfile-b11))))) 8222 'replace) 8223 (with-output-to-file "testfile-b11.ss" 8224 (lambda () 8225 (pretty-print 8226 '(library (testfile-b11) (export a) 8227 (import (rnrs) (rnrs eval)) 8228 (define a (eval 'a (environment '(testfile-a11))))))) 8229 'replace) 8230 #t) 8231 (error? ; cyclic dependency on invoke (indirect) 8232 (let () (import (testfile-a11)) a)) 8233 8234 ; visit cycles 8235 (begin 8236 (delete-file "testfile-a12.so") 8237 (remprop 'chewie 'ratface) 8238 (with-output-to-file "testfile-a12.ss" 8239 (lambda () 8240 (pretty-print 8241 '(library (testfile-a12) (export a) 8242 (import (rnrs) (rnrs eval) (only (scheme) getprop)) 8243 (define-syntax a 8244 (if (getprop 'chewie 'ratface #f) 8245 (eval 'a (environment '(testfile-a12))) 8246 (lambda (x) 3)))))) 8247 'replace) 8248 (separate-compile 'a12) 8249 (putprop 'chewie 'ratface #t) 8250 #t) 8251 (error? ; cyclic dependency on visit 8252 (let () (import (testfile-a12)) a)) 8253 (begin 8254 (with-output-to-file "testfile-a13.ss" 8255 (lambda () 8256 (pretty-print 8257 '(library (testfile-a13) (export a) 8258 (import (rename (rnrs) (cons a)))))) 8259 'replace) 8260 (separate-compile 'a13) 8261 #t) 8262 (equal? (let () (import (testfile-a13)) (a 3 4)) '(3 . 4)) 8263 (error? (library (foo) (export a (rename b a)) (import (rnrs)) (define a 3) (define b 4))) 8264 (error? (library (foo) (export a (rename (b a))) (import (rnrs)) (define a 3) (define b 4))) 8265 (error? (library (foo) (exports a) (import (rnrs)) (define a 3))) 8266 (error? (library (foo) (export a) (imports (rnrs)) (define a 3))) 8267 8268 (error? ; misplaced library form 8269 (let () 8270 (library (foo) 8271 (export) 8272 (import (scheme)) 8273 (library (bar) (export) (import))))) 8274 (error? ; misplaced library form 8275 (let () (library (foo) (export) (import)))) 8276 (error? ; misplaced library form 8277 (+ (library (bar) (export) (import)) 3)) 8278 8279 ; make sure library is visited when needed 8280 (begin 8281 (with-output-to-file "testfile-f2.ss" 8282 (lambda () 8283 (pretty-print 8284 '(library (testfile-f2) (export f2-x) (import (rnrs) (rnrs mutable-pairs)) 8285 (define-syntax define-mutable 8286 (syntax-rules () 8287 [(_ x e) 8288 (begin 8289 (define t (list e)) 8290 (define-syntax x 8291 (identifier-syntax 8292 [_ (car t)] 8293 [(set! _ new) (set-car! t new)])))])) 8294 (define-mutable f2-x 772)))) 8295 'replace) 8296 (for-each separate-compile '(f2)) 8297 #t) 8298 (begin 8299 (define (f2-x-whack! v) 8300 (import (testfile-f2)) 8301 (set! f2-x v)) 8302 (f2-x-whack! 29) 8303 #t) 8304 (eqv? (let () (import (testfile-f2)) f2-x) 29) 8305 (not (top-level-bound? 'f2-x)) 8306 ; make sure #'x doesn't force library to be visited if x is an exported 8307 ; keyword or invoked if x is an exported variable 8308 (begin 8309 (with-output-to-file "testfile-g2.ss" 8310 (lambda () 8311 (pretty-print 8312 '(library (testfile-g2) (export hit-a hit-x) (import (chezscheme)) 8313 (define hit-a (make-parameter #f)) 8314 (define hit-x (make-parameter #f))))) 8315 'replace) 8316 (with-output-to-file "testfile-h2.ss" 8317 (lambda () 8318 (pretty-print 8319 '(library (testfile-h2) (export x a) (import (rnrs) (testfile-g2)) 8320 (define-syntax a (begin (hit-a #t) (lambda (x) 73))) 8321 (define x (begin (hit-x #t) (list (hit-x) 97)))))) 8322 'replace) 8323 (for-each separate-compile '(g2 h2)) 8324 #t) 8325 (let () (import (testfile-g2)) (and (not (hit-a)) (not (hit-x)))) 8326 (let () (import (testfile-g2) (testfile-h2)) (let ([q #'a]) (and (identifier? q) (not (hit-a)) (not (hit-x))))) 8327 (let () (import (testfile-g2) (testfile-h2)) (let ([q #'x]) (and (identifier? q) (not (hit-a)) (not (hit-x))))) 8328 (let () (import (testfile-g2) (testfile-h2)) (and (eqv? a 73) (hit-a) (not (hit-x)))) 8329 (let () (import (testfile-g2) (testfile-h2)) (and (equal? x '(#t 97)) (hit-a) (hit-x))) 8330) 8331 8332(mat library3 8333 ; test several-deep invoke-dependency chain 8334 (begin 8335 (with-output-to-file "testfile-a3-0.ss" 8336 (lambda () 8337 (pretty-print 8338 '(library (testfile-a3-0) 8339 (export x0) 8340 (import (rnrs)) 8341 (define x0 7)))) 8342 'replace) 8343 (with-output-to-file "testfile-a3-1.ss" 8344 (lambda () 8345 (pretty-print 8346 '(library (testfile-a3-1) 8347 (export x1) 8348 (import (rnrs) (testfile-a3-0)) 8349 (define x1 (+ x0 1))))) 8350 'replace) 8351 (with-output-to-file "testfile-a3-2.ss" 8352 (lambda () 8353 (pretty-print 8354 '(library (testfile-a3-2) 8355 (export x2) 8356 (import (rnrs) (testfile-a3-1)) 8357 (define x2 (+ x1 2))))) 8358 'replace) 8359 (with-output-to-file "testfile-a3-3.ss" 8360 (lambda () 8361 (pretty-print 8362 '(library (testfile-a3-3) 8363 (export x3) 8364 (import (rnrs) (testfile-a3-2)) 8365 (define x3 (+ x2 3))))) 8366 'replace) 8367 (with-output-to-file "testfile-a3-4.ss" 8368 (lambda () 8369 (pretty-print '(import (rnrs) (testfile-a3-3))) 8370 (pretty-print '(write (+ x3 4)))) 8371 'replace) 8372 (separate-compile 'compile-library 'a3-0) 8373 (separate-compile 'compile-library 'a3-1) 8374 (separate-compile 'compile-library 'a3-2) 8375 (separate-compile 'compile-library 'a3-3) 8376 (separate-compile 'compile-program 'a3-4) 8377 #t) 8378 (equal? 8379 (with-output-to-string 8380 (lambda () (load-program "testfile-a3-4.so"))) 8381 "17") 8382 (eqv? (let () (import (testfile-a3-3)) x3) 13) 8383 ; try begin containing library and top-level program 8384 (begin 8385 (with-output-to-file "testfile-a3-5.ss" 8386 (lambda () 8387 (pretty-print 8388 '(begin 8389 (library (a3-5 foo) 8390 (export x) 8391 (import (rnrs)) 8392 (define x "hello")) 8393 (top-level-program 8394 (import (rnrs) (a3-5 foo)) 8395 (display x))))) 8396 'replace) 8397 (separate-compile 'a3-5) 8398 #t) 8399 (equal? 8400 (with-output-to-string 8401 (lambda () (load "testfile-a3-5.so"))) 8402 "hello") 8403 (equal? 8404 (with-output-to-string 8405 (lambda () (load "testfile-a3-5.ss"))) 8406 "hello") 8407 ; try begin containing two libraries 8408 (begin 8409 (with-output-to-file "testfile-a3-6.ss" 8410 (lambda () 8411 (pretty-print 8412 '(begin 8413 (library (a3-6 foo) 8414 (export a x) 8415 (import (rnrs)) 8416 (define-syntax a (identifier-syntax "boo")) 8417 (define x "hello")) 8418 (library (a3-6 bar) 8419 (export y) 8420 (import (rnrs) (a3-6 foo)) 8421 (define y (cons a x))) 8422 (let () (import (a3-6 bar)) (write y))))) 8423 'replace) 8424 (separate-compile 'a3-6) 8425 #t) 8426 (equal? 8427 (with-output-to-string 8428 (lambda () (load "testfile-a3-6.so"))) 8429 "(\"boo\" . \"hello\")") 8430 (equal? 8431 (let () 8432 (import (a3-6 bar)) 8433 y) 8434 '("boo" . "hello")) 8435 (equal? 8436 (let () 8437 (import (a3-6 foo)) 8438 (cons x a)) 8439 '("hello" . "boo")) 8440 ; import a library in subset-mode system, then outsied of subset-mode system 8441 (begin 8442 (with-output-to-file "testfile-a3-7.ss" 8443 (lambda () 8444 (pretty-print 8445 '(library (testfile-a3-7) 8446 (export x) 8447 (import (rnrs)) 8448 (define x "hello")))) 8449 'replace) 8450 #t) 8451 (equal? 8452 (parameterize ([subset-mode 'system]) (eval '(let () (import (testfile-a3-7)) x))) 8453 "hello") 8454 (equal? 8455 (let () (import (testfile-a3-7)) x) 8456 "hello") 8457 8458 (begin 8459 (with-output-to-file "testfile-a3-8.ss" 8460 (lambda () 8461 (pretty-print '(printf "outside (testfile-a3-8)\n")) 8462 (pretty-print 8463 '(library (testfile-a3-8) 8464 (export a3-8-x) 8465 (import (rnrs)) 8466 (define a3-8-x 5) 8467 (error #f "library should not be invoked")))) 8468 'replace) 8469 (with-output-to-file "testfile-a3-9.ss" 8470 (lambda () 8471 (pretty-print 8472 '(let () 8473 (import (scheme) (testfile-a3-8)) 8474 (printf "inside testfile-a3-9\n")))) 8475 'replace) 8476 (with-output-to-file "testfile-a3-10.ss" 8477 (lambda () 8478 (pretty-print '(import (scheme) (testfile-a3-8))) 8479 (pretty-print '(printf "inside testfile-a3-10\n"))) 8480 'replace) 8481 (separate-compile 'a3-8) 8482 (separate-compile 'a3-9) 8483 (separate-compile 'a3-10) 8484 #t) 8485 (equal? 8486 (with-output-to-string (lambda () (load "testfile-a3-9.so"))) 8487 "inside testfile-a3-9\n") 8488 (equal? 8489 (with-output-to-string (lambda () (load "testfile-a3-10.so"))) 8490 "inside testfile-a3-10\n") 8491) 8492 8493(mat library4 8494 ; test reloading of libraries if dependencies have changed 8495 ; when compile-imported-libraries is true. 8496 ; first test with compile-imported-libraries true: 8497 (begin 8498 (define ($reset-l4-1) 8499 (for-each delete-file '("testfile-l4-a1.so" "testfile-l4-b1.so" "testfile-l4-c1.so")) 8500 (with-output-to-file "testfile-l4-a1.ss" 8501 (lambda () 8502 (pretty-print 8503 '(library (testfile-l4-a1) (export x) (import (chezscheme) (testfile-l4-b1) (testfile-l4-c1)) 8504 (include "testfile-l4-d1.ss") 8505 (define a 'a-object) 8506 (define x (list a b c d))))) 8507 'replace) 8508 (with-output-to-file "testfile-l4-b1.ss" 8509 (lambda () 8510 (pretty-print 8511 '(library (testfile-l4-b1) (export b) (import (chezscheme)) 8512 (define b (list 'b-object))))) 8513 'replace) 8514 (with-output-to-file "testfile-l4-c1.ss" 8515 (lambda () 8516 (pretty-print 8517 '(library (testfile-l4-c1) (export c) (import (chezscheme)) 8518 (define-syntax c (lambda (x) #''c-object))))) 8519 'replace) 8520 (with-output-to-file "testfile-l4-d1.ss" 8521 (lambda () 8522 (pretty-print 8523 '(define-syntax d (lambda (x) #''d-object)))) 8524 'replace) 8525 (with-output-to-file "testfile-l4-p1.ss" 8526 (lambda () 8527 (pretty-print 8528 '(import (testfile-l4-a1) (chezscheme))) 8529 (pretty-print 8530 '(pretty-print x))) 8531 'replace) 8532 (let ([s (separate-eval 8533 '(compile-imported-libraries #t) 8534 '(compile-file-message #f) 8535 '(load-program "testfile-l4-p1.ss"))]) 8536 (unless (equal? s "(a-object (b-object) c-object d-object)\n") 8537 (errorf #f "unexpected separate-eval return value ~s" s))) 8538 ; ensure different file times for followup updates 8539 (sleep (make-time 'time-duration 0 (if (embedded?) 3 1))) 8540 #t) 8541 #t) 8542 ($reset-l4-1) 8543 (equal? 8544 (begin 8545 (with-output-to-file "testfile-l4-a1.ss" 8546 (lambda () 8547 (pretty-print 8548 '(library (testfile-l4-a1) (export x) (import (chezscheme) (testfile-l4-b1) (testfile-l4-c1)) 8549 (include "testfile-l4-d1.ss") 8550 (define a 'newa-object) 8551 (define x (list a b c d))))) 8552 'replace) 8553 (separate-eval 8554 '(compile-imported-libraries #t) 8555 '(compile-file-message #f) 8556 '(load-program "testfile-l4-p1.ss"))) 8557 "(newa-object (b-object) c-object d-object)\n") 8558 ($reset-l4-1) 8559 (equal? 8560 (begin 8561 (with-output-to-file "testfile-l4-b1.ss" 8562 (lambda () 8563 (pretty-print 8564 '(library (testfile-l4-b1) (export b) (import (chezscheme)) 8565 (define b (list 'newb-object))))) 8566 'replace) 8567 (separate-eval 8568 '(compile-imported-libraries #t) 8569 '(compile-file-message #f) 8570 '(load-program "testfile-l4-p1.ss"))) 8571 "(a-object (newb-object) c-object d-object)\n") 8572 ($reset-l4-1) 8573 (equal? 8574 (begin 8575 (with-output-to-file "testfile-l4-c1.ss" 8576 (lambda () 8577 (pretty-print 8578 '(library (testfile-l4-c1) (export c) (import (chezscheme)) 8579 (define-syntax c (lambda (x) #''newc-object))))) 8580 'replace) 8581 (separate-eval 8582 '(compile-imported-libraries #t) 8583 '(compile-file-message #f) 8584 '(load-program "testfile-l4-p1.ss"))) 8585 "(a-object (b-object) newc-object d-object)\n") 8586 ($reset-l4-1) 8587 (equal? 8588 (begin 8589 (with-output-to-file "testfile-l4-d1.ss" 8590 (lambda () 8591 (pretty-print 8592 '(define-syntax d (lambda (x) #''newd-object)))) 8593 'replace) 8594 (separate-eval 8595 '(compile-imported-libraries #t) 8596 '(compile-file-message #f) 8597 '(load-program "testfile-l4-p1.ss"))) 8598 "(a-object (b-object) c-object newd-object)\n") 8599 ; now with compile-imported-libraries false 8600 ($reset-l4-1) 8601 (equal? 8602 (begin 8603 (with-output-to-file "testfile-l4-a1.ss" 8604 (lambda () 8605 (pretty-print 8606 '(library (testfile-l4-a1) (export x) (import (chezscheme) (testfile-l4-b1) (testfile-l4-c1)) 8607 (include "testfile-l4-d1.ss") 8608 (define a 'newera-object) 8609 (define x (list a b c d))))) 8610 'replace) 8611 (separate-eval 8612 '(compile-imported-libraries #f) 8613 '(compile-file-message #t) 8614 '(load-program "testfile-l4-p1.ss"))) 8615 "(newera-object (b-object) c-object d-object)\n") 8616 ($reset-l4-1) 8617 (equal? 8618 (begin 8619 (with-output-to-file "testfile-l4-b1.ss" 8620 (lambda () 8621 (pretty-print 8622 '(library (testfile-l4-b1) (export b) (import (chezscheme)) 8623 (define b (list 'newerb-object))))) 8624 'replace) 8625 (separate-eval 8626 '(compile-imported-libraries #f) 8627 '(compile-file-message #t) 8628 '(load-program "testfile-l4-p1.ss"))) 8629 "(a-object (newerb-object) c-object d-object)\n") 8630 ($reset-l4-1) 8631 (equal? 8632 (begin 8633 (with-output-to-file "testfile-l4-c1.ss" 8634 (lambda () 8635 (pretty-print 8636 '(library (testfile-l4-c1) (export c) (import (chezscheme)) 8637 (define-syntax c (lambda (x) #''newerc-object))))) 8638 'replace) 8639 (separate-eval 8640 '(compile-imported-libraries #f) 8641 '(compile-file-message #t) 8642 '(load-program "testfile-l4-p1.ss"))) 8643 "(a-object (b-object) newerc-object d-object)\n") 8644 ($reset-l4-1) 8645 (equal? 8646 (begin 8647 (with-output-to-file "testfile-l4-d1.ss" 8648 (lambda () 8649 (pretty-print 8650 '(define-syntax d (lambda (x) #''newerd-object)))) 8651 'replace) 8652 (separate-eval 8653 '(compile-imported-libraries #f) 8654 '(compile-file-message #t) 8655 '(load-program "testfile-l4-p1.ss"))) 8656 "(a-object (b-object) c-object newerd-object)\n") 8657) 8658 8659(mat library5 8660 ; test for proper runtime library dependencies 8661 (begin 8662 (with-output-to-file "testfile-l5-a1.ss" 8663 (lambda () 8664 (pretty-print 8665 '(library (testfile-l5-a1) (export a) (import (chezscheme)) 8666 (define a (cons 3 4))))) 8667 'replace) 8668 (with-output-to-file "testfile-l5-b1.ss" 8669 (lambda () 8670 (pretty-print 8671 '(library (testfile-l5-b1) (export a b c) (import (chezscheme) (testfile-l5-a1)) 8672 (define-syntax b (identifier-syntax (vector a))) 8673 (define c (cons 5 6))))) 8674 'replace) 8675 (with-output-to-file "testfile-l5-c1.ss" 8676 (lambda () 8677 (for-each pretty-print 8678 `((import (chezscheme) (testfile-l5-b1)) 8679 (set-car! a 55) 8680 (pretty-print (list a b))))) 8681 'replace) 8682 (equal? 8683 (parameterize ([compile-imported-libraries #t]) 8684 (compile-program "testfile-l5-c1")) 8685 '((testfile-l5-a1)))) 8686 ; delete testfile-l5-b1.{ss,so} to make sure they aren't surreptitiously loaded 8687 (begin 8688 (delete-file "testfile-l5-b1.ss") 8689 (delete-file "testfile-l5-b1.so") 8690 (and (not (file-exists? "testfile-l5-b1.ss")) 8691 (not (file-exists? "testfile-l5-b1.so")))) 8692 (equal? 8693 (separate-eval '(load-program "testfile-l5-c1.so")) 8694 "((55 . 4) #((55 . 4)))\n") 8695) 8696 8697(mat library6 8698 ; test for proper handling of visit library dependencies 8699 (begin 8700 (with-output-to-file "testfile-l6-a1.ss" 8701 (lambda () 8702 (pretty-print 8703 '(library (testfile-l6-a1) (export a) (import (chezscheme)) 8704 (define a (cons 3 4))))) 8705 'replace) 8706 (with-output-to-file "testfile-l6-b1.ss" 8707 (lambda () 8708 (pretty-print 8709 '(library (testfile-l6-b1) (export b-x b-y) (import (chezscheme) (testfile-l6-a1)) 8710 (define-syntax b-x (lambda (x) (car a))) 8711 (define b-y (cons 5 6))))) 8712 'replace) 8713 (with-output-to-file "testfile-l6-c1.ss" 8714 (lambda () 8715 (pretty-print 8716 '(library (testfile-l6-c1) (export c) (import (chezscheme) (testfile-l6-b1)) 8717 (meta define c 8718 (lambda (x) 8719 #`(cons (* #,x #,(car b-y)) (* #,x #,(cdr b-y)))))))) 8720 'replace) 8721 (with-output-to-file "testfile-l6-prog1.ss" 8722 (lambda () 8723 (pretty-print '(eval-when (visit) (printf "visiting testfile-l6-prog1\n"))) 8724 (pretty-print '(define-syntax M 8725 (lambda (x) 8726 (import (testfile-l6-c1)) 8727 (syntax-case x () 8728 [(_ f d) #`(f #,(c (datum d)))])))) 8729 (pretty-print '(eval-when (revisit) (printf "revisiting testfile-l6-prog1\n"))) 8730 (pretty-print '(pretty-print (M vector 2)))) 8731 'replace) 8732 (separate-compile 8733 '(lambda (x) 8734 (parameterize ([compile-imported-libraries #t]) 8735 (compile-file x))) 8736 "testfile-l6-prog1") 8737 #t) 8738 8739 (begin 8740 (delete-file "testfile-l6-a1.so") 8741 (delete-file "testfile-l6-a1.ss") 8742 (and (not (file-exists? "testfile-l6-a1.so")) 8743 (not (file-exists? "testfile-l6-a1.ss")))) 8744 8745 (equal? 8746 (separate-eval '(revisit "testfile-l6-prog1.so")) 8747 "revisiting testfile-l6-prog1\n#((10 . 12))\n") 8748) 8749 8750(mat library7 8751 (begin 8752 (mkfile "testfile-l7-a1.ss" 8753 '(library (testfile-l7-a1) (export a-macro a) (import (chezscheme)) (define-syntax a-macro (identifier-syntax 'aaa)) (define (a x) (+ x (* x x))))) 8754 (mkfile "testfile-l7-b1.ss" 8755 '(library (testfile-l7-b1) (export b) (import (chezscheme) (testfile-l7-a1)) (define (b x) (cons 'b a-macro)))) 8756 (mkfile "testfile-l7-c1.ss" 8757 '(library (testfile-l7-c1) (export c) (import (chezscheme) (testfile-l7-a1)) (define (c x) (cons 'c (a x))))) 8758 (mkfile "testfile-l7-d1.ss" 8759 '(library (testfile-l7-d1) (export d) (import (chezscheme) (testfile-l7-a1)) (define (d x) (list 'd a-macro (a x))))) 8760 (separate-compile 8761 '(lambda (x) (for-each compile-library x)) 8762 '(list "testfile-l7-a1" "testfile-l7-b1" "testfile-l7-c1" "testfile-l7-d1")) 8763 #t) 8764 (equal? 8765 (separate-eval 8766 '(let () (import (testfile-l7-b1)) (b 7)) 8767 '(let () (import (testfile-l7-c1)) (c 7)) 8768 '(let () (import (testfile-l7-d1)) (d 7))) 8769 "(b . aaa)\n(c . 56)\n(d aaa 56)\n") 8770 (begin 8771 (separate-compile 8772 '(lambda (x) (for-each compile-library x)) 8773 '(list "testfile-l7-a1" "testfile-l7-b1" "testfile-l7-c1")) 8774 #t) 8775 (equal? 8776 (separate-eval 8777 '(let () (import (testfile-l7-b1)) (b 7)) 8778 '(let () (import (testfile-l7-c1)) (c 7)) 8779 ; this should reload from source, since dependency is out-of-date 8780 '(let () (import (testfile-l7-d1)) (d 7))) 8781 "(b . aaa)\n(c . 56)\n(d aaa 56)\n") 8782 (equal? 8783 (separate-eval 8784 ; this should reload from source, since dependency is out-of-date 8785 '(let () (import (testfile-l7-d1)) (d 7)) 8786 '(let () (import (testfile-l7-c1)) (c 7)) 8787 '(let () (import (testfile-l7-b1)) (b 7))) 8788 "(d aaa 56)\n(c . 56)\n(b . aaa)\n") 8789 (error? ; expected different compilation instance 8790 (separate-eval 8791 '(let () (import (testfile-l7-b1)) (b 7)) 8792 '(let () (import (testfile-l7-c1)) (c 7)) 8793 '(load-library "testfile-l7-d1.so") 8794 '(let () (import (testfile-l7-d1)) (d 7)))) 8795 (error? ; expected different compilation instance 8796 (separate-eval 8797 '(load-library "testfile-l7-d1.so") 8798 '(let () (import (testfile-l7-d1)) (d 7)))) 8799 (equal? 8800 (separate-eval 8801 '(load-library "testfile-l7-b1.ss") 8802 '(let () (import (testfile-l7-b1)) (b 7)) 8803 ; this should reload from source, since dependency is out-of-date 8804 '(let () (import (testfile-l7-c1)) (c 7)) 8805 ; this should reload from source, since dependency is out-of-date 8806 '(let () (import (testfile-l7-d1)) (d 7))) 8807 "(b . aaa)\n(c . 56)\n(d aaa 56)\n") 8808 (error? ; expected different compilation instance 8809 (separate-eval 8810 '(load-library "testfile-l7-b1.ss") 8811 '(load-library "testfile-l7-c1.ss") 8812 '(load-library "testfile-l7-d1.so") 8813 '(let () (import (testfile-l7-d1)) (d 7)))) 8814 (begin 8815 (delete-file "testfile-l7-a1.so") 8816 #t) 8817 (equal? 8818 (separate-eval 8819 '(parameterize ([compile-imported-libraries #t]) (compile-library "testfile-l7-b1.ss")) 8820 '(let () (import (testfile-l7-b1)) (b 7)) 8821 ; this should reload from source, since dependency is out-of-date 8822 '(let () (import (testfile-l7-c1)) (c 7)) 8823 '(let () (import (testfile-l7-d1)) (d 7))) 8824 "compiling testfile-l7-b1.ss with output to testfile-l7-b1.so\ncompiling testfile-l7-a1.ss with output to testfile-l7-a1.so\n(b . aaa)\n(c . 56)\n(d aaa 56)\n") 8825 (begin 8826 (delete-file "testfile-l7-a1.so") 8827 #t) 8828 (error? ; expected different compilation instance 8829 (separate-eval 8830 '(parameterize ([compile-imported-libraries #t]) (compile-library "testfile-l7-b1.ss")) 8831 '(load-library "testfile-l7-c1.so") 8832 '(let () (import (testfile-l7-c1)) (c 7)))) 8833 (equal? 8834 (separate-eval 8835 '(library (testfile-l7-a1) (export a-macro a) (import (chezscheme)) (define-syntax a-macro (identifier-syntax 'aaa2)) (define (a x) (* x 11))) 8836 '(let () (import (testfile-l7-b1)) (b 7)) 8837 '(let () (import (testfile-l7-c1)) (c 7)) 8838 '(let () (import (testfile-l7-d1)) (d 7))) 8839 "(b . aaa2)\n(c . 77)\n(d aaa2 77)\n") 8840 (error? ; expected different compilation instance 8841 (separate-eval 8842 '(library (testfile-l7-a1) (export a-macro a) (import (chezscheme)) (define-syntax a-macro (identifier-syntax 'aaa2)) (define (a x) (* x 11))) 8843 '(let () (import (testfile-l7-b1)) (b 7)) 8844 '(let () (import (testfile-l7-c1)) (c 7)) 8845 '(load-library "testfile-l7-d1.so") 8846 '(let () (import (testfile-l7-d1)) (d 7)))) 8847) 8848 8849(mat library-regression 8850 ; test that failing invoke code does not result in cyclic dependency problem on re-run 8851 (equal? 8852 (separate-eval 8853 '(begin 8854 (library (invoke-fail) 8855 (export x) 8856 (import (chezscheme)) 8857 (define x #f) 8858 (error #f "failed to load library (invoke-fail)")) 8859 (guard (e [else 8860 (guard (e2 [else 8861 (display-condition e) (newline) 8862 (display-condition e2) (newline)]) 8863 (eval 'x (environment '(chezscheme) '(invoke-fail))))]) 8864 (eval 'x (environment '(chezscheme) '(invoke-fail)))))) 8865 "Exception: failed to load library (invoke-fail)\nException: failed to load library (invoke-fail)\n") 8866 8867 ; test that true cyclic dependency will always report the same thing 8868 (equal? 8869 (separate-eval 8870 '(begin 8871 (library (invoke-cyclic) 8872 (export x y) 8873 (import (chezscheme)) 8874 (define x #f) 8875 (define y (eval '(if x 5 10) (environment '(chezscheme) '(invoke-cyclic))))) 8876 (guard (e [else 8877 (guard (e2 [else 8878 (display-condition e) (newline) 8879 (display-condition e2) (newline)]) 8880 (eval 'x (environment '(chezscheme) '(invoke-cyclic))))]) 8881 (eval 'x (environment '(chezscheme) '(invoke-cyclic)))))) 8882 "Exception: cyclic dependency involving invocation of library (invoke-cyclic)\nException: cyclic dependency involving invocation of library (invoke-cyclic)\n") 8883 8884 (begin 8885 ; library to help make it easier to cause a failure in the visit-code that 8886 ; does not lead to failure during compilation of the file. 8887 (with-output-to-file "testfile-lr-l1.ss" 8888 (lambda () 8889 (pretty-print 8890 '(library (testfile-lr-l1) 8891 (export make-it-fail) 8892 (import (chezscheme)) 8893 (define make-it-fail (make-parameter #f (lambda (x) (and x #t))))))) 8894 'replace) 8895 ; simple test to define one macro and potentially to raise an error when 8896 ; defining the second one. 8897 (with-output-to-file "testfile-lr-l2.ss" 8898 (lambda () 8899 (pretty-print 8900 '(library (testfile-lr-l2) 8901 (export M1 M2) 8902 (import (chezscheme) (testfile-lr-l1)) 8903 (define-syntax M1 8904 (identifier-syntax #f)) 8905 8906 (define-syntax M2 8907 (if (make-it-fail) 8908 (error 'M2 "user requested failure with (make-it-fail) parameter") 8909 (lambda (x) 8910 (syntax-case x () 8911 [(_ expr) #'expr]))))))) 8912 'replace) 8913 ; more complete test that attempts to create the various types of things 8914 ; that can be defined in visit code so that we can verify things are being 8915 ; properly reset. 8916 (with-output-to-file "testfile-lr-l3.ss" 8917 (lambda () 8918 (pretty-print 8919 '(library (testfile-lr-l3) 8920 (export a b c d e f g h) 8921 (import (chezscheme) (testfile-lr-l1)) 8922 8923 (module a (x) (define x 5)) 8924 (alias b cons) 8925 (define-syntax c (make-compile-time-value 5)) 8926 (define d 5) 8927 (meta define e 5) 8928 (define-syntax f (identifier-syntax #f)) 8929 (define $g (make-parameter #f)) 8930 (define-syntax g 8931 (make-variable-transformer 8932 (lambda (x) 8933 (syntax-case x () 8934 [(set! _ v) #'($g v)] 8935 [_ #'($g)] 8936 [(_ e* ...) #'(($g) e* ...)])))) 8937 (define-property f g 10) 8938 (define-syntax h 8939 (if (make-it-fail) 8940 (error 'h "user requested failure with (make-it-fail) parameter") 8941 (lambda (x) 8942 (syntax-case x () 8943 [(_ expr) #'expr]))))))) 8944 'replace) 8945 (separate-compile 8946 '(lambda (x) 8947 (parameterize ([compile-imported-libraries #t]) 8948 (for-each compile-library x))) 8949 '(list "testfile-lr-l1" "testfile-lr-l2" "testfile-lr-l3")) 8950 #t) 8951 8952 (equal? 8953 (separate-eval 8954 '(begin 8955 (import (testfile-lr-l2) (testfile-lr-l1)) 8956 (make-it-fail #t) 8957 (guard (e [else 8958 (guard (e2 8959 [else 8960 (display-condition e) (newline) 8961 (display-condition e2) (newline)]) 8962 (eval 'M1 (environment '(testfile-lr-l2))))]) 8963 (eval 'M1 (environment '(testfile-lr-l2)))))) 8964 "Exception in M2: user requested failure with (make-it-fail) parameter\nException in M2: user requested failure with (make-it-fail) parameter\n") 8965 8966 ; module is defined as part of import code, run time bindings are setup as part of invoke code 8967 (equal? 8968 (separate-eval 8969 '(begin 8970 (import (testfile-lr-l3) (testfile-lr-l1)) 8971 (make-it-fail #t) 8972 (import a) 8973 x)) 8974 "5\n") 8975 8976 ; alias is part of module binding ribcage, set up by import code 8977 (equal? 8978 (separate-eval 8979 '(begin 8980 (import (testfile-lr-l3) (testfile-lr-l1)) 8981 (make-it-fail #t) 8982 (b 'a 'b))) 8983 "(a . b)\n") 8984 8985 ; compile-time-value is set in visit code, should show same error each time it is referenced 8986 (equal? 8987 (separate-eval 8988 '(begin 8989 (library (lookup) 8990 (export lookup) 8991 (import (chezscheme)) 8992 (define-syntax lookup 8993 (lambda (x) 8994 (syntax-case x () 8995 [(_ id) (lambda (rho) #`'#,(rho #'id))] 8996 [(_ id key) (lambda (rho) #`'#,(rho #'id #'key))])))) 8997 (import (testfile-lr-l3) (testfile-lr-l1)) 8998 (make-it-fail #t) 8999 (guard (e [else 9000 (guard (e2 9001 [else 9002 (display-condition e) (newline) 9003 (display-condition e2) (newline)]) 9004 (eval '(lookup c) (environment '(testfile-lr-l3) '(lookup))))]) 9005 (eval '(lookup c) (environment '(testfile-lr-l3) '(lookup)))))) 9006 "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n") 9007 9008 ; defines are set up as part of invoke code 9009 (equal? 9010 (separate-eval 9011 '(begin 9012 (import (testfile-lr-l3) (testfile-lr-l1)) 9013 (make-it-fail #t) 9014 d)) 9015 "5\n") 9016 9017 ; meta defines are set up as part of visit code 9018 (equal? 9019 (separate-eval 9020 '(begin 9021 (import (testfile-lr-l3) (testfile-lr-l1)) 9022 (make-it-fail #t) 9023 (guard (e [else 9024 (guard (e2 9025 [else 9026 (display-condition e) (newline) 9027 (display-condition e2) (newline)]) 9028 (eval '(let () 9029 (define-syntax get-e 9030 (lambda (x) 9031 (syntax-case x () 9032 [(_) #`'#,e]))) 9033 (get-e)) 9034 (environment '(chezscheme) '(testfile-lr-l3))))]) 9035 (eval '(let () 9036 (define-syntax get-e 9037 (lambda (x) 9038 (syntax-case x () 9039 [(_) #`'#,e]))) 9040 (get-e)) 9041 (environment '(chezscheme) '(testfile-lr-l3)))))) 9042 "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n") 9043 9044 ; macros are set up as part of visit code 9045 (equal? 9046 (separate-eval 9047 '(begin 9048 (import (testfile-lr-l3) (testfile-lr-l1)) 9049 (make-it-fail #t) 9050 (guard (e [else 9051 (guard (e2 9052 [else 9053 (display-condition e) (newline) 9054 (display-condition e2) (newline)]) 9055 (eval 'f (environment '(testfile-lr-l3))))]) 9056 (eval 'f (environment '(testfile-lr-l3)))))) 9057 "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n") 9058 9059 ; variable transformer macros are set up as part of visit code 9060 (equal? 9061 (separate-eval 9062 '(begin 9063 (import (testfile-lr-l3) (testfile-lr-l1)) 9064 (make-it-fail #t) 9065 (guard (e [else 9066 (guard (e2 9067 [else 9068 (display-condition e) (newline) 9069 (display-condition e2) (newline)]) 9070 (eval 'g (environment '(testfile-lr-l3))))]) 9071 (eval 'g (environment '(testfile-lr-l3)))))) 9072 "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n") 9073 9074 ; properties are setup as part of visit code. 9075 (equal? 9076 (separate-eval 9077 '(begin 9078 (library (lookup) 9079 (export lookup) 9080 (import (chezscheme)) 9081 (define-syntax lookup 9082 (lambda (x) 9083 (syntax-case x () 9084 [(_ id) (lambda (rho) #`'#,(rho #'id))] 9085 [(_ id key) (lambda (rho) #`'#,(rho #'id #'key))])))) 9086 (import (testfile-lr-l3) (testfile-lr-l1)) 9087 (make-it-fail #t) 9088 (guard (e [else 9089 (guard (e2 9090 [else 9091 (display-condition e) (newline) 9092 (display-condition e2) (newline)]) 9093 (eval '(lookup f g) (environment '(testfile-lr-l3) '(lookup))))]) 9094 (eval '(lookup f g) (environment '(testfile-lr-l3) '(lookup)))))) 9095 "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n") 9096 9097 ;; re-arm import code if it complains about a library that is not visible 9098 (begin 9099 (with-output-to-file "testfile-lr-l4.ss" 9100 (lambda () 9101 (pretty-print 9102 '(library (testfile-lr-l4) 9103 (export x) 9104 (import (chezscheme)) 9105 (define x 123)))) 9106 'replace) 9107 (with-output-to-file "testfile-lr-p4.ss" 9108 (lambda () 9109 (for-each pretty-print 9110 '((import (testfile-lr-l4) (scheme)) 9111 (define (run args) 9112 (guard (c [#t (display-condition c) (newline)]) 9113 (pretty-print (top-level-value (car args) (environment (cdr args)))))) 9114 (when (> x 0) ;; reference export 9115 (let ([args (map string->symbol (command-line-arguments))]) 9116 (if (= (length args) 2) 9117 (begin 9118 (run args) 9119 (run args)) 9120 (error #f "expected 2 args"))))))) 9121 'replace) 9122 (separate-eval 9123 '(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t]) 9124 (compile-program "testfile-lr-p4.ss") 9125 (compile-whole-program "testfile-lr-p4.wpo" "testfile-lr-p4-visible" #t) 9126 (compile-whole-program "testfile-lr-p4.wpo" "testfile-lr-p4-not-visible" #f))) 9127 (equal? 9128 (separate-eval 9129 '(parameterize ([command-line-arguments '("x" "testfile-lr-l4")]) 9130 (load-program "testfile-lr-p4-visible") 9131 (load-program "testfile-lr-p4-not-visible"))) 9132 (string-append 9133 "123\n" 9134 "123\n" 9135 "Exception in environment: attempt to import invisible library (testfile-lr-l4)\n" 9136 "Exception in environment: attempt to import invisible library (testfile-lr-l4)\n")))) 9137 9138(mat invoke-library 9139 (error? ; invalid library reference 9140 (invoke-library '(testfile-il1 (<= 3)))) 9141 (error? ; invalid library reference 9142 (invoke-library '(testfile-il1 (what?)))) 9143 (error? ; invalid library reference 9144 (invoke-library '())) 9145 (error? ; invalid library reference 9146 (invoke-library 'hello)) 9147 (error? ; invalid library reference 9148 (invoke-library '(3 2 1))) 9149 (begin 9150 (mkfile "testfile-il1.ss" 9151 '(library (testfile-il1 (2)) (export a) (import (chezscheme)) (define a 3) (printf "invoked (testfile-il1)\n"))) 9152 #t) 9153 (equal? 9154 (separate-eval 9155 '(let () (import (testfile-il1)) a)) 9156 "invoked (testfile-il1)\n3\n") 9157 (equal? 9158 (separate-eval 9159 '(invoke-library '(testfile-il1))) 9160 "invoked (testfile-il1)\n") 9161 (equal? 9162 (separate-eval 9163 '(invoke-library '(testfile-il1)) 9164 '(printf "hello\n") 9165 '(let () (import (testfile-il1)) a)) 9166 "invoked (testfile-il1)\nhello\n3\n") 9167 (equal? 9168 (separate-eval 9169 '(let () (import (testfile-il1)) a) 9170 '(printf "hello\n") 9171 '(invoke-library '(testfile-il1))) 9172 "invoked (testfile-il1)\n3\nhello\n") 9173 (begin 9174 (separate-eval '(compile-library "testfile-il1")) 9175 #t) 9176 (delete-file "testfile-il1.ss") 9177 (equal? 9178 (separate-eval 9179 '(let () (import (testfile-il1)) a)) 9180 "invoked (testfile-il1)\n3\n") 9181 (equal? 9182 (separate-eval 9183 '(invoke-library '(testfile-il1))) 9184 "invoked (testfile-il1)\n") 9185 (equal? 9186 (separate-eval 9187 '(invoke-library '(testfile-il1)) 9188 '(printf "hello\n") 9189 '(let () (import (testfile-il1)) a)) 9190 "invoked (testfile-il1)\nhello\n3\n") 9191 (equal? 9192 (separate-eval 9193 '(let () (import (testfile-il1)) a) 9194 '(printf "hello\n") 9195 '(invoke-library '(testfile-il1))) 9196 "invoked (testfile-il1)\n3\nhello\n") 9197 (error? ; version mismatch 9198 (separate-eval '(invoke-library '(testfile-il1 (3))))) 9199 (error? ; version mismatch 9200 (separate-eval 9201 '(invoke-library '(testfile-il1 ((>= 3)))))) 9202 (equal? 9203 (separate-eval 9204 '(invoke-library '(testfile-il1 ((>= 2))))) 9205 "invoked (testfile-il1)\n") 9206 (equal? 9207 (separate-eval 9208 '(invoke-library '(testfile-il1 (2)))) 9209 "invoked (testfile-il1)\n") 9210) 9211 9212(mat cross-library-optimization 9213 (begin 9214 (with-output-to-file "testfile-clo-1a.ss" 9215 (lambda () 9216 (pretty-print 9217 '(library (testfile-clo-1a) 9218 (export f) 9219 (import (chezscheme)) 9220 (define f (lambda (s) (format "~s!\n" s)))))) 9221 'replace) 9222 (with-output-to-file "testfile-clo-1b.ss" 9223 (lambda () 9224 (pretty-print 9225 '(import (chezscheme) (testfile-clo-1a))) 9226 (pretty-print 9227 '(display-string (f 'hello)))) 9228 'replace) 9229 #t) 9230 (eqv? (compile-library "testfile-clo-1a") (void)) 9231 ; in this case, can't propage f because of the embedded string constant, 9232 ; so program depends on library at run time 9233 (equal? (compile-program "testfile-clo-1b") '((testfile-clo-1a))) 9234 (equal? 9235 (with-output-to-string 9236 (lambda () (load-program "testfile-clo-1b.so"))) 9237 "hello!\n") 9238 (begin 9239 (with-output-to-file "testfile-clo-2a.ss" 9240 (lambda () 9241 (pretty-print 9242 '(library (testfile-clo-2a) 9243 (export f) 9244 (import (chezscheme)) 9245 (define f (lambda (s) (symbol->string s)))))) 9246 'replace) 9247 (with-output-to-file "testfile-clo-2b.ss" 9248 (lambda () 9249 (pretty-print 9250 '(import (chezscheme) (testfile-clo-2a))) 9251 (pretty-print 9252 '(display-string (f 'hello)))) 9253 'replace) 9254 #t) 9255 (eqv? (compile-library "testfile-clo-2a") (void)) 9256 ; in this case, nothing stopping propagation of f, 9257 ; so program doesn't necessarily depend on library at run time 9258 (and (member 9259 (compile-program "testfile-clo-2b") 9260 '(() ((testfile-clo-2a)))) 9261 #t) 9262 (equal? 9263 (with-output-to-string 9264 (lambda () (load-program "testfile-clo-2b.so"))) 9265 "hello") 9266 ; testing internal consistency for library w/externally visible side effect, which we don't guarantee 9267 ; will happen if all runtime references are optimized away 9268 (begin 9269 (with-output-to-file "testfile-clo-3a.ss" 9270 (lambda () 9271 (pretty-print 9272 '(library (testfile-clo-3a) 9273 (export g h) 9274 (import (chezscheme)) 9275 (define (f) (putprop 'spam 'canned #t)) 9276 (define (g) (getprop 'spam 'canned #f)) 9277 (define (h) (remprop 'spam 'canned)) 9278 (f)))) 9279 'replace) 9280 (with-output-to-file "testfile-clo-3b.ss" 9281 (lambda () 9282 (pretty-print 9283 '(import (chezscheme) (testfile-clo-3a))) 9284 (pretty-print 9285 '(write (g)))) 9286 'replace) 9287 #t) 9288 (equal? 9289 (let ([libs (parameterize ([compile-imported-libraries #t]) (compile-program "testfile-clo-3b"))]) 9290 (cond 9291 ; if compiled program depends on the library, the externally visible side effect (putprop) will be done 9292 [(equal? libs '((testfile-clo-3a))) 9293 (cons 9294 (equal? (with-output-to-string (lambda () (load-program "testfile-clo-3b.so"))) "#t") 9295 (let () (import (testfile-clo-3a)) (g)))] 9296 ; otherwise not 9297 [(equal? libs '()) 9298 (cons 9299 (equal? (with-output-to-string (lambda () (load-program "testfile-clo-3b.so"))) "#f") 9300 (not (let () (import (testfile-clo-3a)) (g))))] 9301 [else 'oops])) 9302 '(#t . #t)) 9303 (equal? (let () (import (testfile-clo-3a)) (h)) (void)) 9304 (not (let () (import (testfile-clo-3a)) (g))) 9305 9306 ; testing support of procedures with improper formals 9307 (begin 9308 (with-output-to-file "testfile-clo-4a.ss" 9309 (lambda () 9310 (pretty-print 9311 '(library (testfile-clo-4a) 9312 (export f g) 9313 (import (chezscheme)) 9314 (define (f a . rest) 9315 (apply list a rest)) 9316 (define g 9317 (case-lambda 9318 [(a) "foo"] 9319 [(a . rest) (apply list a rest)]))))) 9320 'replace) 9321 #t) 9322 (begin 9323 (load-library "testfile-clo-4a.ss" 9324 (lambda (x) (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [current-eval compile]) 9325 (eval x)))) 9326 #t) 9327 (or 9328 (and (compile-profile) #t) ; => testfile-clo-4a was compiled with profiling, so not quite the same as below 9329 (equivalent-expansion? 9330 (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) 9331 (expand/optimize 9332 '(lambda (x y z) 9333 (import (testfile-clo-4a)) 9334 (list 9335 (f x y z) 9336 (g x y z))))) 9337 '(begin 9338 (#3%$invoke-library '(testfile-clo-4a) '() 'testfile-clo-4a) 9339 (lambda (x y z) 9340 (#2%list (#2%list x y z) 9341 ((#3%$top-level-value 'g) x y z)))))) 9342) 9343 9344(mat lots-of-libraries 9345 (begin 9346 (define (lol-mklibname n) (string->symbol (format "testfile-lol-~d" n))) 9347 (define (lol-mkvarname n) (string->symbol (format "n~d" n))) 9348 (define lol-fiblib 9349 (lambda (n) 9350 (let fiblib ([n n]) 9351 (if (fx= n 1) 9352 `((library (testfile-lol-1) (export n1) (import (chezscheme)) (define n1 1)) 9353 (library (testfile-lol-0) (export n0) (import (chezscheme)) (define n0 0))) 9354 (cons 9355 `(library (,(lol-mklibname n)) 9356 (export ,(lol-mkvarname n)) 9357 (import (chezscheme) (,(lol-mklibname (fx- n 1))) (,(lol-mklibname (fx- n 2)))) 9358 (define ,(lol-mkvarname n) (+ ,(lol-mkvarname (fx- n 1)) ,(lol-mkvarname (fx- n 2))))) 9359 (fiblib (fx- n 1))))))) 9360 #t) 9361 (eqv? 9362 (let ([n 10]) 9363 (eval `(begin ,@(reverse (lol-fiblib n)) (let () (import (,(lol-mklibname n))) ,(lol-mkvarname n))))) 9364 55) 9365 (begin 9366 (define lol-n 100) 9367 (do ([lib* (lol-fiblib lol-n) (cdr lib*)] [n lol-n (fx- n 1)]) 9368 ((null? lib*)) 9369 (with-output-to-file (format "~s.ss" (lol-mklibname n)) 9370 (lambda () (pretty-print (car lib*))) 9371 'replace)) 9372 (with-output-to-file "testfile-lol-prog.ss" 9373 (lambda () 9374 (for-each pretty-print 9375 `((import (chezscheme) (,(lol-mklibname lol-n))) 9376 (pretty-print ,(lol-mkvarname lol-n))))) 9377 'replace) 9378 (define $lol-watchdog 9379 (let ([t (current-time 'time-utc)]) 9380 (let ([time-n 3]) 9381 (separate-eval 9382 `(parameterize ([compile-imported-libraries #t]) 9383 (compile-library ,(format "~a.ss" (lol-mklibname time-n))))) 9384 (do ([n 0 (+ n 1)]) ((> n time-n)) (delete-file (format "~a.so" (lol-mklibname n))))) 9385 (let ([t (time-difference (current-time 'time-utc) t)]) 9386 (let ([t-reasonable 9387 (let ([ns (* (+ (* (time-second t) (expt 10 9)) (time-nanosecond t)) lol-n)]) 9388 (make-time 'time-duration (remainder ns (expt 10 9)) (quotient ns (expt 10 9))))]) 9389 `(let ([t (current-time 'time-utc)]) 9390 (timer-interrupt-handler 9391 (let ([t-reasonable (make-time 'time-duration ,(time-nanosecond t-reasonable) ,(time-second t-reasonable))]) 9392 (lambda () 9393 (unless (time<=? (time-difference (current-time 'time-utc) t) t-reasonable) 9394 (errorf #f "unreasonable time elapsed")) 9395 (set-timer 10000)))) 9396 ((timer-interrupt-handler))))))) 9397 #t) 9398 (string? 9399 (separate-compile 9400 `(lambda (x) 9401 ,$lol-watchdog 9402 (parameterize ([compile-imported-libraries #t]) 9403 (compile-program x))) 9404 'lol-prog)) 9405 (equal? 9406 (separate-eval `(begin ,$lol-watchdog (load-program "testfile-lol-prog.so"))) 9407 (format "~d\n" 9408 (let fib ([i 1] [n1 1] [n0 0]) 9409 (if (fx= i lol-n) 9410 n1 9411 (fib (+ i 1) (+ n1 n0) n1))))) 9412 ; test rebuild 9413 (string? 9414 (separate-compile 9415 `(lambda (x) 9416 ,$lol-watchdog 9417 (parameterize ([compile-imported-libraries #t]) 9418 (compile-program x))) 9419 'lol-prog)) 9420 ; test maybe rebuild 9421 (string? 9422 (separate-compile 9423 `(lambda (x) 9424 ,$lol-watchdog 9425 (parameterize ([compile-imported-libraries #t]) 9426 (maybe-compile-program x))) 9427 'lol-prog)) 9428) 9429 9430(mat import-dependencies 9431 (begin 9432 (with-output-to-file "testfile-a.ss" 9433 (lambda () 9434 (pretty-print 9435 '(library (testfile-a) (export a x) (import (chezscheme)) 9436 (define-syntax a (begin (printf "ct\n") (identifier-syntax 3))) 9437 (define x (begin (printf "rt\n") 4))))) 9438 'replace) 9439 (separate-compile 'compile-library 'a) 9440 #t) 9441 (begin 9442 (with-output-to-file "testfile-m1.ss" 9443 (lambda () 9444 (pretty-print 9445 '(module (q1) 9446 (import (testfile-a)) 9447 (define-syntax q1 (identifier-syntax a))))) 9448 'replace) 9449 (separate-compile 'compile-file 'm1) 9450 #t) 9451 (equal? 9452 (separate-eval '(load "testfile-m1.so") 'q1) 9453 "ct\n3\n") 9454 (begin 9455 (with-output-to-file "testfile-m2.ss" 9456 (lambda () 9457 (pretty-print 9458 '(module (q2) 9459 (import (testfile-a)) 9460 (define-syntax q2 (identifier-syntax x))))) 9461 'replace) 9462 (separate-compile 'compile-file 'm2) 9463 #t) 9464 (equal? 9465 (separate-eval '(load "testfile-m2.so") 'q2) 9466 "rt\n4\n") 9467 (begin 9468 (sleep (make-time 'time-duration 1000000 1)) 9469 (with-output-to-file "testfile-a.ss" 9470 (lambda () 9471 (pretty-print 9472 '(library (testfile-a) (export a x) (import (chezscheme)) 9473 (define-syntax a (begin (printf "ct\n") (identifier-syntax 33))) 9474 (define x (begin (printf "rt\n") 44))))) 9475 'replace) 9476 (separate-compile 'compile-library 'a) 9477 (separate-compile 'maybe-compile-file 'm1) 9478 (separate-compile 'maybe-compile-file 'm2) 9479 #t) 9480 (equal? 9481 (separate-eval '(load "testfile-m1.so") 'q1) 9482 "ct\n33\n") 9483 (equal? 9484 (separate-eval '(load "testfile-m2.so") 'q2) 9485 "rt\n44\n") 9486 ; -------- 9487 (begin 9488 (with-output-to-file "testfile-a.ss" 9489 (lambda () 9490 (pretty-print 9491 '(library (testfile-a) (export a x) (import (chezscheme)) 9492 (define-syntax a (begin (printf "ct\n") (identifier-syntax 3))) 9493 (define x (begin (printf "rt\n") 4))))) 9494 'replace) 9495 (separate-compile 'compile-library 'a) 9496 #t) 9497 (begin 9498 (with-output-to-file "testfile-m3.ss" 9499 (lambda () 9500 (pretty-print 9501 '(define-syntax q3 (let () (import (testfile-a)) (identifier-syntax a))))) 9502 'replace) 9503 (separate-compile 'compile-file 'm3) 9504 #t) 9505 (equal? 9506 (separate-eval '(load "testfile-m3.so") 'q3) 9507 "ct\n3\n") 9508 (begin 9509 (with-output-to-file "testfile-m4.ss" 9510 (lambda () 9511 (pretty-print 9512 '(define-syntax q4 (let () (import (testfile-a)) (identifier-syntax x))))) 9513 'replace) 9514 (separate-compile 'compile-file 'm4) 9515 #t) 9516 (equal? 9517 (separate-eval '(load "testfile-m4.so") 'q4) 9518 "rt\n4\n") 9519 (begin 9520 (sleep (make-time 'time-duration 1000000 1)) 9521 (with-output-to-file "testfile-a.ss" 9522 (lambda () 9523 (pretty-print 9524 '(library (testfile-a) (export a x) (import (chezscheme)) 9525 (define-syntax a (begin (printf "ct\n") (identifier-syntax 33))) 9526 (define x (begin (printf "rt\n") 44))))) 9527 'replace) 9528 (separate-compile 'compile-library 'a) 9529 (separate-compile 'maybe-compile-file 'm3) 9530 (separate-compile 'maybe-compile-file 'm4) 9531 #t) 9532 (equal? 9533 (separate-eval '(load "testfile-m3.so") 'q3) 9534 "ct\n33\n") 9535 (equal? 9536 (separate-eval '(load "testfile-m4.so") 'q4) 9537 "rt\n44\n") 9538 ; -------- 9539 (begin 9540 (with-output-to-file "testfile-a.ss" 9541 (lambda () 9542 (pretty-print 9543 '(library (testfile-a) (export a x) (import (chezscheme)) 9544 (define-syntax a (begin (printf "ct\n") (identifier-syntax 3))) 9545 (define x (begin (printf "rt\n") 4))))) 9546 'replace) 9547 (separate-compile 'compile-library 'a) 9548 #t) 9549 (begin 9550 (with-output-to-file "testfile-m5.ss" 9551 (lambda () 9552 (pretty-print 9553 '(define-property q5 q5 (let () (import (testfile-a)) #'a)))) 9554 'replace) 9555 (separate-compile 'compile-file 'm5) 9556 #t) 9557 (equal? 9558 (separate-eval 9559 '(load "testfile-m5.so") 9560 '(let () 9561 (define-syntax ref-prop 9562 (lambda (x) 9563 (lambda (r) 9564 (syntax-case x () 9565 [(_ id key) (r #'id #'key)])))) 9566 (ref-prop q5 q5))) 9567 "ct\n3\n") 9568 (begin 9569 (with-output-to-file "testfile-m6.ss" 9570 (lambda () 9571 (pretty-print 9572 '(define-property q6 q6 (let () (import (testfile-a)) #'x)))) 9573 'replace) 9574 (separate-compile 'compile-file 'm6) 9575 #t) 9576 (equal? 9577 (separate-eval '(load "testfile-m6.so") 9578 '(let () 9579 (define-syntax ref-prop 9580 (lambda (x) 9581 (lambda (r) 9582 (syntax-case x () 9583 [(_ id key) (r #'id #'key)])))) 9584 (ref-prop q6 q6))) 9585 "rt\n4\n") 9586 (begin 9587 (sleep (make-time 'time-duration 1000000 1)) 9588 (with-output-to-file "testfile-a.ss" 9589 (lambda () 9590 (pretty-print 9591 '(library (testfile-a) (export a x) (import (chezscheme)) 9592 (define-syntax a (begin (printf "ct\n") (identifier-syntax 33))) 9593 (define x (begin (printf "rt\n") 44))))) 9594 'replace) 9595 (separate-compile 'compile-library 'a) 9596 (separate-compile 'maybe-compile-file 'm5) 9597 (separate-compile 'maybe-compile-file 'm6) 9598 #t) 9599 (equal? 9600 (separate-eval 9601 '(load "testfile-m5.so") 9602 '(let () 9603 (define-syntax ref-prop 9604 (lambda (x) 9605 (lambda (r) 9606 (syntax-case x () 9607 [(_ id key) (r #'id #'key)])))) 9608 (ref-prop q5 q5))) 9609 "ct\n33\n") 9610 (equal? 9611 (separate-eval '(load "testfile-m6.so") 9612 '(let () 9613 (define-syntax ref-prop 9614 (lambda (x) 9615 (lambda (r) 9616 (syntax-case x () 9617 [(_ id key) (r #'id #'key)])))) 9618 (ref-prop q6 q6))) 9619 "rt\n44\n") 9620 ; -------- 9621 (begin 9622 (with-output-to-file "testfile-a.ss" 9623 (lambda () 9624 (pretty-print 9625 '(library (testfile-a) (export a x) (import (chezscheme)) 9626 (define-syntax a (begin (printf "ct\n") (identifier-syntax 3))) 9627 (define x (begin (printf "rt\n") 4))))) 9628 'replace) 9629 (separate-compile 'compile-library 'a) 9630 #t) 9631 (begin 9632 (with-output-to-file "testfile-m7.ss" 9633 (lambda () 9634 (pretty-print 9635 '(meta define q7 (let () (import (testfile-a)) #'a)))) 9636 'replace) 9637 (separate-compile 'compile-file 'm7) 9638 #t) 9639 (equal? 9640 (separate-eval 9641 '(load "testfile-m7.so") 9642 '(let () 9643 (define-syntax qq (lambda (x) q7)) 9644 qq)) 9645 "ct\n3\n") 9646 (begin 9647 (with-output-to-file "testfile-m8.ss" 9648 (lambda () 9649 (pretty-print 9650 '(meta define q8 (let () (import (testfile-a)) #'x)))) 9651 'replace) 9652 (separate-compile 'compile-file 'm8) 9653 #t) 9654 (equal? 9655 (separate-eval 9656 '(load "testfile-m8.so") 9657 '(let () 9658 (define-syntax qq (lambda (x) q8)) 9659 qq)) 9660 "rt\n4\n") 9661 (begin 9662 (sleep (make-time 'time-duration 1000000 1)) 9663 (with-output-to-file "testfile-a.ss" 9664 (lambda () 9665 (pretty-print 9666 '(library (testfile-a) (export a x) (import (chezscheme)) 9667 (define-syntax a (begin (printf "ct\n") (identifier-syntax 33))) 9668 (define x (begin (printf "rt\n") 44))))) 9669 'replace) 9670 (separate-compile 'compile-library 'a) 9671 (separate-compile 'maybe-compile-file 'm7) 9672 (separate-compile 'maybe-compile-file 'm8) 9673 #t) 9674 (equal? 9675 (separate-eval 9676 '(load "testfile-m7.so") 9677 '(let () 9678 (define-syntax qq (lambda (x) q7)) 9679 qq)) 9680 "ct\n33\n") 9681 (equal? 9682 (separate-eval 9683 '(load "testfile-m8.so") 9684 '(let () 9685 (define-syntax qq (lambda (x) q8)) 9686 qq)) 9687 "rt\n44\n") 9688) 9689 9690(mat eval-when-library 9691 (begin 9692 (with-output-to-file "testfile-ewl1.ss" 9693 (lambda () 9694 (pretty-print 9695 '(eval-when () 9696 (library (testfile-ewl1) 9697 (export x) 9698 (import (rnrs)) 9699 (define-syntax x (identifier-syntax 23)))))) 9700 'replace) 9701 (with-output-to-file "testfile-ewl2.ss" 9702 (lambda () 9703 (pretty-print 9704 '(eval-when (eval) 9705 (library (testfile-ewl2) 9706 (export x) 9707 (import (rnrs)) 9708 (define-syntax x (identifier-syntax 23)))))) 9709 'replace) 9710 (with-output-to-file "testfile-ewl3.ss" 9711 (lambda () 9712 (pretty-print 9713 '(eval-when (load) 9714 (library (testfile-ewl3) 9715 (export x) 9716 (import (rnrs)) 9717 (define-syntax x (identifier-syntax 23)))))) 9718 'replace) 9719 (with-output-to-file "testfile-ewl4.ss" 9720 (lambda () 9721 (pretty-print 9722 '(eval-when (visit) 9723 (library (testfile-ewl4) 9724 (export x) 9725 (import (rnrs)) 9726 (define-syntax x (identifier-syntax 23)))))) 9727 'replace) 9728 (with-output-to-file "testfile-ewl5.ss" 9729 (lambda () 9730 (pretty-print 9731 '(eval-when (revisit) 9732 (library (testfile-ewl5) 9733 (export x) 9734 (import (rnrs)) 9735 (define-syntax x (identifier-syntax 23)))))) 9736 'replace) 9737 (with-output-to-file "testfile-ewl6.ss" 9738 (lambda () 9739 (pretty-print 9740 '(eval-when (compile) 9741 (library (testfile-ewl6) 9742 (export x) 9743 (import (rnrs)) 9744 (define-syntax x (identifier-syntax 23)))))) 9745 'replace) 9746 (for-each 9747 delete-file 9748 '("testfile-ewl1.so" "testfile-ewl2.so" "testfile-ewl3.so" "testfile-ewl4.so" 9749 "testfile-ewl5.so" "testfile-ewl6.so")) 9750 #t) 9751 ; loading testfile-ewlx.ss did not define library (testfile-ewlx) 9752 (error? (let ([x 55]) (import (testfile-ewl1)) x)) 9753 (error? (let ([x 55]) (import (testfile-ewl3)) x)) 9754 (error? (let ([x 55]) (import (testfile-ewl4)) x)) 9755 (error? (let ([x 55]) (import (testfile-ewl5)) x)) 9756 (error? (let ([x 55]) (import (testfile-ewl6)) x)) 9757 (begin 9758 (for-each separate-compile '(ewl1 ewl2 ewl3 ewl4 ewl5 ewl6)) 9759 (for-each load-library 9760 '("testfile-ewl1.so" "testfile-ewl2.so" "testfile-ewl3.so" "testfile-ewl4.so" 9761 "testfile-ewl5.so" "testfile-ewl6.so")) 9762 #t) 9763 ; loading testfile-ewlx.so did not define library (testfile-ewlx) 9764 ; actually "testfile-ewlx.ss did not ..." (ss rather than so) 9765 ; now that load-library reloads source when dependency changes 9766 (error? (let ([x 55]) (import (testfile-ewl1)) x)) 9767 (error? (let ([x 55]) (import (testfile-ewl2)) x)) 9768 (error? (let ([x 55]) (import (testfile-ewl6)) x)) 9769 (begin 9770 (load-library "testfile-ewl2.ss") 9771 (compile-library "testfile-ewl6") 9772 #t) 9773 (eqv? (let ([x 55]) (import (testfile-ewl2)) x) 23) 9774 (eqv? (let ([x 55]) (import (testfile-ewl3)) x) 23) 9775 (eqv? (let ([x 55]) (import (testfile-ewl4)) x) 23) 9776 (eqv? (let ([x 55]) (import (testfile-ewl5)) x) 23) 9777 (eqv? (let ([x 55]) (import (testfile-ewl6)) x) 23) 9778) 9779 9780(mat library-directories 9781 (error? ; invalid argument 9782 (library-directories '("a" . hello))) 9783 (error? ; invalid argument 9784 (library-directories '("a" . ("src" . "obj")))) 9785 (error? ; invalid argument 9786 (library-directories '("a" . (("src"))))) 9787 (error? ; invalid argument 9788 (library-directories '("a" . (("src" "obj"))))) 9789 (error? ; invalid argument 9790 (library-directories '("a" . ((("src" "obj")))))) 9791 (let ([x (library-directories)]) 9792 (and (list? x) 9793 (andmap (lambda (x) (and (pair? x) (string? (car x)) (string? (cdr x)))) x))) 9794 (if (windows?) 9795 (parameterize ([library-directories "a1;boo;c:/;dxxy"]) 9796 (equal? (library-directories) '(("a1" . "a1") ("boo" . "boo") ("c:/" . "c:/") ("dxxy" . "dxxy")))) 9797 (parameterize ([library-directories "a1:boo:c;/:dxxy"]) 9798 (equal? (library-directories) '(("a1" . "a1") ("boo" . "boo") ("c;/" . "c;/") ("dxxy" . "dxxy"))))) 9799 (if (windows?) 9800 (parameterize ([library-directories "a1;boo;;boo-obj;c:/;;dxxy"]) 9801 (equal? (library-directories) '(("a1" . "a1") ("boo" . "boo-obj") ("c:/" . "dxxy")))) 9802 (parameterize ([library-directories "a1:boo::boo-obj:c;/::dxxy"]) 9803 (equal? (library-directories) '(("a1" . "a1") ("boo" . "boo-obj") ("c;/" . "dxxy"))))) 9804 (let ([default (library-directories)]) 9805 (if (windows?) 9806 (parameterize ([library-directories "a1;boo;c:/;dxxy;"]) 9807 (equal? (library-directories) `(,@'(("a1" . "a1") ("boo" . "boo") ("c:/" . "c:/") ("dxxy" . "dxxy")) ,@default))) 9808 (parameterize ([library-directories "a1:boo:c;/:dxxy:"]) 9809 (equal? (library-directories) `(,@'(("a1" . "a1") ("boo" . "boo") ("c;/" . "c;/") ("dxxy" . "dxxy")) ,@default))))) 9810 (begin 9811 (with-output-to-file "testfile-ld1.ss" 9812 (lambda () 9813 (pretty-print 9814 `(library (,(string->symbol (cd)) testfile-ld1) 9815 (export x) 9816 (import (rnrs)) 9817 (define-syntax x (identifier-syntax 23))))) 9818 'replace) 9819 #t) 9820 (error? ; library not found 9821 (parameterize ([library-directories '()]) 9822 (eval `(lambda () (import (testfile-ld1)) x)))) 9823 (eqv? 9824 ((parameterize ([library-directories '()]) 9825 (eval `(lambda () (import (,(string->symbol (cd)) testfile-ld1)) x)))) 9826 23) 9827) 9828 9829(mat library-extensions 9830 (error? ; invalid argument 9831 (library-extensions '.a1.sls)) 9832 (error? ; invalid argument 9833 (library-extensions '((".foo")))) 9834 (error? ; invalid argument 9835 (library-extensions '((".foo" ".bar")))) 9836 (error? ; invalid argument 9837 (library-extensions '(((".junk"))))) 9838 (let ([x (library-extensions)]) 9839 (and (list? x) 9840 (andmap (lambda (x) (and (pair? x) (string? (car x)) (string? (cdr x)))) x))) 9841 (if (windows?) 9842 (parameterize ([library-extensions ".a1.sls;.boo;.crud;.junk"]) 9843 (equal? (library-extensions) '((".a1.sls" . ".a1.so") (".boo" . ".so") (".crud" . ".so") (".junk" . ".so")))) 9844 (parameterize ([library-extensions ".a1.sls:.boo:.crud:.junk"]) 9845 (equal? (library-extensions) '((".a1.sls" . ".a1.so") (".boo" . ".so") (".crud" . ".so") (".junk" . ".so"))))) 9846 (let ([default (library-extensions)]) 9847 (if (windows?) 9848 (parameterize ([library-extensions ".a1.sls;.boo;.crud;.junk;"]) 9849 (equal? (library-extensions) `(,@'((".a1.sls" . ".a1.so") (".boo" . ".so") (".crud" . ".so") (".junk" . ".so")) ,@default))) 9850 (parameterize ([library-extensions ".a1.sls:.boo:.crud:.junk:"]) 9851 (equal? (library-extensions) `(,@'((".a1.sls" . ".a1.so") (".boo" . ".so") (".crud" . ".so") (".junk" . ".so")) ,@default))))) 9852 (let ([default (library-extensions)]) 9853 (if (windows?) 9854 (parameterize ([library-extensions ".a1.sls;.boo;;.booso;.crud;;.junk;"]) 9855 (equal? (library-extensions) `(,@'((".a1.sls" . ".a1.so") (".boo" . ".booso") (".crud" . ".junk")) ,@default))) 9856 (parameterize ([library-extensions ".a1.sls:.boo::.booso:.crud::.junk:"]) 9857 (equal? (library-extensions) `(,@'((".a1.sls" . ".a1.so") (".boo" . ".booso") (".crud" . ".junk")) ,@default))))) 9858) 9859 9860(mat library-search-handler 9861 (procedure? (library-search-handler)) 9862 (eq? (library-search-handler) default-library-search-handler) 9863 (error? (default-library-search-handler "not-symbol" '(lib) '() '())) 9864 (error? (default-library-search-handler 'import 'bad-library-name '() '())) 9865 (error? (default-library-search-handler 'import '(lib) '(("invalid" "path" "list")) '())) 9866 (error? (default-library-search-handler 'import '(lib) '(("foo" . "bar")) '(("bad") ("extensions")))) 9867 (error? 9868 (parameterize ([library-search-handler 9869 (lambda (who path dir* all-ext*) 9870 (values '(bad source path) #f #f))]) 9871 (eval '(import (foo))))) 9872 (error? 9873 (parameterize ([library-search-handler 9874 (lambda (who path dir* all-ext*) 9875 (values #f '(bad object path) #f))]) 9876 (eval '(import (foo))))) 9877 (error? 9878 (parameterize ([library-search-handler 9879 (lambda (who path dir* all-ext*) 9880 (values #f #f #t))]) 9881 (eval '(import (foo))))) 9882 (begin 9883 (mkdir "lsh-testdir") 9884 (mkdir "lsh-testdir/src1") 9885 (mkdir "lsh-testdir/src2") 9886 (mkdir "lsh-testdir/obj") 9887 #t) 9888 (begin 9889 (with-output-to-file "lsh-testdir/src1/lib.ss" 9890 (lambda () 9891 (pretty-print 9892 '(library (lib) (export a) (import (scheme)) 9893 (define a "src1 provided this a")))) 9894 'replace) 9895 (with-output-to-file "lsh-testdir/src2/lib.ss" 9896 (lambda () 9897 (pretty-print 9898 '(library (lib) (export a) (import (scheme)) 9899 (define a "a from src2")))) 9900 'replace) 9901 (with-output-to-file "lsh-testdir/src2/foo.ss" 9902 (lambda () 9903 (pretty-print 9904 '(library (foo) (export a) (import (scheme) (lib))))) 9905 'replace) 9906 (parameterize ([generate-wpo-files #t] 9907 [compile-imported-libraries #t] 9908 [library-directories '(("src2" . "obj"))]) 9909 (compile-file "lsh-testdir/src2/lib.ss" "lsh-testdir/obj/lib.so") 9910 (compile-file "lsh-testdir/src2/foo.ss" "lsh-testdir/obj/foo.so")) 9911 #t) 9912 (equal? 9913 "a from src2\n" 9914 (separate-eval 9915 '(cd "lsh-testdir") 9916 '(library-extensions '((".ss" . ".so"))) 9917 '(library-directories '(("src2" . "obj") ("src1" . "obj"))) 9918 '(library-search-handler 9919 (lambda (who path dir* all-ext*) 9920 (let-values ([(src-path obj-path obj-exists?) 9921 (default-library-search-handler who path dir* all-ext*)]) 9922 (assert (equal? src-path "src2/lib.ss")) 9923 (assert (equal? obj-path "obj/lib.so")) 9924 (assert obj-exists?) 9925 (values src-path obj-path obj-exists?)))) 9926 '(printf "~a\n" (let () (import (lib)) a)))) 9927 (equal? 9928 "src1 provided this a\n" 9929 (separate-eval 9930 '(cd "lsh-testdir") 9931 '(library-extensions '((".ss" . ".so"))) 9932 '(library-directories '(("src2" . "obj") ("src1" . "obj"))) 9933 '(library-search-handler 9934 (lambda (who path dir* all-ext*) 9935 (assert (eq? who 'import)) 9936 (assert (equal? path '(lib))) 9937 (assert (equal? dir* (library-directories))) 9938 (assert (equal? all-ext* (library-extensions))) 9939 ;; switcheroo 9940 (values "src1/lib.ss" #f #f))) 9941 '(printf "~a\n" (let () (import (lib)) a)))) 9942 (equal? 9943 (string-append 9944 "compiling src1/lib.ss with output to obj/lib-compiled.so\n" 9945 "src1 provided this a\n") 9946 (separate-eval 9947 '(cd "lsh-testdir") 9948 '(compile-imported-libraries #t) 9949 '(library-search-handler 9950 (lambda (who path dir* all-ext*) 9951 (values "src1/lib.ss" "obj/lib-compiled.so" #f))) 9952 '(printf "~a\n" (let () (import (lib)) a)))) 9953 ;; the default library-search-handler finds obj/lib.wpo 9954 ;; so no libraries are needed at run time 9955 (equal? 9956 "()\n" 9957 (separate-eval 9958 '(cd "lsh-testdir") 9959 '(library-extensions '((".ss" . ".so"))) 9960 '(library-directories '(("src1" . "obj") ("src2" . "obj"))) 9961 '(compile-whole-library "obj/foo.wpo" "foo.library"))) 9962 (equal? 9963 "((lib))\n" 9964 (separate-eval 9965 '(cd "lsh-testdir") 9966 '(library-extensions '((".ss" . ".so"))) 9967 '(library-directories '(("src1" . "obj") ("src2" . "obj"))) 9968 '(define (check who path dir*) 9969 (assert (eq? who 'compile-whole-library)) 9970 (assert (equal? path '(lib))) 9971 (assert (equal? dir* (library-directories)))) 9972 '(library-search-handler 9973 (lambda (who path dir* all-ext*) 9974 (check who path dir*) 9975 (assert (equal? all-ext* '((".ss" . ".wpo")))) 9976 ;; default search finds the wpo file, but ... 9977 (let-values ([(src-path obj-path obj-exists?) 9978 (default-library-search-handler who path dir* all-ext*)]) 9979 ;; user reordered library-directories since compiling the wpo file 9980 (assert (equal? src-path "src1/lib.ss")) 9981 (assert (equal? obj-path "obj/lib.wpo")) 9982 (assert obj-exists?)) 9983 ;; ... we install a new handler that returns the object file instead 9984 (library-search-handler 9985 (lambda (who path dir* all-ext*) 9986 (check who path dir*) 9987 (assert (equal? all-ext* (library-extensions))) 9988 (values #f "obj/lib.so" #t))) 9989 ;; ... and report no .wpo file found so we fall back to the 9990 ;; library-search-handler just installed 9991 (values #f #f #f))) 9992 '(compile-whole-library "obj/foo.wpo" "foo.library"))) 9993 (begin 9994 (rm-rf "lsh-testdir") 9995 #t) 9996) 9997 9998(mat compile-imported-libraries 9999 (not (compile-imported-libraries)) 10000 (begin 10001 (mkdir "testdir") 10002 #t) 10003 (begin 10004 (define $cil '()) 10005 (with-output-to-file "testdir/cil1.sls" 10006 (lambda () 10007 (pretty-print '(eval-when (compile) (set! $cil (cons 'cil1 $cil)))) 10008 (pretty-print 10009 '(library (testdir cil1) (export a) (import (rnrs)) 10010 (define x 57388321) 10011 (define-syntax a (lambda (q) #'x))))) 10012 'replace) 10013 (with-output-to-file "testdir/cil2.sls" 10014 (lambda () 10015 (pretty-print '(eval-when (compile) (set! $cil (cons 'cil2 $cil)))) 10016 (pretty-print 10017 '(library (testdir cil2) (export a b f get-y) (import (rnrs) (testdir cil1)) 10018 (define y #f) 10019 (define get-y (lambda () y)) 10020 (define b (lambda () (list a))) 10021 (define f (lambda (v) (set! y v)))))) 10022 'replace) 10023 (with-output-to-file "testdir/cil" 10024 (lambda () 10025 (display "#! /usr/bin/env scheme-script\n") 10026 (pretty-print '(import (rnrs) (testdir cil2))) 10027 (pretty-print '(f (cons (b) a)))) 10028 'replace) 10029 #t) 10030 (equal? 10031 (parameterize ([compile-imported-libraries #t] 10032 [compile-file-message #f] 10033 [compile-library-handler 10034 (lambda args 10035 (printf "hello!\n") 10036 (flush-output-port) 10037 (apply compile-library args) 10038 (printf "goodbye.\n") 10039 (flush-output-port))]) 10040 (with-output-to-string 10041 (lambda () 10042 (load-program "testdir/cil")))) 10043 "hello!\nhello!\ngoodbye.\ngoodbye.\n") 10044 (file-exists? "testdir/cil1.so") 10045 (file-exists? "testdir/cil2.so") 10046 (equal? $cil '(cil1 cil2)) 10047 (equal? (let () (import (testdir cil2)) (get-y)) '((57388321) . 57388321)) 10048 (equal? (let () (import (testdir cil2)) (f 772) (get-y)) 772) 10049 (eq? 10050 (parameterize ([compile-imported-libraries #t]) 10051 (load-program "testdir/cil")) 10052 (void)) 10053 (equal? (let () (import (testdir cil2)) (get-y)) '((57388321) . 57388321)) 10054 (equal? $cil '(cil1 cil2)) 10055 (begin 10056 (rm-rf "testdir") 10057 #t) 10058 ; once again with extension .ss, to see if position in library-extensions list matters 10059 (begin 10060 (mkdir "testdir") 10061 #t) 10062 (begin 10063 (define $cil '()) 10064 (with-output-to-file "testdir/cil3.ss" 10065 (lambda () 10066 (pretty-print '(eval-when (compile) (set! $cil (cons 'cil3 $cil)))) 10067 (pretty-print 10068 '(library (testdir cil3) (export a) (import (rnrs)) 10069 (define x 57388321) 10070 (define-syntax a (lambda (q) #'x))))) 10071 'replace) 10072 (with-output-to-file "testdir/cil4.ss" 10073 (lambda () 10074 (pretty-print '(eval-when (compile) (set! $cil (cons 'cil4 $cil)))) 10075 (pretty-print 10076 '(library (testdir cil4) (export a b f get-y) (import (rnrs) (testdir cil3)) 10077 (define y #f) 10078 (define get-y (lambda () y)) 10079 (define b (lambda () (list a))) 10080 (define f (lambda (v) (set! y v)))))) 10081 'replace) 10082 (with-output-to-file "testdir/cil" 10083 (lambda () 10084 (display "#! /usr/bin/env scheme-script\n") 10085 (pretty-print '(import (rnrs) (testdir cil4))) 10086 (pretty-print '(f (cons (b) a)))) 10087 'replace) 10088 #t) 10089 (eq? 10090 (parameterize ([compile-imported-libraries #t]) 10091 (load-program "testdir/cil")) 10092 (void)) 10093 (file-exists? "testdir/cil3.so") 10094 (file-exists? "testdir/cil4.so") 10095 (equal? $cil '(cil3 cil4)) 10096 (equal? (let () (import (testdir cil4)) (get-y)) '((57388321) . 57388321)) 10097 (equal? (let () (import (testdir cil4)) (f 772) (get-y)) 772) 10098 (eq? 10099 (parameterize ([compile-imported-libraries #t]) 10100 (load-program "testdir/cil")) 10101 (void)) 10102 (equal? (let () (import (testdir cil4)) (get-y)) '((57388321) . 57388321)) 10103 (equal? $cil '(cil3 cil4)) 10104 (begin 10105 (rm-rf "testdir") 10106 (rm-rf "objdir") 10107 #t) 10108 ; try again with different library-directories and library-extensions 10109 (begin 10110 (mkdir "testdir") 10111 #t) 10112 (begin 10113 (define $cil '()) 10114 (with-output-to-file "testdir/cil5.ss" 10115 (lambda () 10116 (pretty-print '(eval-when (compile) (set! $cil (cons 'cil5 $cil)))) 10117 (pretty-print 10118 '(library (testdir cil5) (export a) (import (rnrs)) 10119 (define x 57388321) 10120 (define-syntax a (lambda (q) #'x))))) 10121 'replace) 10122 (with-output-to-file "testdir/cil6.sls" 10123 (lambda () 10124 (pretty-print '(eval-when (compile) (set! $cil (cons 'cil6 $cil)))) 10125 (pretty-print 10126 '(library (testdir cil6) (export a b f get-y) (import (rnrs) (testdir cil5)) 10127 (define y #f) 10128 (define get-y (lambda () y)) 10129 (define b (lambda () (list a))) 10130 (define f (lambda (v) (set! y v)))))) 10131 'replace) 10132 (with-output-to-file "testdir/cil" 10133 (lambda () 10134 (display "#! /usr/bin/env scheme-script\n") 10135 (pretty-print '(import (rnrs) (testdir cil6))) 10136 (pretty-print '(f (cons (b) a)))) 10137 'replace) 10138 #t) 10139 (eq? 10140 (parameterize ([compile-imported-libraries #t] 10141 [library-directories '(("." . "objdir"))] 10142 [library-extensions '((".sls" . ".bar") (".ss" . ".foo"))]) 10143 (load-program "testdir/cil")) 10144 (void)) 10145 (file-exists? "objdir/testdir/cil5.foo") 10146 (file-exists? "objdir/testdir/cil6.bar") 10147 (equal? $cil '(cil5 cil6)) 10148 (equal? (let () (import (testdir cil6)) (get-y)) '((57388321) . 57388321)) 10149 (equal? (let () (import (testdir cil6)) (f 772) (get-y)) 772) 10150 (eq? 10151 (parameterize ([compile-imported-libraries #t] 10152 [library-directories '(("." . "objdir"))] 10153 [library-extensions '((".sls" . ".bar") (".ss" . ".foo"))]) 10154 (load-program "testdir/cil")) 10155 (void)) 10156 (equal? (let () (import (testdir cil6)) (get-y)) '((57388321) . 57388321)) 10157 (equal? $cil '(cil5 cil6)) 10158 (begin 10159 (rm-rf "testdir") 10160 (rm-rf "objdir") 10161 #t) 10162 ; what if we compile explicitly first? 10163 (begin 10164 (mkdir "testdir") 10165 #t) 10166 (begin 10167 (define $cil '()) 10168 (with-output-to-file "testdir/cil7.sls" 10169 (lambda () 10170 (pretty-print '(eval-when (compile) (set! $cil (cons 'cil7 $cil)))) 10171 (pretty-print 10172 '(library (testdir cil7) (export a) (import (rnrs)) 10173 (define x 57388321) 10174 (define-syntax a (lambda (q) #'x))))) 10175 'replace) 10176 (with-output-to-file "testdir/cil8.sls" 10177 (lambda () 10178 (pretty-print '(eval-when (compile) (set! $cil (cons 'cil8 $cil)))) 10179 (pretty-print 10180 '(library (testdir cil8) (export a b f get-y) (import (rnrs) (testdir cil7)) 10181 (define y #f) 10182 (define get-y (lambda () y)) 10183 (define b (lambda () (list a))) 10184 (define f (lambda (v) (set! y v)))))) 10185 'replace) 10186 (with-output-to-file "testdir/cil" 10187 (lambda () 10188 (display "#! /usr/bin/env scheme-script\n") 10189 (pretty-print '(import (rnrs) (testdir cil8))) 10190 (pretty-print '(f (cons (b) a)))) 10191 'replace) 10192 (compile-library "testdir/cil7.sls") 10193 (compile-library "testdir/cil8.sls") 10194 #t) 10195 (file-exists? "testdir/cil7.so") 10196 (file-exists? "testdir/cil8.so") 10197 (equal? $cil '(cil8 cil7)) 10198 (eq? 10199 (parameterize ([compile-imported-libraries #t]) 10200 (load-program "testdir/cil")) 10201 (void)) 10202 (equal? $cil '(cil8 cil7)) 10203 (equal? (let () (import (testdir cil8)) (get-y)) '((57388321) . 57388321)) 10204 (begin 10205 (rm-rf "testdir") 10206 #t) 10207 ; what if we compile ahead of time, and put .so in library extensions? 10208 (begin 10209 (mkdir "testdir") 10210 #t) 10211 (begin 10212 (define $cil '()) 10213 (with-output-to-file "testdir/cil9.sls" 10214 (lambda () 10215 (pretty-print '(eval-when (compile) (set! $cil (cons 'cil9 $cil)))) 10216 (pretty-print 10217 '(library (testdir cil9) (export a) (import (rnrs)) 10218 (define x 57388321) 10219 (define-syntax a (lambda (q) #'x))))) 10220 'replace) 10221 (with-output-to-file "testdir/cil10.sls" 10222 (lambda () 10223 (pretty-print '(eval-when (compile) (set! $cil (cons 'cil10 $cil)))) 10224 (pretty-print 10225 '(library (testdir cil10) (export a b f get-y) (import (rnrs) (testdir cil9)) 10226 (define y #f) 10227 (define get-y (lambda () y)) 10228 (define b (lambda () (list a))) 10229 (define f (lambda (v) (set! y v)))))) 10230 'replace) 10231 (with-output-to-file "testdir/cil" 10232 (lambda () 10233 (display "#! /usr/bin/env scheme-script\n") 10234 (pretty-print '(import (rnrs) (testdir cil10))) 10235 (pretty-print '(f (cons (b) a)))) 10236 'replace) 10237 (compile-library "testdir/cil9.sls") 10238 (compile-library "testdir/cil10.sls") 10239 #t) 10240 (file-exists? "testdir/cil9.so") 10241 (file-exists? "testdir/cil10.so") 10242 (equal? $cil '(cil10 cil9)) 10243 (eq? 10244 (parameterize ([compile-imported-libraries #t] 10245 [library-extensions (cons ".so" (library-extensions))]) 10246 (load-program "testdir/cil")) 10247 (void)) 10248 (equal? $cil '(cil10 cil9)) 10249 (equal? (let () (import (testdir cil10)) (get-y)) '((57388321) . 57388321)) 10250 (begin 10251 (rm-rf "testdir") 10252 #t) 10253 ; separate compilation 10254 (begin 10255 (mkdir "testdir") 10256 #t) 10257 (begin 10258 (define $cil '()) 10259 (with-output-to-file "testdir/cil11.sls" 10260 (lambda () 10261 (pretty-print '(eval-when (compile) (set! $cil (cons 'cil11 $cil)))) 10262 (pretty-print 10263 '(library (testdir cil11) (export a) (import (rnrs)) 10264 (define x 57388321) 10265 (define-syntax a (lambda (q) #'x))))) 10266 'replace) 10267 (with-output-to-file "testdir/cil12.sls" 10268 (lambda () 10269 (pretty-print '(eval-when (compile) (set! $cil (cons 'cil12 $cil)))) 10270 (pretty-print 10271 '(library (testdir cil12) (export a b f get-y) (import (rnrs) (testdir cil11)) 10272 (define y #f) 10273 (define get-y (lambda () y)) 10274 (define b (lambda () (list a))) 10275 (define f (lambda (v) (set! y v)))))) 10276 'replace) 10277 (with-output-to-file "testdir/cil.ss" 10278 (lambda () 10279 (display "#! /usr/bin/env scheme-script\n") 10280 (pretty-print '(import (rnrs) (testdir cil12))) 10281 (pretty-print '(f (cons (b) a)))) 10282 'replace) 10283 #t) 10284 (begin 10285 (separate-compile 10286 '(lambda (x) 10287 (set! $cil '()) 10288 (parameterize ([compile-imported-libraries #t]) 10289 (compile-program x))) 10290 "testdir/cil") 10291 #t) 10292 (file-exists? "testdir/cil.so") 10293 (file-exists? "testdir/cil11.so") 10294 (file-exists? "testdir/cil12.so") 10295 (equal? $cil '()) 10296 (equal? (let () (import (testdir cil11)) a) 57388321) 10297 (eq? 10298 (parameterize ([compile-imported-libraries #t]) 10299 (load-program "testdir/cil.so")) 10300 (void)) 10301 (equal? (let () (import (testdir cil12)) (get-y)) '((57388321) . 57388321)) 10302 (equal? $cil '()) 10303 (begin 10304 (rm-rf "testdir") 10305 #t) 10306 ; test auto recompilation if dependency is recompiled 10307 (begin 10308 (mkdir "testdir") 10309 #t) 10310 (begin 10311 (with-output-to-file "testdir/cil13.sls" 10312 (lambda () 10313 (pretty-print 10314 '(library (testdir cil13) (export a x) (import (rnrs)) 10315 (define x 73) 10316 (define-syntax a (lambda (q) #'(+ x 6)))))) 10317 'replace) 10318 (with-output-to-file "testdir/cil14.sls" 10319 (lambda () 10320 (pretty-print 10321 '(library (testdir cil14) (export a b f get-y) (import (rnrs) (testdir cil13)) 10322 (define y #f) 10323 (define get-y (lambda () y)) 10324 (define b (lambda () (list a x))) 10325 (define f (lambda (v) (set! y v)))))) 10326 'replace) 10327 (with-output-to-file "testdir/cil-a.ss" 10328 (lambda () 10329 (display "#! /usr/bin/env scheme-script\n") 10330 (pretty-print '(import (rnrs) (testdir cil14))) 10331 (pretty-print '(f (cons (b) a))) 10332 (pretty-print '(display (get-y)))) 10333 'replace) 10334 (with-output-to-file "testdir/cil15.sls" 10335 (lambda () 10336 (pretty-print 10337 '(library (testdir cil15) (export a x) (import (rnrs)) 10338 (define x 73) 10339 (define-syntax a (lambda (q) #'(+ x 6)))))) 10340 'replace) 10341 (with-output-to-file "testdir/cil16.sls" 10342 (lambda () 10343 (pretty-print 10344 '(library (testdir cil16) (export a b f get-y) (import (rnrs) (testdir cil15)) 10345 (define y #f) 10346 (define get-y (lambda () y)) 10347 (define b (lambda () (list a x))) 10348 (define f (lambda (v) (set! y v)))))) 10349 'replace) 10350 (with-output-to-file "testdir/cil-b.ss" 10351 (lambda () 10352 (display "#! /usr/bin/env scheme-script\n") 10353 (pretty-print '(import (rnrs) (testdir cil16))) 10354 (pretty-print '(f (cons (b) a))) 10355 (pretty-print '(display (get-y)))) 10356 'replace) 10357 (with-output-to-file "testdir/cil17.sls" 10358 (lambda () 10359 (pretty-print 10360 '(library (testdir cil17) (export a x) (import (rnrs)) 10361 (define x 73) 10362 (define-syntax a (lambda (q) #'(+ x 6)))))) 10363 'replace) 10364 (with-output-to-file "testdir/cil18.sls" 10365 (lambda () 10366 (pretty-print 10367 '(library (testdir cil18) (export a b f get-y) (import (rnrs) (testdir cil17)) 10368 (define y #f) 10369 (define get-y (lambda () y)) 10370 (define b (lambda () (list a x))) 10371 (define f (lambda (v) (set! y v)))))) 10372 'replace) 10373 (with-output-to-file "testdir/cil-c.ss" 10374 (lambda () 10375 (display "#! /usr/bin/env scheme-script\n") 10376 (pretty-print '(import (rnrs) (testdir cil18))) 10377 (pretty-print '(f (cons (b) a))) 10378 (pretty-print '(display (get-y)))) 10379 'replace) 10380 #t) 10381 ; compile 'em all in a separate process 10382 (begin 10383 (separate-compile 10384 '(lambda (x) 10385 (parameterize ([compile-imported-libraries #t]) 10386 (compile-program x))) 10387 "testdir/cil-a") 10388 (separate-compile 10389 '(lambda (x) 10390 (parameterize ([compile-imported-libraries #t]) 10391 (compile-program x))) 10392 "testdir/cil-b") 10393 (separate-compile 10394 '(lambda (x) 10395 (parameterize ([compile-imported-libraries #t]) 10396 (compile-program x))) 10397 "testdir/cil-c") 10398 #t) 10399 (file-exists? "testdir/cil-a.so") 10400 (file-exists? "testdir/cil13.so") 10401 (file-exists? "testdir/cil14.so") 10402 (file-exists? "testdir/cil-b.so") 10403 (file-exists? "testdir/cil15.so") 10404 (file-exists? "testdir/cil16.so") 10405 (file-exists? "testdir/cil-c.so") 10406 (file-exists? "testdir/cil13.so") 10407 (file-exists? "testdir/cil14.so") 10408 ; can't test programs' output here, since we don't want 10409 ; to load the libraries until after the next step 10410 ; now delete object file or modify source file and recompile 10411 (begin 10412 ; ensure a different time stamp 10413 (delete-file "testdir/cil13.so") 10414 (separate-compile 10415 '(lambda (x) 10416 (parameterize ([compile-imported-libraries #t]) 10417 (compile-program x))) 10418 "testdir/cil-a") 10419 (sleep (make-time 'time-duration 0 1)) 10420 (with-output-to-file "testdir/cil15.sls" 10421 (lambda () 10422 (pretty-print 10423 '(library (testdir cil15) (export a x) (import (rnrs)) 10424 (define x -73) 10425 (define-syntax a (lambda (q) #'(+ x 6)))))) 10426 'replace) 10427 (separate-compile 10428 '(lambda (x) 10429 (parameterize ([compile-imported-libraries #t]) 10430 (compile-program x))) 10431 "testdir/cil-b") 10432 (delete-file "testdir/cil17.so") 10433 (separate-compile 10434 '(lambda (x) 10435 (parameterize ([compile-imported-libraries #f]) ; #f here rather than #t should cause failure 10436 (compile-program x))) 10437 "testdir/cil-c") 10438 #t) 10439 (file-exists? "testdir/cil-a.so") 10440 (file-exists? "testdir/cil13.so") 10441 (file-exists? "testdir/cil14.so") 10442 (file-exists? "testdir/cil-b.so") 10443 (file-exists? "testdir/cil15.so") 10444 (file-exists? "testdir/cil16.so") 10445 ; testdir/cil-c.so exists now that load-library reloads source when dependency changes 10446 (file-exists? "testdir/cil-c.so") 10447 (file-exists? "testdir/cil13.so") 10448 (file-exists? "testdir/cil14.so") 10449 (file-exists? "testdir/cil-a.so") 10450 (file-exists? "testdir/cil13.so") 10451 (file-exists? "testdir/cil14.so") 10452 ; now test programs' output 10453 (equal? 10454 (with-output-to-string 10455 (lambda () (load-program "testdir/cil-a.so"))) 10456 "((79 73) . 79)") 10457 (equal? 10458 (with-output-to-string 10459 (lambda () (load-program "testdir/cil-b.so"))) 10460 "((-67 -73) . -67)") 10461 (begin 10462 (rm-rf "testdir") 10463 #t) 10464 ; --------------------------------------------------------------- 10465 (begin 10466 (mkdir "testdir") 10467 #t) 10468 (begin 10469 (with-output-to-file "testdir/cil19A.ss" 10470 (lambda () 10471 (pretty-print 10472 '(library (testdir cil19A) 10473 (export x) 10474 (import (chezscheme)) 10475 (define x (make-parameter 13))))) 10476 'replace) 10477 (with-output-to-file "testdir/cil19B.ss" 10478 (lambda () 10479 (pretty-print 10480 '(library (testdir cil19B) 10481 (export y) 10482 (import (chezscheme)) 10483 ; importing from within RHS to make sure RHS imports are tracked 10484 (define y (make-parameter (let () (import (testdir cil19A)) (+ (x) 5))))))) 10485 'replace) 10486 (with-output-to-file "testdir/cil19C.ss" 10487 (lambda () 10488 (pretty-print 10489 '(import (chezscheme) (testdir cil19B))) 10490 (pretty-print 10491 '(pretty-print (y)))) 10492 'replace) 10493 #t) 10494 (equal? 10495 (separate-eval 10496 '(compile-imported-libraries #t) 10497 '(load-program "testdir/cil19C.ss")) 10498 "compiling testdir/cil19B.ss with output to testdir/cil19B.so\ncompiling testdir/cil19A.ss with output to testdir/cil19A.so\n18\n") 10499 (file-exists? "testdir/cil19A.so") 10500 (file-exists? "testdir/cil19B.so") 10501 (equal? 10502 (separate-eval 10503 '(compile-imported-libraries #t) 10504 '(load-program "testdir/cil19C.ss")) 10505 "18\n") 10506 ; now add an include file 10507 (begin 10508 (sleep (make-time 'time-duration 0 1)) 10509 (with-output-to-file "testdir/cil19A1.ss" 10510 (lambda () 10511 (pretty-print 10512 '(define x (make-parameter 19)))) 10513 'replace) 10514 (with-output-to-file "testdir/cil19A.ss" 10515 (lambda () 10516 (pretty-print 10517 '(library (testdir cil19A) 10518 (export x) 10519 (import (chezscheme)) 10520 (include "cil19A1.ss")))) 10521 'replace) 10522 #t) 10523 (equal? 10524 (separate-eval 10525 '(compile-imported-libraries #t) 10526 '(load-program "testdir/cil19C.ss")) 10527 "compiling testdir/cil19A.ss with output to testdir/cil19A.so\ncompiling testdir/cil19B.ss with output to testdir/cil19B.so\n24\n") 10528 (equal? 10529 (separate-eval 10530 '(compile-imported-libraries #t) 10531 '(load-program "testdir/cil19C.ss")) 10532 "24\n") 10533 ; now change first include file to include a second 10534 (begin 10535 (sleep (make-time 'time-duration 0 1)) 10536 (with-output-to-file "testdir/cil19A2.ss" 10537 (lambda () 10538 (pretty-print 10539 '(define x (make-parameter 23)))) 10540 'replace) 10541 (with-output-to-file "testdir/cil19A1.ss" 10542 (lambda () 10543 (pretty-print 10544 '(include "cil19A2.ss"))) 10545 'replace) 10546 #t) 10547 ; load w/compile-imported-libraries #f---should get old result 10548 ; not longer now that load-library reloads source when dependency changes 10549 (equal? 10550 (separate-eval 10551 '(compile-imported-libraries #f) 10552 '(load-program "testdir/cil19C.ss")) 10553 "28\n" 10554 #;"24\n") 10555 ; should get new result with compile-imported-libraries #t 10556 (equal? 10557 (separate-eval 10558 '(compile-imported-libraries #t) 10559 '(load-program "testdir/cil19C.ss")) 10560 "compiling testdir/cil19A.ss with output to testdir/cil19A.so\ncompiling testdir/cil19B.ss with output to testdir/cil19B.so\n28\n") 10561 (equal? 10562 (separate-eval 10563 '(compile-imported-libraries #t) 10564 '(load-program "testdir/cil19C.ss")) 10565 "28\n") 10566 ; now change second include file 10567 (begin 10568 (sleep (make-time 'time-duration 0 1)) 10569 (with-output-to-file "testdir/cil19A2.ss" 10570 (lambda () 10571 (pretty-print 10572 '(define x (make-parameter 31)))) 10573 'replace) 10574 #t) 10575 (equal? 10576 (separate-eval 10577 '(compile-imported-libraries #t) 10578 '(load-program "testdir/cil19C.ss")) 10579 "compiling testdir/cil19A.ss with output to testdir/cil19A.so\ncompiling testdir/cil19B.ss with output to testdir/cil19B.so\n36\n") 10580 (equal? 10581 (separate-eval 10582 '(compile-imported-libraries #t) 10583 '(load-program "testdir/cil19C.ss")) 10584 "36\n") 10585 (begin 10586 (rm-rf "testdir") 10587 #t) 10588) 10589 10590(mat import-notify 10591 (eq? (import-notify 'yes) (void)) 10592 (eq? (import-notify) #t) 10593 (begin 10594 (with-output-to-file "testfile-imno1.ss" 10595 (lambda () 10596 (pretty-print 10597 '(library (testfile-imno1) (export x) (import (rnrs)) 10598 (define x -73)))) 10599 'replace) 10600 (with-output-to-file "testfile-imno2.ss" 10601 (lambda () 10602 (pretty-print 10603 '(library (testfile-imno2) (export y) (import (rnrs) (testfile-imno1)) 10604 (define y (+ x x))))) 10605 'replace) 10606 (separate-compile 'imno1) 10607 #t) 10608 (equal? 10609 (parameterize ([source-directories '(".")] 10610 [library-directories '(".")] 10611 [console-output-port (open-output-string)]) 10612 (eval '(lambda () (import (testfile-imno2)) y)) 10613 (get-output-string (console-output-port))) 10614 "import: did not find source file \"testfile-imno2.chezscheme.sls\"\nimport: found source file \"testfile-imno2.ss\"\nimport: did not find corresponding object file \"testfile-imno2.so\"\nimport: loading source file \"testfile-imno2.ss\"\nimport: did not find source file \"testfile-imno1.chezscheme.sls\"\nimport: found source file \"testfile-imno1.ss\"\nimport: found corresponding object file \"testfile-imno1.so\"\nimport: object file is not older\nimport: visiting object file \"testfile-imno1.so\"\nattempting to 'revisit' previously 'visited' \"testfile-imno1.so\" for library (testfile-imno1) run-time info\n") 10615 (eq? (import-notify #f) (void)) 10616) 10617 10618(mat rnrs-libraries 10619 (equal? 10620 (let ([cons void]) 10621 (let () (import (rnrs base)) (cons 3 4))) 10622 '(3 . 4)) 10623) 10624 10625(mat top-level-program 10626 (equal? 10627 (with-output-to-string 10628 (lambda () 10629 (eval '(top-level-program (import (scheme)) 10630 (define-syntax a (identifier-syntax (cons x y))) 10631 (define x 55) 10632 (printf "x = ~s\n" x) 10633 (define y 'yyy) 10634 (printf "(a x y) = ~s\n" (list a x y)))))) 10635 "x = 55\n(a x y) = ((55 . yyy) 55 yyy)\n") 10636 (equal? 10637 (with-output-to-string 10638 (lambda () 10639 (with-output-to-file "testfile-tlp1.ss" 10640 (lambda () 10641 (pretty-print 10642 '(library (testfile-tlp1) (export $tlp-x $tlp-y) (import (scheme)) 10643 (define-syntax $tlp-y 10644 (begin 10645 (printf "visiting tlp1\n") 10646 (identifier-syntax (cons ($tlp-x) (z))))) 10647 (define z (make-parameter 'zzz)) 10648 (define $tlp-x (make-parameter 'xxx)) 10649 (printf "invoking tlp1\n")))) 10650 'replace) 10651 (with-output-to-file "testfile-tlp.ss" 10652 (lambda () 10653 (pretty-print 10654 '(top-level-program (import (testfile-tlp1) (rnrs) (only (scheme) list printf)) 10655 (define-syntax a (identifier-syntax (cons x y))) 10656 (define x ($tlp-x)) 10657 (printf "x = ~s\n" x) 10658 (define y $tlp-y) 10659 (printf "(a x y) = ~s\n" (list a x y))))) 10660 'replace) 10661 ; compile in same Scheme process 10662 (compile-file "testfile-tlp1") 10663 (compile-file "testfile-tlp"))) 10664 "compiling testfile-tlp1.ss with output to testfile-tlp1.so\nvisiting tlp1\ncompiling testfile-tlp.ss with output to testfile-tlp.so\n") 10665 (equal? 10666 (with-output-to-string 10667 (lambda () (load "testfile-tlp.so"))) 10668 "invoking tlp1\nx = xxx\n(a x y) = ((xxx xxx . zzz) xxx (xxx . zzz))\n") 10669 (begin 10670 (with-output-to-file "testfile-tlp2.ss" 10671 (lambda () 10672 (pretty-print 10673 '(library (testfile-tlp2) (export $tlp-x $tlp-y) (import (scheme)) 10674 (define-syntax $tlp-y 10675 (begin 10676 (printf "visiting tlp2\n") 10677 (identifier-syntax (cons ($tlp-x) z)))) 10678 (define z 'zzz) 10679 (define $tlp-x (make-parameter 'xxx)) 10680 (printf "invoking tlp2\n")))) 10681 'replace) 10682 (with-output-to-file "testfile-tlp.ss" 10683 (lambda () 10684 (pretty-print 10685 '(top-level-program (import (testfile-tlp2) (rnrs) (only (scheme) list printf)) 10686 (define-syntax a (identifier-syntax (cons x y))) 10687 (define x ($tlp-x)) 10688 (printf "x = ~s\n" x) 10689 (define y $tlp-y) 10690 (printf "(a x y) = ~s\n" (list a x y))))) 10691 'replace) 10692 (for-each separate-compile '(tlp2 tlp)) 10693 #t) 10694 (equal? 10695 (with-output-to-string 10696 (lambda () (load "testfile-tlp.so"))) 10697 "invoking tlp2\nx = xxx\n(a x y) = ((xxx xxx . zzz) xxx (xxx . zzz))\n") 10698 (begin 10699 (with-output-to-file "testfile.ss" 10700 (lambda () 10701 (for-each pretty-print 10702 '((import (rnrs)) 10703 (define x 0) 10704 (define (inc v) (set! x (+ x v)) x) 10705 (if (inc 3))))) 10706 'replace) 10707 #t) 10708 (error? ; invalid syntax (if (inc 3)) at [not near] line 4, char 1 10709 (load-program "testfile.ss")) 10710 (equal? 10711 (with-output-to-string 10712 (lambda () 10713 (with-output-to-file "testfile-tlp1.ss" 10714 (lambda () 10715 (pretty-print 10716 '(library (testfile-tlp1) (export $tlp-x $tlp-y) (import (scheme)) 10717 (define-syntax $tlp-y 10718 (begin 10719 (printf "visiting tlp1\n") 10720 (identifier-syntax (cons ($tlp-x) (z))))) 10721 (define z (make-parameter 'zzz)) 10722 (define $tlp-x (make-parameter 'xxx)) 10723 (printf "invoking tlp1\n")))) 10724 'replace) 10725 (with-output-to-file "testfile-tlp.ss" 10726 (lambda () 10727 (for-each pretty-print 10728 '((import (testfile-tlp1) (rnrs) (only (scheme) list printf)) 10729 (define-syntax a (identifier-syntax (cons x y))) 10730 (define x ($tlp-x)) 10731 (printf "x = ~s\n" x) 10732 (define y $tlp-y) 10733 (printf "(a x y) = ~s\n" (list a x y))))) 10734 'replace) 10735 ; compile in same Scheme process 10736 (compile-library "testfile-tlp1") 10737 (compile-program "testfile-tlp"))) 10738 "compiling testfile-tlp1.ss with output to testfile-tlp1.so\nvisiting tlp1\ncompiling testfile-tlp.ss with output to testfile-tlp.so\n") 10739 (equal? 10740 (with-output-to-string 10741 (lambda () 10742 (load-library "testfile-tlp1.so"))) 10743 "") 10744 (equal? 10745 (with-output-to-string 10746 (lambda () 10747 (load-program "testfile-tlp.so"))) 10748 "invoking tlp1\nx = xxx\n(a x y) = ((xxx xxx . zzz) xxx (xxx . zzz))\n") 10749 ; load again from source 10750 (equal? 10751 (with-output-to-string 10752 (lambda () 10753 (load-library "testfile-tlp1.ss"))) 10754 "visiting tlp1\n") 10755 (error? ; wrong version of testfile-tlp1 10756 (load-program "testfile-tlp.so")) 10757 (equal? 10758 (with-output-to-string 10759 (lambda () 10760 (load-program "testfile-tlp.ss"))) 10761 "invoking tlp1\nx = xxx\n(a x y) = ((xxx xxx . zzz) xxx (xxx . zzz))\n") 10762 (begin 10763 (delete-file "testfile-tlp1.so") 10764 (delete-file "testfile-tlp.so") 10765 #t) 10766 (begin 10767 (with-output-to-file "testfile-tlp1.ss" 10768 (lambda () 10769 (parameterize ([print-vector-length #t]) 10770 (pretty-print 10771 '(library (testfile-tlp1) (export $tlp-z) (import (chezscheme)) 10772 (define $tlp-z '#3(1 2)))))) 10773 'replace) 10774 (with-output-to-file "testfile-tlp.ss" 10775 (lambda () 10776 (parameterize ([print-vector-length #t]) 10777 (for-each pretty-print 10778 '((import (testfile-tlp1) (chezscheme)) 10779 (pretty-print (equal? $tlp-z '#3(1 2))))))) 10780 'replace) 10781 #t) 10782 (error? ; nonstandard vector-length syntax 10783 (compile-library "testfile-tlp1")) 10784 (error? ; nonstandard vector-length syntax 10785 (compile-program "testfile-tlp")) 10786 (error? ; nonstandard vector-length syntax 10787 (load-library "testfile-tlp1.ss")) 10788 (error? ; nonstandard vector-length syntax 10789 (load-program "testfile-tlp.ss")) 10790 (begin 10791 (with-output-to-file "testfile-tlp1.ss" 10792 (lambda () 10793 (display "#!chezscheme\n") 10794 (parameterize ([print-vector-length #t]) 10795 (pretty-print 10796 '(library (testfile-tlp1) (export $tlp-z) (import (chezscheme)) 10797 (define $tlp-z '#3(1 2)))))) 10798 'replace) 10799 (with-output-to-file "testfile-tlp.ss" 10800 (lambda () 10801 (display "#!chezscheme\n") 10802 (parameterize ([print-vector-length #t]) 10803 (for-each pretty-print 10804 '((import (testfile-tlp1) (chezscheme)) 10805 (pretty-print (equal? $tlp-z '#3(1 2))))))) 10806 'replace) 10807 #t) 10808 (equal? 10809 (begin 10810 (compile-library "testfile-tlp1") 10811 (compile-program "testfile-tlp") 10812 (with-output-to-string 10813 (lambda () 10814 (load-library "testfile-tlp1.so") 10815 (load-program "testfile-tlp.so")))) 10816 "#t\n") 10817 (equal? 10818 (with-output-to-string 10819 (lambda () 10820 (load-library "testfile-tlp1.ss") 10821 (load-program "testfile-tlp.ss"))) 10822 "#t\n") 10823 ; test to make sure compiled top-level-program doesn't try to 10824 ; load libraries upon which it should not depend 10825 (equal? 10826 (begin 10827 (with-output-to-file "testfile-tlp3.ss" 10828 (lambda () 10829 (pretty-print 10830 '(library (testfile-tlp3) 10831 (export t1-x) 10832 (import (chezscheme)) 10833 (define t1-x 332211)))) 10834 'replace) 10835 (with-output-to-file "testfile-tlp4.ss" 10836 (lambda () 10837 (pretty-print 10838 '(library (testfile-tlp4) 10839 (export t2-q) 10840 (import (chezscheme) (testfile-tlp3)) 10841 (define-syntax t2-q (lambda (x) t1-x))))) 10842 'replace) 10843 (with-output-to-file "testfile-tlp5.ss" 10844 (lambda () 10845 (pretty-print '(import (chezscheme) (testfile-tlp4))) 10846 (pretty-print '(pretty-print t2-q))) 10847 'replace) 10848 (separate-compile 'compile-library 'tlp3) 10849 (separate-compile 'compile-library 'tlp4) 10850 (separate-compile 'compile-program 'tlp5) 10851 (delete-file "testfile-tlp3.ss") 10852 (delete-file "testfile-tlp4.ss") 10853 (delete-file "testfile-tlp3.so") 10854 (delete-file "testfile-tlp4.so") 10855 (printf "loading testfile-tlp5.so\n") 10856 (with-output-to-string 10857 (lambda () 10858 (load-program "testfile-tlp5.so")))) 10859 "332211\n") 10860 ; check dependencies returned by compile-program 10861 (equal? 10862 (let () 10863 (define dep8) 10864 (with-output-to-file "testfile-tlp6.ss" 10865 (lambda () 10866 (pretty-print 10867 '(library (testfile-tlp6) 10868 (export t1-x) 10869 (import (chezscheme)) 10870 (define t1-x 332211)))) 10871 'replace) 10872 (with-output-to-file "testfile-tlp7.ss" 10873 (lambda () 10874 (pretty-print 10875 '(library (testfile-tlp7) 10876 (export t2-q) 10877 (import (chezscheme) (testfile-tlp6)) 10878 (define-syntax t2-q (lambda (x) t1-x))))) 10879 'replace) 10880 (with-output-to-file "testfile-tlp8.ss" 10881 (lambda () 10882 (pretty-print '(import (chezscheme) (testfile-tlp7))) 10883 (pretty-print '(pretty-print t2-q))) 10884 'replace) 10885 (compile-library "testfile-tlp6") 10886 (compile-library "testfile-tlp7") 10887 (set! dep8 (compile-program "testfile-tlp8")) 10888 (printf "loading testfile-tlp8.so\n") 10889 (list 10890 (with-output-to-string 10891 (lambda () 10892 (load-program "testfile-tlp8.so"))) 10893 dep8)) 10894 '("332211\n" ())) 10895 ; version of the above where program does depend on something 10896 (equal? 10897 (let () 10898 (define dep8) 10899 (with-output-to-file "testfile-tlp9.ss" 10900 (lambda () 10901 (pretty-print 10902 '(library (testfile-tlp9) 10903 (export t1-x) 10904 (import (chezscheme)) 10905 (define t1-x (make-parameter 332211))))) 10906 'replace) 10907 (with-output-to-file "testfile-tlp10.ss" 10908 (lambda () 10909 (pretty-print 10910 '(library (testfile-tlp10) 10911 (export t2-q) 10912 (import (chezscheme) (testfile-tlp9)) 10913 (define-syntax t2-q (identifier-syntax (t1-x)))))) 10914 'replace) 10915 (with-output-to-file "testfile-tlp11.ss" 10916 (lambda () 10917 (pretty-print '(import (chezscheme) (testfile-tlp10))) 10918 (pretty-print '(pretty-print t2-q))) 10919 'replace) 10920 ; if we don't let the compilation happen implicitly, the filename 10921 ; for (testfile-tlp9) doesn't get set 10922 (parameterize ([compile-imported-libraries #t]) 10923 (set! dep8 (compile-program "testfile-tlp11"))) 10924 (printf "loading testfile-tlp11.so\n") 10925 (list 10926 (with-output-to-string 10927 (lambda () 10928 (load-program "testfile-tlp11.so"))) 10929 dep8)) 10930 '("332211\n" ((testfile-tlp9)))) 10931 (equal? (library-object-filename '(testfile-tlp9)) "testfile-tlp9.so") 10932 ; make sure internal module bindings are properly set up before 10933 ; the body forms are processed 10934 (begin 10935 (top-level-program 10936 (import (chezscheme)) 10937 (module ((a x)) 10938 (define x 3) 10939 (define-syntax a (identifier-syntax x)) 10940 (putprop 'tlp-spam 'tlp 7)) 10941 a 10942 (putprop 'tlp-spam 'spam a)) 10943 (and (eqv? (getprop 'tlp-spam 'spam) 3) 10944 (eqv? (getprop 'tlp-spam 'tlp) 7) 10945 (remprop 'tlp-spam 'spam) 10946 (remprop 'tlp-spam 'tlp) 10947 #t)) 10948 ; make sure we ignore return value(s) of interleaved init expressions 10949 (equal? 10950 (with-output-to-string 10951 (lambda () 10952 ; prevent cp0 from fixing the problem 10953 (parameterize ([run-cp0 (lambda (f x) x)]) 10954 (eval '(top-level-program (import (scheme)) 10955 (define (f) (printf "hello\n") (values 1 2 3)) 10956 (f) 10957 (define x 'world) 10958 (pretty-print x)))))) 10959 "hello\nworld\n") 10960) 10961 10962(mat library-meta 10963 (begin 10964 (with-output-to-file "testfile-lm-a1.ss" 10965 (lambda () 10966 (pretty-print 10967 '(library (testfile-lm-a1) 10968 (export a) 10969 (import (chezscheme)) 10970 (meta define a #'17)))) 10971 'replace) 10972 (with-output-to-file "testfile-lm-a2.ss" 10973 (lambda () 10974 (pretty-print 10975 '(library (testfile-lm-a2) 10976 (export b) 10977 (import (chezscheme) (testfile-lm-a1)) 10978 (define-syntax b (lambda (q) a))))) 10979 'replace) 10980 (for-each separate-compile '(lm-a1 lm-a2)) 10981 #t) 10982 (equal? 10983 (let () 10984 (import (testfile-lm-a2)) 10985 b) 10986 17) 10987 (error? ; attempt to assign unbound variable 10988 (let () 10989 (import (testfile-lm-a1)) 10990 (define-syntax b (lambda (q) (set! a (+ a 1)) a)))) 10991 ; test $visit-library 10992 (begin 10993 (with-output-to-file "testfile-lm-b1.ss" 10994 (lambda () 10995 (pretty-print 10996 '(library (testfile-lm-b1) 10997 (export a) 10998 (import (chezscheme)) 10999 (meta define a #'17)))) 11000 'replace) 11001 (with-output-to-file "testfile-lm-b2.ss" 11002 (lambda () 11003 (pretty-print '(import (testfile-lm-b1))) 11004 (pretty-print '(define-syntax b (lambda (q) a)))) 11005 'replace) 11006 (for-each separate-compile '(lm-b1 lm-b2)) 11007 #t) 11008 (equal? 11009 (with-output-to-string 11010 (lambda () 11011 (parameterize ([trace-output-port (current-output-port)]) 11012 (load "testfile-lm-b2.so")))) 11013 "") 11014 (eqv? b 17) 11015) 11016 11017(mat library-introspection 11018 (error? (library-exports 'foo)) 11019 (error? (library-exports '(1 2 3))) 11020 (error? (library-exports '(probably not a valid loaded library))) 11021 (error? (library-exports '(probably not a valid loaded library (2 3)))) 11022 (error? (library-exports '(rnrs (six)))) 11023 (error? (library-exports '(rnrs (1)))) 11024 (error? (library-version 'foo)) 11025 (error? (library-version '(1 2 3))) 11026 (error? (library-version '(probably not a valid loaded library))) 11027 (error? (library-version '(probably not a valid loaded library ((>= 0))))) 11028 (error? (library-version '(rnrs (3 . 4)))) 11029 (error? (library-version '(rnrs (1)))) 11030 (error? (library-requirements 'foo)) 11031 (error? (library-requirements '(1 2 3))) 11032 (error? (library-requirements '(probably not a valid loaded library))) 11033 (error? (library-requirements '(probably not a valid loaded library (1)))) 11034 (error? (library-requirements '(rnrs (3.0)))) 11035 (error? (library-requirements '(rnrs (1)))) 11036 (error? (library-object-filename 'foo)) 11037 (error? (library-object-filename '(1 2 3))) 11038 (error? (library-object-filename '(probably not a valid loaded library))) 11039 (error? (library-object-filename '(probably not a valid loaded library (2 3)))) 11040 (error? (library-object-filename '(rnrs (six)))) 11041 (error? (library-object-filename '(rnrs (1)))) 11042 11043 (error? (library-requirements 'foo (library-requirements-options))) 11044 (error? (library-requirements '(1 2 3) (library-requirements-options))) 11045 (error? (library-requirements '(probably not a valid loaded library) (library-requirements-options))) 11046 (error? (library-requirements '(probably not a valid loaded library (1)) (library-requirements-options))) 11047 (error? (library-requirements '(rnrs (3.0)) (library-requirements-options))) 11048 (error? (library-requirements '(rnrs (1)) (library-requirements-options))) 11049 11050 (enum-set? (library-requirements-options)) 11051 (error? (library-requirements-options . a)) 11052 (error? (library-requirements-options spam)) 11053 (error? (library-requirements-options import spam)) 11054 11055 (error? (library-requirements '(chezscheme) 'import)) 11056 (error? (library-requirements '(chezscheme) '(import))) 11057 (error? (library-requirements '(chezscheme) '())) 11058 11059 (begin 11060 (define set-equal? 11061 (lambda (s1 s2) 11062 (and (= (length s1) (length s2)) 11063 (andmap (lambda (x) (member x s2)) s1) 11064 #t))) 11065 #t) 11066 (list? (library-list)) 11067 (andmap list? (library-list)) 11068 (andmap (lambda (x) (andmap symbol? x)) (library-list)) 11069 (begin 11070 (library (null) (export) (import)) 11071 #t) 11072 (let ([ls (library-list)]) 11073 (and 11074 (member '(rnrs) ls) 11075 (member '(rnrs strings) ls) 11076 (member '(rnrs io ports) ls) 11077 (member '(chezscheme) ls) 11078 (member '(scheme) ls) 11079 (member '(null) ls)) 11080 #t) 11081 (null? (library-exports '(null))) 11082 (set-equal? 11083 (library-exports '(rnrs mutable-pairs)) 11084 '(set-car! set-cdr!)) 11085 (equal? (sort string<? (map symbol->string (library-exports '(scheme)))) 11086 (sort string<? (map symbol->string (library-exports '(chezscheme))))) 11087 (equal? (library-version '(rnrs)) '(6)) 11088 (equal? (library-version '(rnrs (6))) '(6)) 11089 (equal? (library-version '(rnrs (or (6) (7)))) '(6)) 11090 (equal? (library-version '(rnrs (or (6) (7)))) '(6)) 11091 (equal? (library-version '(scheme)) '()) 11092 (equal? (library-requirements '(scheme)) '()) 11093 (equal? (library-requirements '(scheme) (library-requirements-options)) '()) 11094 (equal? (library-requirements '(scheme) (library-requirements-options import)) '()) 11095 (equal? (library-requirements '(scheme ())) '()) 11096 (equal? (library-requirements '(rnrs)) '()) 11097 (equal? (library-requirements '(null)) '()) 11098 (not (library-object-filename '(rnrs))) 11099 (not (library-object-filename '(rnrs (6)))) 11100 (not (library-object-filename '(rnrs (or (6) (7))))) 11101 (not (library-object-filename '(rnrs (or (6) (7))))) 11102 (not (library-object-filename '(scheme))) 11103 (begin 11104 (library (li1 (3 4 5)) 11105 (export x y) 11106 (import (chezscheme)) 11107 (define-syntax x (lambda (x) 3)) 11108 (define y (+ x 1))) 11109 (library (li2 (7 2)) 11110 (export x z w) 11111 (import (rnrs) (li1 (3))) 11112 (define z (+ x y)) 11113 (define-syntax w (lambda (q) (* y 2)))) 11114 (library (li2a (7 2)) 11115 (export x z w) 11116 (import (rnrs) (li1 (3))) 11117 (define z (+ x x)) 11118 (define-syntax w (lambda (q) (* y 2)))) 11119 #t) 11120 (and (member '(li1) (library-list)) 11121 (member '(li2) (library-list)) 11122 (member '(li2a) (library-list)) 11123 #t) 11124 (equal? (library-version '(li1)) '(3 4 5)) 11125 (equal? (library-version '(li2)) '(7 2)) 11126 (equal? (library-version '(li2 ((>= 5)))) '(7 2)) 11127 (equal? (library-version '(li2 (7 (>= 1)))) '(7 2)) 11128 (error? (library-version '(li2 (6)))) 11129 (set-equal? (library-exports '(li1)) '(x y)) 11130 (set-equal? (library-exports '(li2)) '(x z w)) 11131 (set-equal? (library-exports '(li2 ((>= 5)))) '(x z w)) 11132 (set-equal? (library-exports '(li2 (7 (>= 1)))) '(x z w)) 11133 (error? (library-exports '(li2 (6)))) 11134 (not (library-object-filename '(li1))) 11135 (not (library-object-filename '(li2))) 11136 (not (library-object-filename '(li2 ((>= 5))))) 11137 (not (library-object-filename '(li2 (7 (>= 1))))) 11138 (error? (library-exports '(li2 (6)))) 11139 (set-equal? 11140 (library-requirements '(li1)) 11141 '((chezscheme))) 11142 (set-equal? 11143 (library-requirements '(li2 ((>= 7)))) 11144 '((rnrs (6)) (li1 (3 4 5)))) 11145 (set-equal? 11146 (library-requirements '(li2)) 11147 '((rnrs (6)) (li1 (3 4 5)))) 11148 (set-equal? 11149 (library-requirements '(li2) (library-requirements-options import)) 11150 '((rnrs (6)) (li1 (3 4 5)))) 11151 (set-equal? 11152 (library-requirements '(li2) (library-requirements-options visit@visit)) 11153 '()) 11154 (set-equal? 11155 (library-requirements '(li2) (library-requirements-options invoke@visit)) 11156 '((li1 (3 4 5)))) 11157 (set-equal? 11158 (library-requirements '(li2) (library-requirements-options invoke)) 11159 '((li1 (3 4 5)))) 11160 (error? (library-requirements '(li2 (6)))) 11161 (set-equal? 11162 (library-requirements '(li2a)) 11163 '((rnrs (6)) (li1 (3 4 5)))) 11164 (set-equal? 11165 (library-requirements '(li2a) (library-requirements-options import)) 11166 '((rnrs (6)) (li1 (3 4 5)))) 11167 (set-equal? 11168 (library-requirements '(li2a) (library-requirements-options visit@visit)) 11169 '()) 11170 (set-equal? 11171 (library-requirements '(li2a) (library-requirements-options invoke@visit)) 11172 '((li1 (3 4 5)))) 11173 (set-equal? 11174 (library-requirements '(li2a) (library-requirements-options invoke)) 11175 '()) 11176 (equal? 11177 (let () 11178 (import (li1) (li2)) 11179 (list x y z w)) 11180 '(3 4 7 8)) 11181 ; make sure requirements haven't changed just because we used the exports 11182 (set-equal? 11183 (library-requirements '(li1)) 11184 '((chezscheme))) 11185 (set-equal? 11186 (library-requirements '(li2)) 11187 '((rnrs (6)) (li1 (3 4 5)))) 11188 (begin 11189 (define-syntax $li-a 11190 (syntax-rules () 11191 [(_ name a p) 11192 (begin 11193 (library name (export a y) (import (rnrs)) 11194 (define-syntax a (identifier-syntax (cons y 1))) 11195 (define y 'hello)) 11196 (define p (lambda () (import name) y)))])) 11197 ($li-a ($li-spam) q $li-get-y) 11198 #t) 11199 (eq? ($li-get-y) 'hello) 11200 (equal? (let () (import ($li-spam)) q) '(hello . 1)) 11201 (eqv? (let ([y 75]) (import ($li-spam)) y) 75) 11202 (begin 11203 (with-output-to-file "testfile-li3.ss" 11204 (lambda () 11205 (pretty-print 11206 '(library (testfile-li3) 11207 (export x) 11208 (import (rnrs)) 11209 (define x 3)))) 11210 'replace) 11211 (with-output-to-file "testfile-li4.ss" 11212 (lambda () 11213 (pretty-print 11214 '(library (testfile-li4) 11215 (export x) 11216 (import (rnrs)) 11217 (define x 3)))) 11218 'replace) 11219 (with-output-to-file "testfile-li5.ss" 11220 (lambda () 11221 (pretty-print 11222 '(library (testfile-li5) 11223 (export x) 11224 (import (rnrs)) 11225 (define x 3)))) 11226 'replace) 11227 (separate-compile 'li5) 11228 #t) 11229 (equal? 11230 (parameterize ([compile-imported-libraries #t]) 11231 (eval '(let () (import (testfile-li3)) x)) 11232 (library-object-filename '(testfile-li3))) 11233 "testfile-li3.so") 11234 (equal? 11235 (parameterize ([compile-imported-libraries #f]) 11236 (eval '(let () (import (testfile-li4)) x)) 11237 (library-object-filename '(testfile-li4))) 11238 #f) 11239 (equal? 11240 (begin 11241 (eval '(let () (import (testfile-li5)) x)) 11242 (library-object-filename '(testfile-li5))) 11243 "testfile-li5.so") 11244 (equal? 11245 (begin 11246 (load-library "testfile-li3.ss") 11247 (library-object-filename '(testfile-li3))) 11248 #f) 11249 (equal? 11250 (begin 11251 (load-library "testfile-li3.so") 11252 (library-object-filename '(testfile-li3))) 11253 "testfile-li3.so") 11254) 11255 11256(mat rnrs-eval 11257 (begin 11258 (define $eval-e1 (environment '(rnrs))) 11259 (environment? $eval-e1)) 11260 (error? ; variable environment not bound 11261 (r6rs:eval 'environment $eval-e1)) 11262 (error? ; variable eval not bound 11263 (r6rs:eval 'eval $eval-e1)) 11264 (eq? (r6rs:eval 'cons $eval-e1) cons) 11265 (error? ; invalid context for definition 11266 (r6rs:eval '(define x 4) $eval-e1)) 11267 (error? ; invalid context for definition 11268 (r6rs:eval '(define foo 4) $eval-e1)) 11269 (error? ; cannot assign cons 11270 (r6rs:eval '(set! cons 4) $eval-e1)) 11271 (error? ; cannot assign foo 11272 (r6rs:eval '(set! foo 4) $eval-e1)) 11273 (begin 11274 (with-output-to-file "testfile-eval1.ss" 11275 (lambda () 11276 (pretty-print 11277 '(library (testfile-eval1) 11278 (export canned spam list define quote set!) 11279 (import (rnrs)) 11280 (define-syntax canned 11281 (begin 11282 (display "testfile-eval1 visit") 11283 (newline) 11284 (identifier-syntax tuna))) 11285 (define spam (lambda () (cons 'not canned))) 11286 (define tuna 'yummy) 11287 (display "testfile-eval1 invoke") 11288 (newline)))) 11289 'replace) 11290 #t) 11291 (equal? 11292 (r6rs:eval 11293 '(list canned (spam)) 11294 (environment '(testfile-eval1))) 11295 '(yummy (not . yummy))) 11296 (error? ; cons is not bound 11297 (r6rs:eval 11298 '(cons canned (spam)) 11299 (environment '(testfile-eval1)))) 11300 (error? ; invalid context for definition 11301 (r6rs:eval 11302 '(define foo 3) 11303 (environment '(testfile-eval1)))) 11304 (error? ; cannot assign 11305 (r6rs:eval 11306 '(set! spam 3) 11307 (environment '(testfile-eval1)))) 11308 (error? ; cannot assign 11309 (r6rs:eval 11310 '(set! foo 3) 11311 (environment '(testfile-eval1)))) 11312 (error? ; invalid definition in immutable environment 11313 (let ([env (environment '(testfile-eval1))]) 11314 (eval `(define cons ',vector) env))) 11315 (equal? 11316 (let ([env (copy-environment (environment '(testfile-eval1)))]) 11317 (eval `(define cons ',vector) env) 11318 (r6rs:eval '(cons canned (spam)) env)) 11319 '#(yummy (not . yummy))) 11320 (eq? 11321 (r6rs:eval '(let () (import (scheme)) compile) 11322 (environment '(only (scheme) let import))) 11323 compile) 11324) 11325 11326(mat top-level-syntax-functions 11327 (error? (top-level-syntax "hello")) 11328 (error? (top-level-syntax)) 11329 (error? (top-level-syntax 'hello 'hello)) 11330 (error? (top-level-syntax (scheme-environment) (scheme-environment))) 11331 (error? (top-level-syntax? "hello")) 11332 (error? (top-level-syntax?)) 11333 (error? (top-level-syntax? 'hello 'hello)) 11334 (error? (top-level-syntax? (scheme-environment) (scheme-environment))) 11335 (error? (define-top-level-syntax "hello" "hello")) 11336 (error? (define-top-level-syntax)) 11337 (error? (define-top-level-syntax 15)) 11338 (error? (define-top-level-syntax 'hello 'hello 'hello)) 11339 (error? (define-top-level-syntax (scheme-environment) (scheme-environment) (scheme-environment))) 11340 (error? 11341 (let ([e (scheme-environment)]) 11342 (define-top-level-syntax 'p (lambda (x) "hello") e))) 11343 (error? 11344 (let ([e (copy-environment (scheme-environment) #f)]) 11345 (define-top-level-syntax 'p void e))) 11346 (error? 11347 (let ([e (scheme-environment)]) 11348 (top-level-syntax 'p e))) 11349 (and (top-level-syntax 'hopenotdefined) #t) 11350 (and (top-level-syntax 'cons) #t) 11351 (and (top-level-syntax 'scheme) #t) 11352 (error? (top-level-syntax 'cond (environment))) 11353 (top-level-syntax? 'hopenotdefined) 11354 (top-level-syntax? 'cons) 11355 (top-level-syntax? 'scheme) 11356 (not (top-level-syntax? 'cond (environment))) 11357 11358 (top-level-syntax? 'cond) 11359 (procedure? (top-level-syntax 'cond)) 11360 11361 (begin 11362 (define-top-level-syntax '$tls-foo (syntax-rules () [(_ x) (x x)])) 11363 #t) 11364 (equal? ($tls-foo list) `(,list)) 11365 11366 (equal? 11367 (parameterize ([interaction-environment 11368 (copy-environment (scheme-environment) #t)]) 11369 (let ([t (syntax-rules () [(_ x y) (* x y)])]) 11370 (eval `(define-syntax cons ',t)) 11371 (eval '(cons 3 4)))) 11372 12) 11373 (equal? 11374 (let ([e (environment '(only (scheme) cond))]) 11375 (list 11376 (top-level-syntax? 'cond e) 11377 (eq? (top-level-syntax 'cond e) (top-level-syntax 'cond (scheme-environment))) 11378 (top-level-syntax? 'cdr e))) 11379 '(#t #t #f)) 11380 (equal? 11381 (let ([e (copy-environment (environment) #t)]) 11382 (let ([t1 (lambda (x) 17)] [t2 (syntax-rules () [(_ x y) (list y x)])]) 11383 (define-top-level-syntax 'p t1 e) 11384 (define-top-level-syntax 'q t2 e) 11385 (list 11386 (top-level-syntax? 'p e) 11387 (top-level-syntax? 'q e) 11388 (top-level-syntax? 'r e) 11389 (eq? (top-level-syntax 'p e) t1) 11390 (eq? (top-level-syntax 'q e) t2) 11391 ((top-level-syntax 'p e) 'p) 11392 (eval '(q 3 4) e) 11393 (eval 'p e)))) 11394 '(#t #t #t #t #t 17 (4 3) 17)) 11395 ) 11396 11397(mat annotations 11398 (source-file-descriptor? 11399 (make-source-file-descriptor #f ; anything is allowed as a path 11400 (open-bytevector-input-port (string->utf8 "hello")))) 11401 (error? ; 17 is not a binary-input port 11402 (make-source-file-descriptor "foo" 17)) 11403 (error? ; #<input port stdin> is not a binary-input port 11404 (make-source-file-descriptor "foo" (open-string-input-port "oops"))) 11405 (error? ; #<binary input port> does not supoprt port-position and set-port-position! 11406 (make-source-file-descriptor "foo" 11407 (make-custom-binary-input-port "foo" (lambda (bv s c) 0) #f #f #f) 11408 #t)) 11409 (begin 11410 (define str "(ugh (if \x3b2;))") 11411 (define bv (string->utf8 str)) 11412 (define ip (open-bytevector-input-port bv)) 11413 (define sfd (make-source-file-descriptor "foo" ip #t)) 11414 #t) 11415 (not (= (bytevector-length bv) (string-length str))) 11416 (error? ; sfd is not an sfd 11417 (make-source-object 'sfd 2 3)) 11418 (error? ; two is not an exact integer 11419 (make-source-object sfd 'two 3)) 11420 (error? ; three is not an exact integer 11421 (make-source-object sfd 2 'three)) 11422 (error? ; bfp 3 is not between 0 and efp 2 11423 (make-source-object sfd 3 2)) 11424 (error? ; bfp -7 not between 0 and efp -3 11425 (make-source-object sfd -7 -3)) 11426 (error? ; bfp -7 is not between 0 and efp 3 11427 (make-source-object sfd -7 3)) 11428 (error? ; bfp -7 is not between 0 and efp 3 11429 (make-source-object sfd -7 3 2 1)) 11430 (error? ; one is not an exact integer 11431 (make-source-object sfd 1 2 'one 1)) 11432 (error? ; one is not an exact integer 11433 (make-source-object sfd 1 2 1 'one)) 11434 (error? ; zero is not an exact positive integer 11435 (make-source-object sfd 1 2 0 1)) 11436 (error? ; zero is not an exact positive integer 11437 (make-source-object sfd 1 2 1 0)) 11438 (error? ; bfp 3 is not between 0 and efp 2 11439 (make-source-object sfd 3 2 1 1)) 11440 (begin 11441 (define source (make-source-object sfd 2 3)) 11442 (define source-at-line-two (make-source-object sfd 3 5 2 1)) 11443 #t) 11444 (error? ; source is not a source object 11445 (make-annotation #f 'source #f)) 11446 (begin 11447 (define a (make-annotation '(if 3) source '(if I were a rich man))) 11448 (define a-at-line-two (make-annotation '(if 3) source-at-line-two '(if I were a rich man))) 11449 (define x (datum->syntax #'* a)) 11450 #t) 11451 (source-file-descriptor? sfd) 11452 (not (source-file-descriptor? source)) 11453 (source-object? source) 11454 (source-object? source-at-line-two) 11455 (not (source-object? sfd)) 11456 (not (source-object? a)) 11457 (annotation? a) 11458 (not (annotation? source)) 11459 (error? ; #<source> is not an sfd 11460 (source-file-descriptor-path source)) 11461 (error? ; #<annotation> is not an sfd 11462 (source-file-descriptor-checksum a)) 11463 (error? ; #<sfd> is not a source object 11464 (source-object-sfd sfd)) 11465 (error? ; #<annotation> is not a source object 11466 (source-object-bfp a)) 11467 (error? ; 3 is not a source object 11468 (source-object-efp 3)) 11469 (error? ; 3 is not a source object 11470 (source-object-line 3)) 11471 (error? ; 3 is not a source object 11472 (source-object-column 3)) 11473 (error? ; 3 is not an annotation 11474 (annotation-expression 3)) 11475 (error? ; #<source> is not an annotation 11476 (annotation-stripped source)) 11477 (error? ; #<sfd> is not an annotation 11478 (annotation-source sfd)) 11479 (error? ; #<source> is not an annotation 11480 (annotation-option-set source)) 11481 (error? ; invalid syntax 11482 (annotation-options . debug)) 11483 (error? ; invalid syntax 11484 (annotation-options 3 profile)) 11485 (error? ; invalid option 11486 (annotation-options fig)) 11487 (error? ; invalid option 11488 (annotation-options debug fig)) 11489 (error? ; invalid option 11490 (annotation-options fig profile)) 11491 (equal? 11492 (source-file-descriptor-path sfd) 11493 "foo") 11494 (number? (source-file-descriptor-checksum sfd)) 11495 (eq? (source-object-sfd source) sfd) 11496 (eq? (source-object-bfp source) 2) 11497 (eq? (source-object-efp source) 3) 11498 (eq? (source-object-line source) #f) 11499 (eq? (source-object-column source) #f) 11500 (eq? (source-object-sfd source) sfd) 11501 (eq? (source-object-bfp source-at-line-two) 3) 11502 (eq? (source-object-efp source-at-line-two) 5) 11503 (eq? (source-object-line source-at-line-two) 2) 11504 (eq? (source-object-column source-at-line-two) 1) 11505 (equal? (annotation-expression a) '(if 3)) 11506 (eq? (annotation-source a) source) 11507 (equal? (annotation-stripped a) '(if I were a rich man)) 11508 (enum-set=? (annotation-option-set a) (annotation-options debug profile)) 11509 (enum-set=? 11510 (annotation-option-set (make-annotation '(if 3) source '(if I were a rich man) (annotation-options))) 11511 (annotation-options)) 11512 (enum-set=? 11513 (annotation-option-set (make-annotation '(if 3) source '(if I were a rich man) (annotation-options debug))) 11514 (annotation-options debug)) 11515 (enum-set=? 11516 (annotation-option-set (make-annotation '(if 3) source '(if I were a rich man) (annotation-options profile))) 11517 (annotation-options profile)) 11518 (enum-set=? 11519 (annotation-option-set (make-annotation '(if 3) source '(if I were a rich man) (annotation-options debug profile))) 11520 (annotation-options debug profile)) 11521 (enum-set=? 11522 (annotation-option-set (make-annotation '(if 3) source '(if I were a rich man) (annotation-options profile debug))) 11523 (annotation-options debug profile)) 11524 (eq? (syntax->annotation x) a) 11525 (not (syntax->annotation #'(a b c))) 11526 (not (syntax->annotation '(a b c))) 11527 (not (syntax->annotation #f)) 11528 (error? ; invalid syntax (if I were a rich man) at char 2 of foo 11529 (expand a)) 11530 (error? ; invalid syntax (if I were a rich man) at line 2, char 1 of foo 11531 (expand a-at-line-two)) 11532 (error? ; invalid syntax (if I were a rich man) at char 2 of foo 11533 (eval a)) 11534 (error? ; invalid syntax (if I were a rich man) at char 2, char 1 of foo 11535 (eval a-at-line-two)) 11536 (error? ; invalid syntax (if I were a rich man) at char 2 of foo 11537 (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* a))) foo))) 11538 (error? ; invalid syntax (if I were a rich man) at line 2, char 1 of foo 11539 (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* a-at-line-two))) foo))) 11540 (error? ; invalid syntax (if I were a rich man) at char 2 of foo 11541 (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source '(if I were a rich man) (annotation-options debug profile))))) foo))) 11542 (error? ; invalid syntax (if I were a rich man) at line 2, char 1 of foo 11543 (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source-at-line-two '(if I were a rich man) (annotation-options debug profile))))) foo))) 11544 (error? ; invalid syntax (if I were a rich man) at char 2 of foo 11545 (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source '(if I were a rich man) (annotation-options debug))))) foo))) 11546 (error? ; invalid syntax (if I were a rich man) 11547 (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source '(if I were a rich man) (annotation-options profile))))) foo))) 11548 (error? ; invalid syntax (if I were a rich man) 11549 (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source '(if I were a rich man) (annotation-options))))) foo))) 11550 (error? ; invalid argument count in call (f) at char 2 of foo 11551 (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source '(f) (annotation-options debug profile)))))) foo))) 11552 (error? ; invalid argument count in call (f) at line 2, char 1 of foo 11553 (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source-at-line-two '(f) (annotation-options debug profile)))))) foo))) 11554 (error? ; invalid argument count in call (f) at char 2 of foo 11555 (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source '(f) (annotation-options debug)))))) foo))) 11556 (error? ; invalid argument count in call (f) 11557 (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source '(f) (annotation-options profile)))))) foo))) 11558 (error? ; invalid argument count in call (f) 11559 (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source '(f) (annotation-options)))))) foo))) 11560 (begin 11561 (profile-clear) 11562 #t) 11563 (begin 11564 (define foo 11565 (parameterize ([compile-profile #t] [current-eval compile]) 11566 (eval '(lambda () 11567 (define-syntax foo 11568 (lambda (z) 11569 (datum->syntax #'* 11570 (make-annotation 11571 `(,(make-annotation '+ (make-source-object sfd 2 3) '+ (annotation-options debug profile)) 11572 ,(make-annotation '3 (make-source-object sfd 4 5) '3 (annotation-options)) 11573 ,(make-annotation '44 (make-source-object sfd 8 10) '44 (annotation-options debug))) 11574 (make-source-object sfd 1 11) 11575 '(+ 3 44) 11576 (annotation-options profile))))) 11577 foo)))) 11578 #t) 11579 (equal? (foo) 47) 11580 (equal? 11581 (let ([ls (profile-dump-list)]) 11582 (vector 11583 (find (lambda (x) (equal? (list-head (cdr x) 3) '("foo" 1 11))) ls) 11584 (find (lambda (x) (equal? (list-head (cdr x) 3) '("foo" 2 3))) ls) 11585 (find (lambda (x) (equal? (list-head (cdr x) 3) '("foo" 4 5))) ls) 11586 (find (lambda (x) (equal? (list-head (cdr x) 3) '("foo" 8 10))) ls))) 11587 '#((1 "foo" 1 11 #f #f) 11588 (1 "foo" 2 3 #f #f) 11589 #f 11590 #f)) 11591 (begin 11592 (profile-clear) 11593 #t) 11594 (begin 11595 (define ip (transcoded-port ip (native-transcoder))) 11596 (define-values (x fp) (get-datum/annotations ip sfd 0)) 11597 #t) 11598 (error? ; #<sfd> is not a textual input port 11599 (get-datum/annotations sfd sfd 0)) 11600 (error? ; #<input port> is not an sfd 11601 (get-datum/annotations ip ip 0)) 11602 (error? ; #<sfd> is not a valid file position 11603 (get-datum/annotations ip sfd sfd)) 11604 (error? ; -5 is not a valid file position 11605 (get-datum/annotations ip sfd -5)) 11606 (error? ; 5.0 is not a valid file position 11607 (get-datum/annotations ip sfd 5.0)) 11608 (eqv? fp (string-length str)) 11609 (annotation? x) 11610 (equal? (annotation-stripped x) (with-input-from-string str read)) 11611 (equal? 11612 (let f ([x x]) 11613 (and (annotation? x) 11614 (let ([x (annotation-expression x)]) 11615 (if (list? x) 11616 (map f x) 11617 x)))) 11618 (with-input-from-string str read)) 11619 (begin 11620 (define source (annotation-source x)) 11621 #t) 11622 (source-object? source) 11623 (eq? (source-object-sfd source) sfd) 11624 (eqv? (source-object-bfp source) 0) 11625 (eqv? (source-object-efp source) (string-length str)) 11626 (source-file-descriptor? 11627 (source-file-descriptor 'spam 0)) 11628 (error? ; not an exact nonnegative integer 11629 (source-file-descriptor "spam" -1)) 11630 (error? ; not an exact nonnegative integer 11631 (source-file-descriptor "spam" 1.0)) 11632 (source-file-descriptor? (source-file-descriptor "spam" #x34534a5)) 11633 (source-file-descriptor? (source-file-descriptor "spam" #x20333333333339999999997834443333337)) 11634 (equal? 11635 (source-file-descriptor-path (source-file-descriptor "spam" #x20333333333339999999997834443333337)) 11636 "spam") 11637 (equal? 11638 (source-file-descriptor-checksum (source-file-descriptor "spam" #x20333333333339999999997834443333337)) 11639 #x20333333333339999999997834443333337) 11640 (error? ; not an sfd 11641 (locate-source "spam" 17)) 11642 (error? ; not an exact nonnegative integer 11643 (locate-source sfd -1)) 11644 (error? ; not an exact nonnegative integer 11645 (locate-source sfd 'a)) 11646 (let-values ([() (locate-source sfd 7)]) #t) 11647 (let-values ([() (locate-source (source-file-descriptor 'something-else 0) 7)]) #t) 11648 (begin 11649 (with-output-to-file "testfile.ss" 11650 (lambda () 11651 (printf "; bogus exports\n") 11652 (printf "(module (a 3)\n") 11653 (printf " (define a 3))\n")) 11654 'replace) 11655 #t) 11656 (equal? 11657 (guard (c [(syntax-violation? c) 11658 (let* ([form (syntax-violation-form c)] 11659 [annotation (syntax->annotation form)] 11660 [source (annotation-source annotation)]) 11661 (cons 11662 (call-with-values (lambda () (locate-source (source-object-sfd source) (source-object-bfp source))) vector) 11663 (call-with-values (lambda () (locate-source (source-object-sfd source) (source-object-efp source))) vector)))]) 11664 (load "testfile.ss")) 11665 '(#("testfile.ss" 2 12) . #("testfile.ss" 2 13))) 11666 (equal? 11667 (let ([sfd (source-file-descriptor (source-file-descriptor-path sfd) (source-file-descriptor-checksum sfd) )]) 11668 (let ([source (make-source-object sfd 2 3)]) 11669 (guard (c [(syntax-violation? c) 11670 (let* ([form (syntax-violation-form c)] 11671 [annotation (syntax->annotation form)] 11672 [source (annotation-source annotation)]) 11673 (cons 11674 (call-with-values (lambda () (locate-source (source-object-sfd source) (source-object-bfp source))) vector) 11675 (call-with-values (lambda () (locate-source (source-object-sfd source) (source-object-efp source))) vector)))]) 11676 (load "testfile.ss")))) 11677 '(#("testfile.ss" 2 12) . #("testfile.ss" 2 13))) 11678 11679 (error? ; not a source object 11680 (locate-source-object-source "spam" #t #t)) 11681 (error? 11682 (current-locate-source-object-source 7)) 11683 (error? 11684 (current-locate-source-object-source "string")) 11685 (error? ; not a source object 11686 ((current-locate-source-object-source) "spam" #t #t)) 11687 (error? ; invalid syntax (if I were a rich man) at line 200, char 17 of foo 11688 (parameterize ([current-locate-source-object-source 11689 (lambda (src start? cache?) 11690 (values (source-file-descriptor-path (source-object-sfd src)) 200 17))]) 11691 (expand a))) 11692 ) 11693 11694(mat annotations-via-recorded-lines 11695 (error? 11696 (current-make-source-object 7)) 11697 (error? 11698 (current-make-source-object "string")) 11699 (begin 11700 (define sfd-with-lines 11701 (let ((op (open-output-file "testfile.ss" 'replace))) 11702 (display "apple\n banana\ncoconut" op) 11703 (close-port op) 11704 (let* ([ip (open-file-input-port "testfile.ss")] 11705 [sfd (make-source-file-descriptor "testfile.ss" ip)]) 11706 (close-port ip) 11707 sfd))) 11708 (define input-string-with-lines "Apple\n Banana\nCoconut\nMore") 11709 (define input-port-with-lines (open-string-input-port input-string-with-lines)) 11710 (define input-port-with-line-pos 0) 11711 (define (make-make-source-object/get-lines expected-sfd) 11712 (lambda (sfd bfp efp) 11713 (if (eq? sfd expected-sfd) 11714 ;; Gather line and column now: 11715 (let-values ([(path line col) (locate-source sfd bfp #t)]) 11716 (make-source-object sfd bfp efp line col)) 11717 (error 'recording-make-source-object "reading some other file?")))) 11718 (define (read-with-lines) 11719 (parameterize ([current-make-source-object (make-make-source-object/get-lines sfd-with-lines)]) 11720 (let-values ([(v pos) (get-datum/annotations input-port-with-lines sfd-with-lines input-port-with-line-pos)]) 11721 (set! input-port-with-line-pos pos) 11722 v))) 11723 #t) 11724 (begin 11725 (define line-one (read-with-lines)) 11726 (annotation? line-one)) 11727 (equal? (annotation-stripped line-one) 'Apple) 11728 (equal? (source-object-bfp (annotation-source line-one)) 0) 11729 (equal? (source-object-line (annotation-source line-one)) 1) 11730 (equal? (source-object-column (annotation-source line-one)) 1) 11731 (begin 11732 (define line-two (read-with-lines)) 11733 (annotation? line-two)) 11734 (equal? (source-object-bfp (annotation-source line-two)) 8) 11735 (equal? (source-object-line (annotation-source line-two)) 2) 11736 (equal? (source-object-column (annotation-source line-two)) 3) 11737 (begin 11738 (define line-three (read-with-lines)) 11739 (annotation? line-three)) 11740 (equal? (source-object-bfp (annotation-source line-three)) 15) 11741 (equal? (source-object-line (annotation-source line-three)) 3) 11742 (equal? (source-object-column (annotation-source line-three)) 1) 11743 (annotation? (read-with-lines)) ; 'More 11744 (eof-object? (read-with-lines)) 11745 11746 ;; Make sure lines are calculated right with input that is longer than 11747 ;; the file buffer size: 11748 (begin 11749 (define input-string-with-lines (string-append 11750 "\"" 11751 (make-string (* 2 (file-buffer-size)) #\a) 11752 "\"" 11753 "\nend")) 11754 11755 (define input-port-with-lines (open-string-input-port input-string-with-lines)) 11756 (define sfd-with-lines 11757 (let ((op (open-output-file "testfile.ss" 'replace))) 11758 (display input-string-with-lines op) 11759 (close-port op) 11760 (let* ([ip (open-file-input-port "testfile.ss")] 11761 [sfd (make-source-file-descriptor "testfile.ss" ip)]) 11762 (close-port ip) 11763 sfd))) 11764 (define input-port-with-line-pos 0) 11765 (define (read-with-lines) 11766 (parameterize ([current-make-source-object (make-make-source-object/get-lines sfd-with-lines)]) 11767 (let-values ([(v pos) (get-datum/annotations input-port-with-lines sfd-with-lines input-port-with-line-pos)]) 11768 (set! input-port-with-line-pos pos) 11769 v))) 11770 (define line-one (read-with-lines)) 11771 (annotation? line-one)) 11772 (string? (annotation-stripped line-one)) 11773 (begin 11774 (define line-two (read-with-lines)) 11775 (annotation? line-two)) 11776 (equal? (source-object-line (annotation-source line-two)) 2) 11777 (equal? (source-object-column (annotation-source line-two)) 1) 11778 ) 11779 11780(mat locate-source-caching 11781 (begin 11782 (define (make-expr n) 11783 `(let () 11784 ,@(let loop ([i n]) 11785 (if (zero? i) 11786 '(#t) 11787 (cons 11788 `(let-values ([(x y z) (values 1 2 3)]) x) 11789 (loop (sub1 i))))))) 11790 11791 (define (time-expr n) 11792 (with-output-to-file "testfile.ss" 11793 (lambda () 11794 (pretty-print (make-expr n))) 11795 'truncate) 11796 (collect) 11797 (parameterize ([collect-request-handler void]) 11798 (let ([start (current-time)]) 11799 (load "testfile.ss" expand) 11800 (let ([delta (time-difference (current-time) start)]) 11801 (+ (* #e1e9 (time-second delta)) 11802 (time-nanosecond delta)))))) 11803 11804 (let loop ([tries 3]) 11805 (when (zero? tries) 11806 (error 'source-cache-test "loading lots of `let-values` forms seems to take too long")) 11807 (let ([t1000 (time-expr 1000)] [t10000 (time-expr 10000)]) 11808 (or (> (* 20 t1000) t10000) 11809 (begin 11810 (printf "t1000 = ~s, t10000 = ~s, t10000 / t1000 = ~s\n" t1000 t10000 (inexact (/ t10000 t1000))) 11811 (loop (sub1 tries))))))) 11812 11813 (begin 11814 (define sfd-to-cache 11815 (let ((op (open-output-file "testfile.ss" 'replace))) 11816 (display "apple\n banana\ncoconut" op) 11817 (close-port op) 11818 (let* ([ip (open-file-input-port "testfile.ss")] 11819 [sfd (make-source-file-descriptor "testfile.ss" ip)]) 11820 (close-port ip) 11821 sfd))) 11822 11823 (equal? (call-with-values 11824 (lambda () (locate-source sfd-to-cache 8 #t)) 11825 (case-lambda 11826 [(name line col) (list line col)])) 11827 '(2 3))) 11828 11829 (begin 11830 (let ((op (open-output-file "testfile.ss" 'replace))) 11831 (display "1\n2\n3\n4\n5\n6789" op) 11832 (close-port op)) 11833 ;; Cache may report the old source line, 11834 ;; or uncached should report no line: 11835 (equal? (call-with-values 11836 (lambda () (locate-source sfd-to-cache 8 #t)) 11837 (case-lambda 11838 [() '(2 3)] ; report no line same as expected cache 11839 [(name line col) (list line col)])) 11840 '(2 3))) 11841 11842 ;; An uncached lookup defniitely reports no line: 11843 (equal? (call-with-values 11844 (lambda () (locate-source sfd-to-cache 8 #f)) 11845 (lambda () 'none)) 11846 'none) 11847 11848 (begin 11849 (collect (collect-maximum-generation)) 11850 ;; After collecting the maximum generation, the 11851 ;; cached information shoould definitely be gone: 11852 (equal? (call-with-values 11853 (lambda () (locate-source sfd-to-cache 8 #t)) 11854 (lambda () 'gone)) 11855 'gone)) 11856 ) 11857 11858(mat include 11859 (error? ; invalid syntax 11860 (expand '(include spam))) 11861 (error? ; invalid syntax 11862 (parameterize ([source-directories '("../s" "../c")]) 11863 (expand '(include spam)))) 11864 ) 11865 11866(mat extend-syntax 11867 (begin (extend-syntax (foo) 11868 [(foo a b) (list a b)]) 11869 #t) 11870 (equal? (foo 3 4) '(3 4)) 11871 (begin (extend-syntax (foo bar) 11872 [(foo) '()] 11873 [(foo (bar x)) x] 11874 [(foo x) (cons x '())] 11875 [(foo x y ...) (cons x (foo y ...))]) 11876 #t) 11877 (equal? (foo 'a 'b 'c 'd) '(a b c d)) 11878 (equal? (foo 'a 'b 'c (bar 'd)) '(a b c . d)) 11879 (begin (extend-syntax (foo) 11880 [(foo ((x v) ...) e1 e2 ...) 11881 (andmap symbol? '(x ...)) 11882 ((lambda (x ...) e1 e2 ...) v ...)] 11883 [(foo ((lambda (x ...) e1 e2 ...) v ...)) 11884 (= (length '(x ...)) (length '(v ...))) 11885 (foo ((x v) ...) e1 e2 ...)]) 11886 #t) 11887 (equal? (foo ((a 3) (b 4)) (cons a b)) '(3 . 4)) 11888 (error? (extend-syntax (foo ...) [(foo ...) 0])) 11889 (error? (extend-syntax (foo) [(foo x ... y) 0])) 11890 (error? (extend-syntax (foo) [(foo x . ...) 0])) 11891 (error? (extend-syntax (foo) [(foo (...)) 0])) 11892 (error? (extend-syntax (foo) [(foo x x) 0])) 11893 (begin (extend-syntax (foo) [(foo foo) 0]) #t) 11894 (begin (extend-syntax (foo) [(foo keys) (with ([x `,'keys]) 'x)]) 11895 (equal? (foo (a b c)) '(a b c))) 11896 (begin (extend-syntax (foo) [(foo x y) '`(x ,@y)]) 11897 (equal? (foo a b) '`(a ,@b))) 11898 (begin (extend-syntax (foo) ; test exponential "with" time problem 11899 [(foo) 11900 (with ([a1 1] [b1 2] [c1 3] [d1 4] [e1 5] [f1 6] [g1 7] [h1 8] 11901 [a2 1] [b2 2] [c2 3] [d2 4] [e2 5] [f2 6] [g2 7] [h2 8] 11902 [a3 1] [b3 2] [c3 3] [d3 4] [e3 5] [f3 6] [g3 7] [h3 8] 11903 [a4 1] [b4 2] [c4 3] [d4 4] [e4 5] [f4 6] [g4 7] [h4 8] 11904 [a5 1] [b5 2] [c5 3] [d5 4] [e5 5] [f5 6] [g5 7] [h5 8] 11905 [a6 1] [b6 2] [c6 3] [d6 4] [e6 5] [f6 6] [g6 7] [h6 8] 11906 [a7 1] [b7 2] [c7 3] [d7 4] [e7 5] [f7 6] [g7 7] [h7 8] 11907 [a8 1] [b8 2] [c8 3] [d8 4] [e8 5] [f8 6] [g8 7] [h8 8]) 11908 '(a1 b2 c3 d4 e5 f6 g7 h8))]) 11909 (equal? (foo) '(1 2 3 4 5 6 7 8))) 11910 (equal? (letrec* ((x 3) (y (+ x 2))) (list x y)) '(3 5)) 11911 ) 11912 11913(mat with 11914 (begin (extend-syntax (foo) 11915 [(foo x ...) 11916 (with ([n (length '(x ...))]) 11917 (list n 'x ...))]) 11918 #t) 11919 (equal? (foo 3 2 1) '(3 3 2 1)) 11920 (begin (extend-syntax (foo) 11921 [(foo (x ...) ...) 11922 (list (with ([(y ...) 11923 '(x ... (with ([n (length '(x ...))]) n))]) 11924 (with ([(z ...) (reverse '(y ...))]) 11925 (list 'z ...))) 11926 ...)]) 11927 #t) 11928 (equal? (foo) '()) 11929 (equal? (foo (a b) (c d e)) '((2 b a) (3 e d c))) 11930 (begin (extend-syntax (foo) 11931 [(foo x ...) 11932 (with ([(y1 y2 ...) '(x ...)]) 11933 (with ([(z1 z2) 'y1]) 11934 '(z2 z1)))]) 11935 #t) 11936 (equal? (foo (a b) (c d) (e f)) '(b a)) 11937 ) 11938