From 6d25b7ecde982b72ca7e63571af43cb9db99b959 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 18 Jun 2001 19:18:49 +0000 Subject: [PATCH] . original commit: 74267d720a902ce204564b1d6d9c5a2f0e064990 --- collects/tests/mzscheme/macrolib.ss | 139 ++++++---------------------- collects/tests/mzscheme/pconvert.ss | 13 ++- 2 files changed, 34 insertions(+), 118 deletions(-) diff --git a/collects/tests/mzscheme/macrolib.ss b/collects/tests/mzscheme/macrolib.ss index 1a7803b..30e2f1a 100644 --- a/collects/tests/mzscheme/macrolib.ss +++ b/collects/tests/mzscheme/macrolib.ss @@ -1,10 +1,9 @@ -(if (not (defined? 'SECTION)) - (load "testing.ss")) +(load-relative "loadtest.ss") (SECTION 'macrolib) -(require-library "macro.ss") +(require (lib "etc.ss")) (let ([u (letrec ([x x]) x)]) (let ([l1 @@ -25,7 +24,7 @@ [l2 (list u u u 1 1 2 1 1 2 3 5)]) (test l1 'let-plus l2))) -(require-library "shared.ss") +(require (lib "shared.ss")) (test "((car . cdr) #(one two three four five six) #&box (list1 list2 list3 list4) # 3 3)" 'shared @@ -46,7 +45,7 @@ (define x 7) (test 6 'local (local ((define x 6)) x)) (test 7 'local x) -(test 6 vector-ref (struct->vector (local ((define x 6) (define-struct a (b))) (make-a x))) 1) +(test '... vector-ref (struct->vector (local ((define x 6) (define-struct a (b))) (make-a x))) 1) (test #t 'local (local [(define o (lambda (x) (if (zero? x) #f (e (sub1 x))))) (define e (lambda (x) (if (zero? x) #t (o (sub1 x)))))] (e 10))) @@ -65,35 +64,33 @@ (test 17 'local (local [(define-values (apple b) (values 12 17))] b)) (test 4 'local (local [(define-struct cons (car cdr))] (cons-car (make-cons 4 5)))) (test 40 'local (local [(define-struct (cons struct:exn) (car cdr))] (cons-car (make-cons "" (void) 40 50)))) -(syntax-test '(local)) -(syntax-test '(local . 1)) -(syntax-test '(local ())) -(syntax-test '(local () . 1)) -(syntax-test '(local 1 1)) -(syntax-test '(local (1) 1)) -(syntax-test '(local (x) 1)) -(syntax-test '(local ((+ 1 2)) 1)) -(syntax-test '(local ((define x)) 1)) -(syntax-test '(local ((define x 4) (+ 1 2)) 1)) -(syntax-test '(local ((define x 4) (+ 1 2) (define y 10)) 1)) -(syntax-test '(local ((define (x 8) 4)) 1)) -(syntax-test '(local ((define (x . 8) 4)) 1)) -(syntax-test '(local ((define x 8 4)) 1)) -(syntax-test '(local ((define 1 8 4)) 1)) -(syntax-test '(let ([define 10]) (local ((define x 4)) 10))) -(syntax-test '(let ([define-values 10]) (local ((define-values (x) 4)) 10))) -(syntax-test '(let ([define-struct 10]) (local ((define-struct x ())) 10))) +(syntax-test #'(local)) +(syntax-test #'(local . 1)) +(syntax-test #'(local ())) +(syntax-test #'(local () . 1)) +(syntax-test #'(local 1 1)) +(syntax-test #'(local (1) 1)) +(syntax-test #'(local (x) 1)) +(syntax-test #'(local ((+ 1 2)) 1)) +(syntax-test #'(local ((define x)) 1)) +(syntax-test #'(local ((define x 4) (+ 1 2)) 1)) +(syntax-test #'(local ((define x 4) (+ 1 2) (define y 10)) 1)) +(syntax-test #'(local ((define (x 8) 4)) 1)) +(syntax-test #'(local ((define (x . 8) 4)) 1)) +(syntax-test #'(local ((define x 8 4)) 1)) +(syntax-test #'(local ((define 1 8 4)) 1)) +(syntax-test #'(let ([define 10]) (local ((define x 4)) 10))) +(syntax-test #'(let ([define-values 10]) (local ((define-values (x) 4)) 10))) +(syntax-test #'(let ([define-struct 10]) (local ((define-struct x ())) 10))) (for-each syntax-test - (list '(evcase) - '(evcase 1 (a)) - '(evcase 1 (a b) a) - '(evcase 1 (a . b) a) - '(evcase 1 [else 5] [1 10]))) + (list #'(evcase) + #'(evcase 1 (a)) + #'(evcase 1 (a b) a) + #'(evcase 1 (a . b) a) + #'(evcase 1 [else 5] [1 10]))) (define => 17) (test (void) 'void-evcase (with-handlers ([(lambda (x) #t) (lambda (x) 17)]) (evcase 1))) -(define save-comp (compile-allow-cond-fallthrough)) -(compile-allow-cond-fallthrough #f) (test #t andmap (lambda (x) (= x 17)) (list (evcase 3 [3 17]) @@ -104,92 +101,12 @@ (evcase 3 [4 4] [2 10] [else 17]) (let ([else 10]) (evcase 3 [4 4] [2 10] [else 15] [3 17])) (let ([else 3]) (evcase 3 [else 17] [2 14])) - (with-handlers ([(lambda (x) #t) (lambda (x) 17)]) (evcase 1)) + (if (eq? (void) (evcase 1)) 17 'bad) (evcase 3 [3 =>]) (evcase 3 [3 => 17]) (let ([=> 12]) (evcase 3 [3 => 17])) (let ([=> 17]) (evcase 3 [3 =>])))) -(compile-allow-cond-fallthrough save-comp) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require-library "invoke.ss") - -(define make-z - (lambda (x-val) - (unit - (import z) - (export (x z) y) - - (define x x-val) - (define y (lambda () (- z x)))))) - -(define z1 (make-z 8)) -(define z2 (make-z 7)) - -(define m3 - (compound-unit - (import) - (link [Z1 (z1 (Z2 z))][Z2 (z2 (Z1 z))]) - (export [Z1 (y y1) (z x1)][Z2 (y y2) (z x2)]))) - -(define-values/invoke-unit (y1 x1 y2 x2) m3) -(test '(-1 1 8 7) 'invoke-open-unit (list (y1) (y2) x1 x2)) - -; Linking environments - -(when (defined? 'x) - (undefine 'x)) - -(define (make--eval) - (let ([n (make-namespace)]) - (lambda (e) - (let ([orig (current-namespace)]) - (dynamic-wind - (lambda () (current-namespace n)) - (lambda () - (require-library "invoke.ss") - (eval e)) - (lambda () (current-namespace orig))))))) - -(define u - (unit - (import) - (export x) - (define x 5))) -(define e (make--eval)) -(e (list 'define-values/invoke-unit '(x) u #f)) -(test #f defined? 'x) -(test #t e '(defined? 'x)) - -(define u2 - (let ([u u]) - (unit - (import) - (export) - (global-define-values/invoke-unit (x) u #f)))) -(define e (make--eval)) -(e (list 'define-values/invoke-unit '() u2 #f)) -(test #f defined? 'x) -(test #t e '(defined? 'x)) - - -; Export var from embedded unit: - -(define-signature e ((unit w : (embedded-v)))) -(define-values/invoke-unit/sig (embedded-v) - (compound-unit/sig - (import) - (link [E : e ((compound-unit/sig - (import) - (link [w : (embedded-v) ((unit/sig (embedded-v) - (import) - (define embedded-v 0)))]) - (export (unit w))))]) - (export (var ((E w) embedded-v))))) -(test 0 'embedded-v embedded-v) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/collects/tests/mzscheme/pconvert.ss b/collects/tests/mzscheme/pconvert.ss index d282692..3c083f1 100644 --- a/collects/tests/mzscheme/pconvert.ss +++ b/collects/tests/mzscheme/pconvert.ss @@ -1,12 +1,11 @@ -(unless (defined? 'SECTION) - (load-relative "testing.ss")) +(load-relative "loadtest.ss") (SECTION 'pconvert) -(import (lib "unit.ss")) -(import (lib "class.ss")) -(import (lib "pconvert.ss")) +(require (lib "unit.ss")) +(require (lib "class.ss")) +(require (lib "pconvert.ss")) (constructor-style-printing #t) (quasi-read-style-printing #f) @@ -348,10 +347,10 @@ (test-not-shared #\a #\a) (test-not-shared 'x ''x) (test-shared (lambda (x) x) '(lambda (a1) ...)) - (test-shared (make-promise (lambda () 1)) '(delay ...)) + (test-shared (delay 1) '(delay ...)) (test-shared (class object% ()) '(class ...)) (test-shared (unit (import) (export)) '(unit ...)) - (test-shared (make-object (class object% () (sequence (super-init)))) '(make-object (class ...) ...)) + (test-shared (make-object (class object% (super-instantiate ()))) '(make-object (class ...) ...)) (test-shared "abc" "abc") (test-shared (list 1 2 3) '(list 1 2 3))