1;;; 2;;; primitive syntax test 3;;; 4 5(use gauche.test) 6 7(test-start "primitive syntax") 8 9;; We use prim-test instead of test, for error-handler is not tested yet. 10 11;;---------------------------------------------------------------- 12(test-section "conditionals") 13 14(prim-test "if" 5 (lambda () (if #f 2 5))) 15(prim-test "if" 2 (lambda () (if (not #f) 2 5))) 16 17(prim-test "and" #t (lambda () (and))) 18(prim-test "and" 5 (lambda () (and 5))) 19(prim-test "and" #f (lambda () (and 5 #f 2))) 20(prim-test "and" #f (lambda () (and 5 #f unbound-var))) 21(prim-test "and" 'a (lambda () (and 3 4 'a))) 22 23(prim-test "or" #f (lambda () (or))) 24(prim-test "or" 3 (lambda () (or 3 9))) 25(prim-test "or" 3 (lambda () (or #f 3 unbound-var))) 26 27(prim-test "when" 4 (lambda () (when 3 5 4))) 28(prim-test "when" (undefined) (lambda () (when #f 5 4))) 29(prim-test "when" (undefined) (lambda () (when #f unbound-var))) 30(prim-test "unless" (undefined) (lambda () (unless 3 5 4))) 31(prim-test "unless" (undefined) (lambda () (unless #t unbound-var))) 32(prim-test "unless" 4 (lambda () (unless #f 5 4))) 33 34(prim-test "cond" (undefined) (lambda () (cond (#f 2)))) 35(prim-test "cond" 5 (lambda () (cond (#f 2) (else 5)))) 36(prim-test "cond" 2 (lambda () (cond (1 2) (else 5)))) 37(prim-test "cond" 8 (lambda () (cond (#f 2) (1 8) (else 5)))) 38(prim-test "cond" 3 (lambda () (cond (1 => (lambda (x) (+ x 2))) (else 8)))) 39(prim-test "cond (srfi-61)" 1 (lambda () (cond (1 number? => values) (else 8)))) 40(prim-test "cond (srfi-61)" 8 (lambda () (cond (1 string? => values) (else 8)))) 41(prim-test "cond (srfi-61)" '(1 2) 42 (lambda () (cond ((values 1 2) 43 (lambda (x y) (and (= x 1) (= y 2))) 44 => list)))) 45 46(prim-test "case" #t (lambda () (case (+ 2 3) ((1 3 5 7 9) #t) ((0 2 4 6 8) #f)))) 47(prim-test "case" #t (lambda () (undefined? (case 1 ((2 3) #t))))) 48(prim-test "case" #t (lambda () (case 1 (() #f) ((1) #t)))) 49(prim-test "case" #t (lambda () (case 1 (() #f) (else #t)))) 50(prim-test "case" #t (lambda () (undefined? (case 1 (() #t))))) 51(prim-test "case (srfi-87)" 0 (lambda () (case (+ 2 3) ((1 3 5) 0) (else => values)))) 52(prim-test "case (srfi-87)" 6 (lambda () (case (+ 2 3) ((1 3 5) => (cut + 1 <>)) (else => values)))) 53(prim-test "case (srfi-87)" 5 (lambda () (case (+ 2 3) ((2 4 6) 0) (else => values)))) 54 55;;---------------------------------------------------------------- 56(test-section "binding") 57 58(prim-test "let" 35 59 (lambda () 60 (let ((x 2) (y 3)) 61 (let ((x 7) (z (+ x y))) 62 (* z x))))) 63(prim-test "let*" 70 64 (lambda () 65 (let ((x 2) (y 3)) 66 (let* ((x 7) (z (+ x y))) 67 (* z x))))) 68(prim-test "let*" 2 69 (lambda () 70 (let* ((x 1) (x (+ x 1))) x))) 71 72(prim-test "named let" -3 73 (lambda () 74 (let ((f -)) 75 (let f ((a (f 3))) 76 a)))) 77 78;;---------------------------------------------------------------- 79(test-section "closure and saved env") 80 81(prim-test "lambda" 5 (lambda () ((lambda (x) (car x)) '(5 6 7)))) 82(prim-test "lambda" 12 83 (lambda () 84 ((lambda (x y) 85 ((lambda (z) (* (car z) (cdr z))) (cons x y))) 3 4))) 86 87(define (addN n) (lambda (a) (+ a n))) 88(prim-test "lambda" 5 (lambda () ((addN 2) 3))) 89(define add3 (addN 3)) 90(prim-test "lambda" 9 (lambda () (add3 6))) 91 92(define count (let ((c 0)) (lambda () (set! c (+ c 1)) c))) 93(prim-test "lambda" 1 (lambda () (count))) 94(prim-test "lambda" 2 (lambda () (count))) 95 96;;---------------------------------------------------------------- 97(test-section "application") 98 99(define Apply apply) ; avoid inline expansion 100 101(prim-test "apply" '(1 2 3) (lambda () (Apply list '(1 2 3)))) 102(prim-test "apply" '(2 3 4) (lambda () (Apply list 2 '(3 4)))) 103(prim-test "apply" '(3 4 5) (lambda () (Apply list 3 4 '(5)))) 104(prim-test "apply" '(4 5 6) (lambda () (Apply list 4 5 6 '()))) 105 106(prim-test "apply^2" '() (lambda () (Apply Apply list '() '()))) 107(prim-test "Apply^2" '() (lambda () (Apply Apply list '(())))) 108(prim-test "apply^2" '(1 . 2) (lambda () (Apply Apply cons '((1 2))))) 109(prim-test "apply^2" '(3 . 4) (lambda () (Apply Apply cons 3 '((4))))) 110(prim-test "apply^2" '(5 . 6) (lambda () (Apply Apply (list cons 5 '(6))))) 111 112 113(prim-test "apply" '(6 7 8) (lambda () (Apply Apply (list list 6 7 '(8))))) 114 115 116;; This tests 'unfolding' path in ADJUST_ARGUMENT_FRAME. 117(prim-test "apply, copying args" '(1 2 3) 118 (lambda () 119 (let ((orig (list 1 2 3))) 120 (let ((new (Apply list orig))) 121 (set-car! (cdr new) '100) 122 orig)))) 123 124;; This tests 'folding' path in ADJUST_ARGUMENT_FRAME 125(prim-test "apply, copying args" '(2 3) 126 (lambda () 127 (let ((orig (list 2 3))) 128 (let ((new (Apply list 1 orig))) 129 (set-car! (cdr new) '100) 130 orig)))) 131 132;; Detect circular list in the argument 133;; https://github.com/shirok/Gauche/issues/684 134;; NB: At this point, we haven't tested #0= reader notation, 135;; and to avoid optimization, these data should be in global space. 136(define *apply-circular-data-1* 137 (let ((x (list 'a))) 138 (set-cdr! x x) 139 x)) 140(define *apply-circular-data-2* 141 (let ((x (list 'a 'a))) 142 (set-cdr! (cdr x) x) 143 x)) 144 145(prim-test "apply, circular list 1" 146 "improper list not allowed: #0=(a . #0#)" 147 (lambda () 148 (with-error-handler 149 (lambda (e) (slot-ref e 'message)) 150 (lambda () 151 (apply list *apply-circular-data-1*))))) 152(prim-test "apply, circular list 2" 153 "improper list not allowed: #0=(a . #0#)" 154 (lambda () 155 (with-error-handler 156 (lambda (e) (slot-ref e 'message)) 157 (lambda () 158 (apply list 'a *apply-circular-data-1*))))) 159(prim-test "apply, circular list 3" 160 "improper list not allowed: #0=(a a . #0#)" 161 (lambda () 162 (with-error-handler 163 (lambda (e) (slot-ref e 'message)) 164 (lambda () 165 (apply list 'a *apply-circular-data-2*))))) 166(prim-test "apply, circular list 4" 167 "improper list not allowed: #0=(a a . #0#)" 168 (lambda () 169 (with-error-handler 170 (lambda (e) (slot-ref e 'message)) 171 (lambda () 172 ;; This is caught in different place (#<subr apply>), 173 ;; rather than VM APPLY instruction. 174 (Apply list 'a *apply-circular-data-2*))))) 175 176;; This test exhibits the optimizer bug reported by Michael Campbell. 177(define bug-optimizer-local-inliner 178 (lambda (flag) 179 (define (a . args) 180 (receive x args 181 (cons x x) 182 (Apply values x)) 183 (Apply format args)) 184 (define (b bar) 185 (a "~a" bar)) 186 (b 1) 187 (cond 188 (flag (b 1)) 189 (else (a "~a" 1))))) 190(prim-test "apply local inliner optimizer" "1" 191 (lambda () (bug-optimizer-local-inliner #f)) equal?) 192(prim-test "apply local inliner optimizer" "1" 193 (lambda () (bug-optimizer-local-inliner #t)) equal?) 194 195(prim-test "map" '() (lambda () (map car '()))) 196(prim-test "map" '(1 2 3) (lambda () (map car '((1) (2) (3))))) 197(prim-test "map" '(() () ()) (lambda () (map cdr '((1) (2) (3))))) 198(prim-test "map" '((1 . 4) (2 . 5) (3 . 6)) (lambda () (map cons '(1 2 3) '(4 5 6)))) 199 200;;---------------------------------------------------------------- 201(test-section "loop") 202 203(define (fact-non-tail-rec n) 204 (if (<= n 1) n (* n (fact-non-tail-rec (- n 1))))) 205(prim-test "loop non-tail-rec" 120 (lambda () (fact-non-tail-rec 5))) 206 207(define (fact-tail-rec n r) 208 (if (<= n 1) r (fact-tail-rec (- n 1) (* n r)))) 209(prim-test "loop tail-rec" 120 (lambda () (fact-tail-rec 5 1))) 210 211(define (fact-named-let n) 212 (let loop ((n n) (r 1)) (if (<= n 1) r (loop (- n 1) (* n r))))) 213(prim-test "loop named-let" 120 (lambda () (fact-named-let 5))) 214 215(define (fact-int-define n) 216 (define (rec n r) (if (<= n 1) r (rec (- n 1) (* n r)))) 217 (rec n 1)) 218(prim-test "loop int-define" 120 (lambda () (fact-int-define 5))) 219 220(define (fact-do n) 221 (do ((n n (- n 1)) (r 1 (* n r))) ((<= n 1) r))) 222(prim-test "loop do" 120 (lambda () (fact-do 5))) 223 224;; tricky case 225(prim-test "do" #f (lambda () (do () (#t #f) #t))) 226 227;;---------------------------------------------------------------- 228(test-section "quasiquote") 229 230;; The new compiler generates constant list for much wider 231;; range of quasiquoted forms (e.g. constant numerical expressions 232;; and constant variable definitions are folded at the compile time). 233 234(define-constant quasi0 99) 235(define quasi1 101) 236(define-constant quasi2 '(a b)) 237(define quasi3 '(c d)) 238 239(prim-test "qq" '(1 2 3) (lambda () `(1 2 3))) 240(prim-test "qq" '() (lambda () `())) 241(prim-test "qq" 99 (lambda () `,quasi0)) 242(prim-test "qq" 101 (lambda () `,quasi1)) 243(prim-test "qq," '((1 . 2)) (lambda () `(,(cons 1 2)))) 244(prim-test "qq," '((1 . 2) 3) (lambda () `(,(cons 1 2) 3))) 245(prim-test "qq," '(0 (1 . 2)) (lambda () `(0 ,(cons 1 2)))) 246(prim-test "qq," '(0 (1 . 2) 3) (lambda () `(0 ,(cons 1 2) 3))) 247(prim-test "qq," '(((1 . 2))) (lambda () `((,(cons 1 2))))) 248(prim-test "qq," '(((1 . 2)) 3) (lambda () `((,(cons 1 2)) 3))) 249(prim-test "qq," '(99 3) (lambda () `(,quasi0 3))) 250(prim-test "qq," '(3 99) (lambda () `(3 ,quasi0))) 251(prim-test "qq," '(3 99 3) (lambda () `(3 ,quasi0 3))) 252(prim-test "qq," '(100 3) (lambda () `(,(+ quasi0 1) 3))) 253(prim-test "qq," '(3 100) (lambda () `(3 ,(+ quasi0 1)))) 254(prim-test "qq," '(101 3) (lambda () `(,quasi1 3))) 255(prim-test "qq," '(3 101) (lambda () `(3 ,quasi1))) 256(prim-test "qq," '(102 3) (lambda () `(,(+ quasi1 1) 3))) 257(prim-test "qq," '(3 102) (lambda () `(3 ,(+ quasi1 1)))) 258(prim-test "qq,(r6rs)" '(98 99 (a b) 100) 259 (lambda () `(98 (unquote quasi0 quasi2) 100))) 260(prim-test "qq,(r6rs)" '(98 99 101 100) 261 (lambda () `(98 (unquote quasi0 quasi1) 100))) 262(prim-test "qq,(r6rs)" '(98 99 (a b) 100) 263 (lambda () `(98 (unquote quasi0 quasi2) 100))) 264(prim-test "qq,(r6rs)" '(98 99 (a b) (1 2) (3 4)) 265 (lambda () `(98 (unquote quasi0 quasi2) (unquote (list 1 2) (list 3 4))))) 266(prim-test "qq@" '(1 2 3 4) (lambda () `(1 ,@(list 2 3) 4))) 267(prim-test "qq@" '(1 2 3 4) (lambda () `(1 2 ,@(list 3 4)))) 268(prim-test "qq@" '(a b c d) (lambda () `(,@quasi2 ,@quasi3))) 269(prim-test "qq@(r6rs)" '(1 a b a b 2) 270 (lambda () `(1 (unquote-splicing quasi2 quasi2) 2))) 271(prim-test "qq@(r6rs)" '(1 a b c d 2) 272 (lambda () `(1 (unquote-splicing quasi2 quasi3) 2))) 273(prim-test "qq@(r6rs)" '(1 a b c d 2) 274 (lambda () `(1 (unquote-splicing (list 'a 'b) '(c d)) ,@(list 2)))) 275(prim-test "qq." '(1 2 3 4) (lambda () `(1 2 . ,(list 3 4)))) 276(prim-test "qq." '(a b c d) (lambda () `(,@quasi2 . ,quasi3))) 277(prim-test "qq#," '#((1 . 2) 3) (lambda () `#(,(cons 1 2) 3))) 278(prim-test "qq#," '#(99 3) (lambda () `#(,quasi0 3))) 279(prim-test "qq#," '#(100 3) (lambda () `#(,(+ quasi0 1) 3))) 280(prim-test "qq#," '#(3 101) (lambda () `#(3 ,quasi1))) 281(prim-test "qq#," '#(3 102) (lambda () `#(3 ,(+ quasi1 1)))) 282(prim-test "qq#@" '#(1 2 3 4) (lambda () `#(1 ,@(list 2 3) 4))) 283(prim-test "qq#@" '#(1 2 3 4) (lambda () `#(1 2 ,@(list 3 4)))) 284(prim-test "qq#@" '#(a b c d) (lambda () `#(,@quasi2 ,@quasi3))) 285(prim-test "qq#@" '#(a b (c d)) (lambda () `#(,@quasi2 ,quasi3))) 286(prim-test "qq#@" '#((a b) c d) (lambda () `#(,quasi2 ,@quasi3))) 287(prim-test "qq#" '#() (lambda () `#())) 288(prim-test "qq#@" '#() (lambda () `#(,@(list)))) 289 290(prim-test "qq@@" '(1 2 1 2) (lambda () `(,@(list 1 2) ,@(list 1 2)))) 291(prim-test "qq@@" '(1 2 a 1 2) (lambda () `(,@(list 1 2) a ,@(list 1 2)))) 292(prim-test "qq@@" '(a 1 2 1 2) (lambda () `(a ,@(list 1 2) ,@(list 1 2)))) 293(prim-test "qq@@" '(1 2 1 2 a) (lambda () `(,@(list 1 2) ,@(list 1 2) a))) 294(prim-test "qq@@" '(1 2 1 2 a b) (lambda () `(,@(list 1 2) ,@(list 1 2) a b))) 295(prim-test "qq@." '(1 2 1 2 . a) 296 (lambda () `(,@(list 1 2) ,@(list 1 2) . a))) 297(prim-test "qq@." '(1 2 1 2 1 . 2) 298 (lambda () `(,@(list 1 2) ,@(list 1 2) . ,(cons 1 2)))) 299(prim-test "qq@." '(1 2 1 2 a b) 300 (lambda () `(,@(list 1 2) ,@(list 1 2) . ,quasi2))) 301(prim-test "qq@." '(1 2 1 2 a 1 . 2) 302 (lambda () `(,@(list 1 2) ,@(list 1 2) a . ,(cons 1 2)))) 303(prim-test "qq@." '(1 2 1 2 a c d) 304 (lambda () `(,@(list 1 2) ,@(list 1 2) a . ,quasi3))) 305 306(prim-test "qq#@@" '#(1 2 1 2) (lambda () `#(,@(list 1 2) ,@(list 1 2)))) 307(prim-test "qq#@@" '#(1 2 a 1 2) (lambda () `#(,@(list 1 2) a ,@(list 1 2)))) 308(prim-test "qq#@@" '#(a 1 2 1 2) (lambda () `#(a ,@(list 1 2) ,@(list 1 2)))) 309(prim-test "qq#@@" '#(1 2 1 2 a) (lambda () `#(,@(list 1 2) ,@(list 1 2) a))) 310(prim-test "qq#@@" '#(1 2 1 2 a b) (lambda () `#(,@(list 1 2) ,@(list 1 2) a b))) 311 312(prim-test "qqq" '(1 `(1 ,2 ,3) 1) 313 (lambda () `(1 `(1 ,2 ,,(+ 1 2)) 1))) 314(prim-test "qqq" '(1 `(1 ,99 ,101) 1) 315 (lambda () `(1 `(1 ,,quasi0 ,,quasi1) 1))) 316(prim-test "qqq" '(1 `(1 ,@2 ,@(1 2))) 317 (lambda () `(1 `(1 ,@2 ,@,(list 1 2))))) 318(prim-test "qqq" '(1 `(1 ,@2 (unquote 1 2))) 319 (lambda () `(1 `(1 ,@2 ,,@(list 1 2))))) 320(prim-test "qqq" '(1 `(1 ,@2 (unquote-splicing 1 2))) 321 (lambda () `(1 `(1 ,@2 ,@,@(list 1 2))))) 322(prim-test "qqq" '(1 `(1 ,@(a b) ,@(c d))) 323 (lambda () `(1 `(1 ,@,quasi2 ,@,quasi3)))) 324(prim-test "qqq" '(1 `(1 ,(a b x) ,(y c d))) 325 (lambda () `(1 `(1 ,(,@quasi2 x) ,(y ,@quasi3))))) 326(prim-test "qqq#" '#(1 `(1 ,2 ,3) 1) 327 (lambda () `#(1 `(1 ,2 ,,(+ 1 2)) 1))) 328(prim-test "qqq#" '#(1 `(1 ,99 ,101) 1) 329 (lambda () `#(1 `(1 ,,quasi0 ,,quasi1) 1))) 330(prim-test "qqq#" '#(1 `(1 ,@2 ,@(1 2))) 331 (lambda () `#(1 `(1 ,@2 ,@,(list 1 2))))) 332(prim-test "qqq#" '#(1 `(1 ,@(a b) ,@(c d))) 333 (lambda () `#(1 `(1 ,@,quasi2 ,@,quasi3)))) 334(prim-test "qqq#" '#(1 `(1 ,(a b x) ,(y c d))) 335 (lambda () `#(1 `(1 ,(,@quasi2 x) ,(y ,@quasi3))))) 336(prim-test "qqq#" '(1 `#(1 ,(a b x) ,(y c d))) 337 (lambda () `(1 `#(1 ,(,@quasi2 x) ,(y ,@quasi3))))) 338 339(prim-test "qq-hygiene 0" '(2 1) 340 (lambda () (let ((quasiquote reverse)) `(list 1 2)))) 341(prim-test "qq-hygiene 1" '(,(+ 1 2)) 342 (lambda () (let ((unquote 3)) `(,(+ 1 2))))) 343(prim-test "qq-hygiene 2" '(,@(+ 1 2)) 344 (lambda () (let ((unquote-splicing 3)) `(,@(+ 1 2))))) 345 346;;---------------------------------------------------------------- 347(test-section "multiple values") 348 349(prim-test "receive" '(1 2 3) 350 (lambda () (receive (a b c) (values 1 2 3) (list a b c)))) 351(prim-test "receive" '(1 2 3) 352 (lambda () (receive (a . r) (values 1 2 3) (cons a r)))) 353(prim-test "receive" '(1 2 3) 354 (lambda () (receive x (values 1 2 3) x))) 355(prim-test "receive" 1 356 (lambda () (receive (a) 1 a))) 357(prim-test "call-with-values" '(1 2 3) 358 (lambda () (call-with-values (lambda () (values 1 2 3)) list))) 359(prim-test "call-with-values" '() 360 (lambda () (call-with-values (lambda () (values)) list))) 361 362;; This is not 'right' in R5RS sense---for now, I just tolerate it 363;; by CommonLisp way, i.e. if more than one value is passed to an 364;; implicit continuation that expects one value, the second and after 365;; values are just discarded. This behavior may be changed later, 366;; so do not count on it. The test just make sure it doesn't screw 367;; up anything. 368(prim-test "receive" '((0 0)) 369 (lambda () (receive l (list 0 (values 0 1 2)) l))) 370 371;;---------------------------------------------------------------- 372(test-section "eval") 373 374(prim-test "eval" '(1 . 2) 375 (lambda () (eval '(cons 1 2) (interaction-environment)))) 376 377(define (vector-ref x y) 'foo) 378 379(prim-test "eval" '(foo foo 3) 380 (lambda () 381 (list (vector-ref '#(3) 0) 382 (eval '(vector-ref '#(3) 0) (interaction-environment)) 383 (eval '(vector-ref '#(3) 0) (scheme-report-environment 5))))) 384 385(define vector-ref (with-module scheme vector-ref)) 386 387(prim-test "eval" #t 388 (lambda () 389 (with-error-handler 390 (lambda (e) #t) 391 (lambda () (eval '(car '(3 2)) (null-environment 5)))))) 392 393;; check interaction w/ modules 394(define-module primsyn.test (define foo 'a)) 395(define foo '(x y)) 396 397(prim-test "eval (module)" '(a b (x y)) 398 (lambda () 399 (let* ((m (find-module 'primsyn.test)) 400 (a (eval 'foo m)) 401 (b (eval '(begin (set! foo 'b) foo) m))) 402 (list a b foo)))) 403 404(prim-test "eval (module)" '(x y) 405 (lambda () 406 (with-error-handler 407 (lambda (e) foo) 408 (lambda () 409 (eval '(Apply car foo '()) (find-module 'primsyn.test)))))) 410 411;;---------------------------------------------------------------- 412(test-section "max literal arguments") 413 414;; Fix this after we have separate compile-error condition. 415(define (test-max-literal-args msg expr) 416 (prim-test (string-append "max literal arguments for " msg) 417 'caught 418 (lambda () 419 (with-error-handler (lambda (e) 'caught) 420 (lambda () (eval expr (interaction-environment))))))) 421 422(test-max-literal-args "inliner" `(list ,@(make-list 10000 #f))) 423(test-max-literal-args "global proc" `(make ,@(make-list 10000 #f))) 424(test-max-literal-args "local proc" 425 `(let ((foo (lambda x x))) 426 (foo ,@(make-list 10000 #f)))) 427 428;;---------------------------------------------------------------- 429(test-section "local procedure optimization") 430 431;; this caused an internal compiler error in 0.8.6. 432;; (found and fixed by Jun Inoue) 433(prim-test "internal-define inilining" '(1) 434 (lambda () 435 (with-error-handler 436 (lambda (e) 'ouch!) 437 (lambda () 438 (eval '(let () 439 (define (a x) x) 440 (define (b x) (a x)) 441 (define (c x) (b x)) 442 (list 1)) 443 (interaction-environment)))))) 444 445;; this caused an internal compiler error in 0.8.6 446;; (found and fixed by Kazuki Tsujimoto) 447(prim-test "multiple inlining" 0 448 (lambda () 449 (let ((f (lambda (i) (set! i 0) i))) (f (f 1))))) 450 451;; this caused an internal compiler error in 0.9.1 452(define (zero) 0) 453(prim-test "pass3 inlining with pass3/$call optimization" #t 454 (lambda () 455 (eval '((letrec ((f (lambda (a b) 456 (do ((x a (+ x 1))) 457 ((>= x b)))))) 458 f) 459 (zero) (zero)) 460 (interaction-environment)))) 461 462;; This caused internal error in 0.9.1, and infinite loop in dev version 463;; after it. 464(prim-test "pass3/$call inlining problem" #t 465 (lambda () 466 (procedure? 467 (eval '(lambda (n p t) 468 (define (y a r s f) 469 (let loop ([e 0]) 470 (cond [(a n) (unwind-protect (s) (r n))] 471 [(< e 10) (loop (+ 1 e))] 472 [else (f)]))) 473 (define (l0 a r) 474 (y a r (^() (r n)) (^() (error "oo")))) 475 ;; Main locker 476 (define (l1 a r) 477 (y a r p (^() (if (and-let* ([ t ] 478 [m (file-mtime n)]) 479 (< (+ m t) 10)) 480 (begin (l0 a r) (l1 a r)))))) 481 (error "zz")) 482 (interaction-environment))))) 483 484;;---------------------------------------------------------------- 485(test-section "optimized frames") 486 487;; Empty environment frame is omitted by compiler optimization. 488;; The following tests makes sure if it works correctly. 489 490(prim-test "lambda (empty env)" 1 491 (lambda () 492 (let* ((a 1) 493 (b (lambda () 494 ((lambda () a))))) 495 (b)))) 496 497(prim-test "let (empty env)" 1 498 (lambda () 499 (let ((a 1)) 500 (let () 501 (let () 502 a))))) 503 504(prim-test "let (empty env)" '(1 . 1) 505 (lambda () 506 (let ((a 1)) 507 (cons (let () (let () a)) 508 (let* () (letrec () a)))))) 509 510(prim-test "let (empty env)" '(3 . 1) 511 (lambda () 512 (let ((a 1) 513 (b 0)) 514 (cons (let () (let () (set! b 3)) b) 515 (let () (let () a)))))) 516 517(prim-test "named let (empty env)" 1 518 (lambda () 519 (let ((a -1)) 520 (let loop () 521 (unless (positive? a) 522 (set! a (+ a 1)) 523 (loop))) 524 a))) 525 526(prim-test "do (empty env)" 1 527 (lambda () (let ((a 0)) (do () ((positive? a) a) (set! a (+ a 1)))))) 528 529;;---------------------------------------------------------------- 530(test-section "hygienity") 531 532(prim-test "hygienity (named let)" 4 533 (lambda () 534 (let ((lambda list)) 535 (let loop ((x 0)) 536 (if (> x 3) x (loop (+ x 1))))))) 537 538(prim-test "hygienity (internal defines)" 4 539 (lambda () 540 (let ((lambda list)) 541 (define (x) 4) 542 (x)))) 543 544(prim-test "hygienity (do)" 4 545 (lambda () 546 (let ((lambda #f) 547 (begin #f) 548 (if #f) 549 (letrec #f)) 550 (do ((x 0 (+ x 1))) 551 ((> x 3) x) 552 #f)))) 553 554;;---------------------------------------------------------------- 555(test-section "letrec and letrec*") 556 557(prim-test "letrec reordering" '((1 3) . (2 3 1)) 558 (lambda () 559 (let ((r '())) 560 (cons (letrec ((a (begin (set! r (cons 1 r)) 1)) 561 (b (begin (set! r (cons 2 r)) 2)) 562 (c (begin (set! r (cons 3 r)) 3))) 563 (list a c)) 564 r)))) 565 566(prim-test "letrec* non-reordering" '((1 3) . (3 2 1)) 567 (lambda () 568 (let ((r '())) 569 (cons (letrec* ((a (begin (set! r (cons 1 r)) 1)) 570 (b (begin (set! r (cons 2 r)) 2)) 571 (c (begin (set! r (cons 3 r)) 3))) 572 (list a c)) 573 r)))) 574 575 576(test-end) 577 578