diff --git a/collects/tests/mzscheme/macrolib.ss b/collects/tests/mzscheme/macrolib.ss new file mode 100644 index 0000000..c247e6d --- /dev/null +++ b/collects/tests/mzscheme/macrolib.ss @@ -0,0 +1,72 @@ + +(if (not (defined? 'SECTION)) + (load "testing.ss")) + +(SECTION 'macrolib) + +(require-library "macro.ss") + +(let ([u (letrec ([x x]) x)]) + (let ([l1 + (let+ ([rec a a] + [recs [b c] [c b]] + [rec d 1] + [val e 1] + [val x 1] + [val y 2] + [vals (x y) (y x)] + [rec (values f) (values 1)] + [vals [(values g h) (values 2 3)]] + [val i 3] + [_ (set! i 4) + (set! i 5)]) + 'x + (list a b c d e x y f g h i))] + [l2 (list u u u 1 1 2 1 1 2 3 5)]) + (test l1 'let-plus l2))) + +(require-library "shared.ss") + +(test "((car . cdr) #(one two three four five six) #&box (list1 list2 list3 list4) # 3 3)" + 'shared + (let ([s (open-output-string)]) + (display + (shared ((a (cons 'car 'cdr)) + (b (vector 'one 'two 'three 'four 'five 'six)) + (c (box 'box)) + (d (list 'list1 'list2 'list3 'list4)) + (e (make-weak-box 'weak-box)) + (f (+ 1 2)) + (g 3)) + (list a b c d e f g)) + s) + (get-output-string s))) + +(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 #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))) +(test 'second 'local (local ((define x 10) (define u 'second)) (cons x 1) u)) +(test-values '(4 6) (lambda () (local ((define y 6) (define x 4)) (values x y)))) +(test 10 'local (let ([x 10]) (local ((define y (lambda () x))) (define x 5) (y)))) +(test 5 'local (let ([x 10]) (local ((define y (lambda () x))) (define x 5) x))) +(test 8 'local (local [(define lambda 8)] lambda)) +(test 9 'local (local [(define lambda 9) (define lambda2 lambda)] lambda2)) +(test 1 'local (local ((define-values (a b c) (values 1 2 3))) a)) +(test 1 (lambda () (local ((define-values (a b c) (values 1 2 3))) a))) +(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)) + +(report-errs) diff --git a/collects/tests/mzscheme/pconvert.ss b/collects/tests/mzscheme/pconvert.ss new file mode 100644 index 0000000..078ce91 --- /dev/null +++ b/collects/tests/mzscheme/pconvert.ss @@ -0,0 +1,261 @@ + +(unless (defined? 'SECTION) + (load-relative "testing.ss")) + +(SECTION 'pconvert) + +(require-library "pconver.ss") + +(constructor-style-printing #t) +(quasi-read-style-printing #f) + +(define (xl) 1) +(define (xu) (unit (import) (export))) +(define (xc) (class '() ())) + +(begin + (define-struct test (value constructor-sexp shared-constructor-sexp + quasi-sexp shared-quasi-sexp cons-as-list)) + + (define-struct no-cons-test (value constructor-sexp shared-constructor-sexp + quasi-sexp shared-quasi-sexp)) + (define-struct same-test (value sexp)) + (define get-value + (lambda (test-case) + (cond + [(test? test-case) + (test-value test-case)] + [(no-cons-test? test-case) + (no-cons-test-value test-case)] + [(same-test? test-case) + (same-test-value test-case)]))) + (define run-test + (lambda (test-case) + (let* ([before (get-value test-case)] + [cmp + (lambda (selector constructor-style? quasi-read? sharing? cons-as-list?) + (unless (parameterize ([constructor-style-printing constructor-style?] + [show-sharing sharing?] + [quasi-read-style-printing quasi-read?] + [abbreviate-cons-as-list cons-as-list?]) + (test (selector test-case) print-convert before)) + (printf ">> (constructor-style-printing ~a) (quasi-read-style-printing ~a) (show-sharing ~a) (abbreviate-cons-as-list ~a)~n" + constructor-style? quasi-read? sharing? cons-as-list?)))]) + ;(printf "testing: ~s~n" before) + ;(printf ".") (flush-output (current-output-port)) + (cond + [(test? test-case) + (cmp test-shared-constructor-sexp #t #f #t #t) + (cmp test-constructor-sexp #t #f #f #t) + (cmp test-shared-quasi-sexp #f #f #t #t) + (cmp test-quasi-sexp #f #f #f #t) + (cmp test-cons-as-list #t #f #f #f)] + [(no-cons-test? test-case) + (cmp no-cons-test-shared-constructor-sexp #t #f #t #t) + (cmp no-cons-test-constructor-sexp #t #f #f #t) + (cmp no-cons-test-shared-quasi-sexp #f #f #t #t) + (cmp no-cons-test-quasi-sexp #f #f #f #t)] + [(same-test? test-case) + (cmp same-test-sexp #t #t #t #t) + (cmp same-test-sexp #t #t #t #f) + (cmp same-test-sexp #t #t #f #t) + (cmp same-test-sexp #t #t #f #f) + (cmp same-test-sexp #t #f #t #t) + (cmp same-test-sexp #t #f #t #f) + (cmp same-test-sexp #t #f #f #t) + (cmp same-test-sexp #t #f #f #f) + (cmp same-test-sexp #f #t #t #t) + (cmp same-test-sexp #f #t #t #f) + (cmp same-test-sexp #f #t #f #t) + (cmp same-test-sexp #f #t #f #f) + (cmp same-test-sexp #f #f #t #t) + (cmp same-test-sexp #f #f #t #f) + (cmp same-test-sexp #f #f #f #t) + (cmp same-test-sexp #f #f #f #f)])))) + + (define + tests + (list + (make-same-test "abc" "abc") + (make-same-test 8 8) + (make-same-test 'a ''a) + (make-test (list 1) '(list 1) '(list 1) '`(1) '`(1) '(cons 1 null)) + (make-same-test (vector 0 0 0 0 0 0 0 0 0 0) '(vector 0 0 0 0 0 0 0 0 0 0)) + (make-same-test (delay 1) '(delay ...)) + (make-same-test (let-struct a (a) (make-a 3)) '(make-a 3)) + (make-same-test (box 3) '(box 3)) + (make-test null 'null 'null '`() '`() 'null) + (make-same-test add1 'add1) + (make-same-test (void) '(void)) + (make-same-test (unit (import) (export)) '(unit ...)) + (make-same-test (make-weak-box 12) '(make-weak-box 12)) + (make-same-test (regexp "1") '(regexp ...)) + (make-same-test (lambda () 0) '(lambda () ...)) + (make-same-test xl 'xl) + (make-same-test (letrec ([xl (lambda () 1)]) xl) '(lambda () ...)) + (make-same-test (letrec ([xl-ID-BETTER-NOT-BE-DEFINED (lambda () 1)]) + xl-ID-BETTER-NOT-BE-DEFINED) + '(lambda () ...)) + (make-same-test xc 'xc) + (make-same-test (letrec ([xc (class '() ())]) xc) '(class ...)) + (make-same-test (letrec ([xc-ID-BETTER-NOT-BE-DEFINED (class '() ())]) + xc-ID-BETTER-NOT-BE-DEFINED) + '(class ...)) + (make-same-test xu 'xu) + (make-same-test (letrec ([xu (unit (import) (export))]) xu) + '(unit ...)) + (make-same-test (letrec ([xu-ID-BETTER-NOT-BE-DEFINED (unit (import) (export))]) + xu-ID-BETTER-NOT-BE-DEFINED) + '(unit ...)) + (make-same-test (lambda (x) x) '(lambda (a1) ...)) + (make-same-test (lambda x x) '(lambda args ...)) + (make-same-test (lambda (a b . c) a) '(lambda (a1 a2 . args) ...)) + (make-same-test (case-lambda) '(case-lambda)) + (make-same-test (case-lambda [() a] [(x) a]) '(case-lambda [() ...] [(a1) ...])) + (make-same-test (case-lambda [() a] [(x y) a]) + '(case-lambda [() ...] [(a1 a2) ...])) + (make-same-test (case-lambda [() a] [(x . y) a]) + '(case-lambda [() ...] [(a1 . args) ...])) + (make-same-test (case-lambda [() a] [x a]) + '(case-lambda [() ...] [args ...])) + (make-same-test (case-lambda [() a] [(x y z) a] [x a]) + '(case-lambda [() ...] [(a1 a2 a3) ...] [args ...])) + (make-same-test (let ([ht (make-hash-table)]) + (hash-table-put! ht 'x 1) + ht) + '(make-hash-table)) + (make-test (list 'a (box (list ())) (cons 1 '())) + '(list (quote a) (box (list null)) (list 1)) + '(list (quote a) (box (list null)) (list 1)) + '`(a ,(box `(())) (1)) + '`(a ,(box `(())) (1)) + '(cons 'a + (cons (box (cons null null)) + (cons (cons 1 null) + null)))) + (make-test (let ([x (list 1)]) (set-car! x x) x) + '(shared ([-0- (list -0-)]) -0-) + '(shared ([-0- (list -0-)]) -0-) + '(shared ([-0- `(,-0-)]) -0-) + '(shared ([-0- `(,-0-)]) -0-) + '(shared ([-0- (cons -0- null)]) -0-)) + (make-test (let ([x (list 1)]) (set-cdr! x x) x) + '(shared ([-0- (cons 1 -0-)]) -0-) + '(shared ([-0- (cons 1 -0-)]) -0-) + '(shared ([-0- `(1 . ,-0-)]) -0-) + '(shared ([-0- `(1 . ,-0-)]) -0-) + '(shared ([-0- (cons 1 -0-)]) -0-)) + (make-test (let* ([a (list 1 2 3)] + [b (list 1 a (cdr a))]) + (set-car! b b) + (append b (list (list 2 3)))) + '(shared ([-1- (list -1- (list 1 2 3) (list 2 3))]) + (list -1- (list 1 2 3) (list 2 3) (list 2 3))) + '(shared ([-1- (list -1- -3- -4-)] + [-3- (cons 1 -4-)] + [-4- (list 2 3)]) + (list -1- -3- -4- (list 2 3))) + '(shared ([-1- `(,-1- (1 2 3) (2 3))]) + `(,-1- (1 2 3) (2 3) (2 3))) + '(shared ([-1- `(,-1- ,-3- ,-4-)] + [-3- `(1 . ,-4-)] + [-4- `(2 3)]) + `(,-1- ,-3- ,-4- (2 3))) + '(shared ([-1- (cons -1- + (cons (cons 1 (cons 2 (cons 3 null))) + (cons (cons 2 (cons 3 null)) + null)))]) + (cons -1- + (cons (cons 1 (cons 2 (cons 3 null))) + (cons (cons 2 (cons 3 null)) + (cons (cons 2 (cons 3 null)) + null)))))) + (make-no-cons-test (let* ([a (list 1 2 3)] + [b (list 1 a (cdr a))]) + (set-car! b b) + (let* ([share-list (append b (list (list 2 3)))] + [v (vector 1 share-list (cdr share-list))]) + (vector-set! v 0 v) + v)) + '(shared + ((-0- (vector -0- + (list -2- + (list 1 2 3) + (list 2 3) + (list 2 3)) + (list (list 1 2 3) + (list 2 3) + (list 2 3)))) + (-2- (list -2- (list 1 2 3) (list 2 3)))) + -0-) + '(shared + ((-0- (vector -0- (cons -2- -8-) -8-)) + (-2- (list -2- -4- -5-)) + (-4- (cons 1 -5-)) + (-5- (list 2 3)) + (-8- (list -4- -5- (list 2 3)))) + -0-) + '(shared + ((-0- (vector -0- + `(,-2- + (1 2 3) + (2 3) + (2 3)) + `((1 2 3) + (2 3) + (2 3)))) + (-2- `(,-2- (1 2 3) (2 3)))) + -0-) + '(shared + ((-0- (vector -0- `(,-2- . ,-8-) -8-)) + (-2- `(,-2- ,-4- ,-5-)) + (-4- `(1 . ,-5-)) + (-5- `(2 3)) + (-8- `(,-4- ,-5- (2 3)))) + -0-)))) + (for-each run-test tests)) + +(begin + (define make-test-shared + (lambda (shared?) + (lambda (object output) + (parameterize ([constructor-style-printing #t] + [show-sharing #t] + [quasi-read-style-printing #f] + [abbreviate-cons-as-list #t]) + (test (if shared? + `(shared ((-1- ,output)) + (list -1- -1-)) + `(list ,output ,output)) + print-convert + (list object object)))))) + (define test-shared (make-test-shared #t)) + (define test-not-shared (make-test-shared #f)) + + (test-not-shared #t #t) + (test-not-shared #f #f) + (test-not-shared 1 1) + (test-not-shared 3276832768 3276832768) + (test-not-shared (regexp "") '(regexp ...)) + (let ([in (open-input-string "")]) (test-not-shared in in)) + (let ([out (open-output-string)]) (test-not-shared out out)) + (test-not-shared #\a #\a) + (test-not-shared 'x ''x) + (test-not-shared (lambda (x) x) '(lambda (a1) ...)) + (test-not-shared (make-promise (lambda () 1)) '(delay ...)) + (test-not-shared (class () ()) '(class ...)) + (test-not-shared (unit (import) (export)) '(unit ...)) + (test-not-shared (make-object (class () ())) '(make-object (class ...))) + + (test-shared "abc" "abc") + (test-shared (list 1 2 3) '(list 1 2 3)) + (test-shared (vector 1 2 3) '(vector 1 2 3)) + (let-struct a () (test-shared (make-a) '(make-a))) + (test-shared (box 1) '(box 1)) + (test-shared (make-hash-table) '(make-hash-table))) + +(arity-test print-convert 1 2) +(arity-test build-share 1 1) +(arity-test get-shared 1 2) +(arity-test print-convert-expr 3 3) +(report-errs) diff --git a/collects/tests/mzscheme/uinc.ss b/collects/tests/mzscheme/uinc.ss new file mode 100644 index 0000000..ea489aa --- /dev/null +++ b/collects/tests/mzscheme/uinc.ss @@ -0,0 +1,2 @@ + +(+ 4 5) diff --git a/collects/tests/mzscheme/uinc2.ss b/collects/tests/mzscheme/uinc2.ss new file mode 100644 index 0000000..c1de73f --- /dev/null +++ b/collects/tests/mzscheme/uinc2.ss @@ -0,0 +1,2 @@ + +(define x 8) diff --git a/collects/tests/mzscheme/unit.ss b/collects/tests/mzscheme/unit.ss new file mode 100644 index 0000000..6c4febf --- /dev/null +++ b/collects/tests/mzscheme/unit.ss @@ -0,0 +1,383 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'unit) + +(syntax-test '(unit)) +(syntax-test '(unit (import))) +(syntax-test '(unit (impLort))) +(syntax-test '(unit (impLort) (export) 5)) +(syntax-test '(unit (import) (expLort) 5)) +(syntax-test '(unit import (export) 5)) +(syntax-test '(unit (import) export 5)) +(syntax-test '(unit (import) (export) . 5)) +(syntax-test '(unit (import 8) (export) 5)) +(syntax-test '(unit (import . i) (export) 5)) +(syntax-test '(unit (import (i)) (export) 5)) +(syntax-test '(unit (import i 8) (export) 5)) +(syntax-test '(unit (import i . b) (export) 5)) +(syntax-test '(unit (import i (b)) (export) 5)) +(syntax-test '(unit (import i) (export 7) 5)) +(syntax-test '(unit (import i) (export . a) (define a 6))) +(syntax-test '(unit (import i) (export a . b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a x) . b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a 8) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export b (a 8)) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a . x) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export b (a . x)) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a x y) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a x . y) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export b (a x . y)) (define a 5) (define b 6))) + +(syntax-test '(unit (import i) (export) (begin))) +(syntax-test '(unit (import i) (export) (begin 1 . 2))) +(syntax-test '(unit (import i) (export b a) (begin (define a 5) (define b 6) . x))) +(syntax-test '(unit (import i) (export b a) (begin (define a 5) (define b 6)) (define b 6))) + +(syntax-test '(unit (import #%car) (export) (define a 5))) +(syntax-test '(unit (import) (export #%car) (define a 5))) +(syntax-test '(unit (import) (export #%car) (define #%car 5))) +(syntax-test '(unit (import) (export) (define #%car 5))) +(syntax-test '(unit (import) (export) (define-values (3) 5))) + +(syntax-test '(unit (import a) (export (a x) b) (define a 5) (define b 6))) +(syntax-test '(unit (import a) (export (a x) (a y)) (define a 5) (define b 6))) +(syntax-test '(unit (import i a) (export (a x) b) (define a 5) (define b 6))) +(syntax-test '(unit (import b) (export (a x) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i j i) (export (a x) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i j j) (export (a x) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export a a) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a x) (b x)) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a x) b) (define a 5) (define a 6) (define b 6))) +(syntax-test '(unit (import make-i) (export (a x) b) (define a 5) (define-struct i ()) (define b 6))) +(syntax-test '(unit (import i) (export (make-a x) b) (define make-a 5) (define-struct a ()) (define b 6))) +(syntax-test '(unit (import i) (export (a x) b) (define a 5) (define r 6) (define r 7) (define b 6))) + +(syntax-test '(unit (import i) (export b (a x)) 5)) +(syntax-test '(unit (import i) (export (a x) b) (define x 5) (define b 6))) +(syntax-test '(unit (import i) (export (a x) b) (set! a 5) (define b 6))) + +(syntax-test '(compound-unit (import) (link (A (0 (A)))) (export))) ; self-import +(syntax-test '(compound-unit (import) (link (A (0 (A x)))) (export))) ; self-import + +(unless (defined? 'test-global-var) + (define test-global-var 5) + (syntax-test '(unit (import) (export) test-global-var)) + (constant-name 'test-global-var) + (syntax-test '(unit (import) (export) test-global-var))) + +(test #t unit? (unit (import) (export))) +(test #t unit? (unit (import) (export) 5)) +(test #t unit? (unit (import i) (export (a x)) (define a 8) (define x 5))) +(test 5 (lambda (f) (invoke-unit f)) (unit (import) (export) 5)) + +(test #t unit? (unit (import i) (export b a) (begin (define a 5) (define b 6)))) +(test #t unit? (unit (import i) (export b a) 'a (begin (define a 5) (define b 6)) 'b)) +(test #t unit? (unit (import i) (export b a) (begin (define a 5)) (define b 6))) +(test #t unit? (unit (import i) (export b a) (define a 5) (begin (define b 6)))) +(test #t unit? (unit (import i) (export b a) (define a 5) (begin (define y 7) (define b 6)) (+ y b a))) + +(test 3 'embedded-deeply ((invoke-unit (unit (import) (export) (lambda () (define x 3) x))))) +(test 1 'embedded-deeply-struct ((invoke-unit (unit (import) (export) (lambda () + (define-struct a ()) + make-a + 1))))) +(syntax-test '(compound-unit)) +(syntax-test '(compound-unit . x)) +(syntax-test '(compound-unit (import))) +(syntax-test '(compound-unit (import) . x)) +(syntax-test '(compound-unit (import) (link))) +(syntax-test '(compound-unit (import) (link) . x)) +(syntax-test '(compound-unit import (link) (export))) +(syntax-test '(compound-unit (import) link (export))) +(syntax-test '(compound-unit (import) (link) export)) +(syntax-test '(compound-unit ((import)) (link) (export))) +(syntax-test '(compound-unit (import) ((link)) (export))) +(syntax-test '(compound-unit (import) (link) ((export)))) +(syntax-test '(compound-unit (import . a) (link) (export))) +(syntax-test '(compound-unit (import b . a) (link) (export))) +(syntax-test '(compound-unit (import 1) (link) (export))) +(syntax-test '(compound-unit (import (a)) (link) (export))) +(syntax-test '(compound-unit (import (a . b)) (link) (export))) +(syntax-test '(compound-unit (import (a (b))) (link) (export))) +(syntax-test '(compound-unit (import ((a) b)) (link) (export))) +(syntax-test '(compound-unit (import) (link . a) (export))) +(syntax-test '(compound-unit (import) (link a) (export))) +(syntax-test '(compound-unit (import) (link (a)) (export))) +(syntax-test '(compound-unit (import) (link (a (b)) . c) (export))) +(syntax-test '(compound-unit (import) (link (a (b) . c)) (export))) +(syntax-test '(compound-unit (import) (link (a (b . c)) (c (d))) (export))) +(syntax-test '(compound-unit (import) (link (a (b c . e)) (c (d)) (e (f))) (export))) +(syntax-test '(compound-unit (import) (link (a (b 1))) (export))) +(syntax-test '(compound-unit (import) (link (a (b))) (export . a))) +(syntax-test '(compound-unit (import) (link (a (b))) (export a))) +(syntax-test '(compound-unit (import) (link (a (b))) (export (a w) . a))) +(syntax-test '(compound-unit (import) (link (a (b))) (export (a 1)))) +(syntax-test '(compound-unit (import) (link (a (b))) (export (a (x))))) +(syntax-test '(compound-unit (import) (link (a (b))) (export (1 w)))) + + +; Simple: + +(define m1 + (unit + (import) + (export x y a? set-a-b!) + + (define-struct a (b c)) + + (define x 7) + (define z 8) + (define y (lambda () (* z x))) + + (list x y z))) + +(test #t apply (lambda (x y z) (and (= x 7) (= z 8) (procedure? y) (= 0 (arity y)))) + (invoke-unit m1)) + +(test #t apply + (lambda (x y-val a? set-a-b!) + (and (= x 7) (= y-val 56) + (= 1 (arity a?)) + (= 2 (arity set-a-b!)))) + (invoke-unit + (compound-unit + (import) + (link [M (m1)] + [N ((unit + (import x y a? set-a-b!) + (export) + (list x (y) a? set-a-b!)) + (M x y a? set-a-b!))]) + (export)))) + +; Structures: + + +(define m2-1 + (unit + (import) + (export x struct:a a? v y) + + (define x 5) + (define-struct a (b c)) + (define v (make-a 5 6)) + (define (y v) (a? v)))) + +(define m2-2 + (unit + (import struct:a a?) + (export x? make-x x-z both) + + (define-struct (x struct:a) (y z)) + (define both (lambda (v) + (and (a? v) (x? v)))))) + +(define m2-3 + (compound-unit + (import) + (link [O (m2-1)][T (m2-2 (O struct:a) (O a?))]) + (export [O x struct:a v y] + [T x? make-x x-z both]))) + + +(let ([p (open-output-string)]) + (invoke-unit + (compound-unit + (import) + (link [M (m2-3)] + [N ((unit + (import x v struct:a y x? make-x x-z both) + (export) + (define (filter v) + (if (procedure? v) + `(proc: ,(inferred-name v)) + v)) + (display + (map filter (list x v struct:a y make-x x? x-z both)) + p) + (let ([v2 (make-x 1 2 3 4)]) + (display (map filter + (list x (struct-type? struct:a) + v (y v) (y x) + v2 + (y v2) + (x? v2) + (both v) + (both v2))) + p))) + (M x v struct:a y x? make-x x-z both))]) + (export))) + + (test (string-append "(5 #(struct:a 5 6) # (proc: y)" + " (proc: make-x) (proc: x?)" + " (proc: x-z) (proc: both))" + "(5 #t #(struct:a 5 6) #t #f #(struct:x 1 2 3 4) #t #t #f #t)") + get-output-string p)) + +; Compound with circularity + +(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)]))) + +(invoke-open-unit m3) +(test '(-1 1 8 7) 'invoke-open-unit (list (y1) (y2) x1 x2)) + +; Dynamic linking + +(let ([u + (unit + (import x) + (export) + + (+ x 8))]) + + (test 10 'dynamic (invoke-unit + (unit + (import) + (export w) + + (define w 2) + + (invoke-unit u w))))) + +; Linking environemtns + +(if (defined? 'x) + (undefine 'x)) + +(define (make--eval) + (let ([n (make-namespace)]) + (lambda (e) + (let ([orig (current-namespace)]) + (dynamic-wind + (lambda () (current-namespace n)) + (lambda () (eval e)) + (lambda () (current-namespace orig))))))) + +(define u + (unit + (import) + (export x) + (define x 5))) +(define e (make--eval)) +(e (list 'invoke-open-unit u #f)) +(test #f defined? 'x) +(test #t e '(defined? 'x)) + +(define u2 + (let ([u u]) + (unit + (import) + (export) + (invoke-open-unit u #f)))) +(define e (make--eval)) +(e (list 'invoke-open-unit u2 #f)) +(test #f defined? 'x) +(test #t e '(defined? 'x)) + + +; Misc + +(test 12 'nested-units + (invoke-unit + (compound-unit + (import) + (link (a@ ((unit (import) (export s@:a) (define s@:a 5)))) + (u@ ((compound-unit + (import a@:s@:a) + (link (r@ ((unit (import a) (export) (+ a 7)) a@:s@:a))) + (export)) + (a@ s@:a)))) + (export)))) + +; Import linking via invoke-unit + +(test '(5 7 (7 2)) 'invoke-unit-linking + (let ([u (unit (import x) (export) x)] + [v (unit (import x) (export) (lambda () x))] + [x 5]) + (list (invoke-unit u x) + (begin + (set! x 7) + (invoke-unit u x)) + (let ([f (invoke-unit v x)]) + (list + (f) + (begin + (set! x 2) + (f))))))) + +; Shadowed syntax definitions: + +(test 8 'unit (invoke-unit (unit (import) (export) (define lambda 8) lambda))) +(test 9 'unit (invoke-unit (unit (import) (export) (begin (define lambda 9) (define lambda2 lambda)) lambda2))) + +; Multiple values +(test '(1 2 3) + call-with-values + (lambda () (invoke-unit (unit (import) (export) (values 1 2 3)))) + list) + +; Units within units: + +(define u (unit + (import) + (export) + (define y 10) + (define x 5) + (unit + (import) + (export) + x))) +(test #t unit? u) +(define u2 (invoke-unit u)) +(test #t unit? u2) +(test 5 'invoke-unit-in-unit (invoke-unit u2)) + +; Units and objects combined: + +(define u@ + (unit (import x) (export) + (class* () () () (public (y x))))) +(define v (invoke-unit u@ car)) +(test #t class? v) +(define w (make-object v)) +(test car 'ivar (ivar w y)) + +(define c% + (class* () () (x) + (public (z (unit (import) (export) x))))) +(define u (ivar (make-object c% car) z)) +(test #t unit? u) +(test car 'invoke (invoke-unit u)) + + +(define c% + (class* () () (x) (public (y x)) + (public (z (unit (import) (export) y))))) +(define u (make-object c% 3)) +(define u2 (ivar u z)) +(test #t unit? u2) +(test 3 'invoke (invoke-unit u2)) + +(test (letrec* ([x y][y 0]) x) 'invoke + (invoke-unit (unit (import) (export) (define x y) (define y 7) x))) + +(report-errs) diff --git a/collects/tests/mzscheme/unitsig.ss b/collects/tests/mzscheme/unitsig.ss new file mode 100644 index 0000000..81d9be9 --- /dev/null +++ b/collects/tests/mzscheme/unitsig.ss @@ -0,0 +1,441 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'unit/sig) + +(undefine 'a) +(undefine 'b) + +(syntax-test '(define-signature)) +(syntax-test '(define-signature)) +(syntax-test '(define-signature 8)) +(syntax-test '(define-signature . x)) +(syntax-test '(define-signature x)) +(syntax-test '(define-signature 8)) +(syntax-test '(define-signature x (8))) +(syntax-test '(define-signature x (a . 8))) +(syntax-test '(define-signature x (a . y))) +(syntax-test '(define-signature x (y y))) +(syntax-test '(define-signature x ((y)))) +(syntax-test '(define-signature x ((struct)))) +(syntax-test '(define-signature x ((struct y)))) +(syntax-test '(define-signature x ((struct . y)))) +(syntax-test '(define-signature x ((struct y . x)))) +(syntax-test '(define-signature x ((struct y x)))) +(syntax-test '(define-signature x ((struct y (x)) . x))) +(syntax-test '(define-signature x ((unit)))) +(syntax-test '(define-signature x ((unit y)))) +(syntax-test '(define-signature x ((unit . y)))) +(syntax-test '(define-signature x ((unit y : a)))) +(define-signature a ()) +(syntax-test '(define-signature x ((unit y a)))) +(syntax-test '(define-signature x ((unit y . a)))) +(syntax-test '(define-signature x ((unit y : . a)))) +(syntax-test '(define-signature x ((unit y a) . x))) +(syntax-test '(define-signature x (y (unit y a)))) + +(syntax-test '(unit/sig)) +(syntax-test '(unit/sig 8)) +(syntax-test '(unit/sig b)) +(define-signature b (x y)) +(syntax-test '(unit/sig (a))) +(syntax-test '(unit/sig a (impLort))) +(syntax-test '(unit/sig a (impLort) 5)) +(syntax-test '(unit/sig a import 5)) +(syntax-test '(unit/sig a (import . x) . 5)) +(syntax-test '(unit/sig a (import (x) 8) 5)) +(syntax-test '(unit/sig a (import (x) . i) 5)) +(syntax-test '(unit/sig a (import (i : a) . b) 5)) +(syntax-test '(unit/sig b (import (i : a)) 5)) +(syntax-test '(unit/sig a (import (i : a x)) 5)) +(syntax-test '(unit/sig a (import (i : a) x) 5)) +(syntax-test '(unit/sig b (import (i : a)) (define x 7))) +(syntax-test '(unit/sig b (import (i : a)) (define x 7) (define i:y 6))) +(syntax-test '(unit/sig blah (import) (define x 7))) + +(syntax-test '(unit/sig () (import) (begin))) +(syntax-test '(unit/sig () (import) (begin 1 . 2))) +(syntax-test '(unit/sig () (import) (begin (define x 5)) (define x 5))) + +(define b@ (unit/sig b (import) (define x 9) (define y 9))) +(define b2@ (unit/sig b (import (i : a)) (define x 9) (define y 9))) +(define b3@ (unit/sig b (import (i : ())) (define x 9) (define y 9))) +(define b3u@ (unit/sig b (import ()) (define x 9) (define y 9))) +(define b3u2@ (unit/sig b (import a) (define x 9) (define y 9))) +(define-signature >b ((unit b@ : b))) +(define b3u3@ (unit/sig b (import (i : >b)) (define x 9) (define y 9))) + +(define >b@ (compound-unit/sig (import) (link [b@ : b (b@)]) (export (unit b@)))) + +(syntax-test '(compound-unit/sig)) +(syntax-test '(compound-unit/sig 8)) +(syntax-test '(compound-unit/sig b)) +(syntax-test '(compound-unit/sig (import) (link) (export (var (U x))))) +(syntax-test '(compound-unit/sig (import a) (link) (export))) +(syntax-test '(compound-unit/sig (import 5) (link) (export))) +(syntax-test '(compound-unit/sig (import . i) (link) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link ()) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@)) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ b)) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b)) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b ())) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ 5))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ . i))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i . a)))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i a a)))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ c@))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (c@ a)))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export . b@))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export b@))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit)))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit c@)))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : c)))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ (b@))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : (b@))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var)))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open)))) +(error-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i : a)))) (export)) exn:unit:signature:arity?) +(error-test '(compound-unit/sig (import (i : a)) (link (b@ : b (5 (i : a)))) (export)) exn:unit:signature:non-signed-unit?) +(error-test '(compound-unit/sig (import (i : b)) (link (b@ : b (b3@ (i : b)))) (export)) exn:unit:signature:match:extra?) +(error-test '(compound-unit/sig (import (i : b)) (link (b@ : b (b3u@ (i : b)))) (export)) exn:unit:signature:match:extra?) +(error-test '(compound-unit/sig (import (i : b)) (link (b@ : b (b3u2@ (i : b)))) (export)) exn:unit:signature:match:extra?) +(error-test '(compound-unit/sig (import (i : >b)) (link (b@ : b (b3@ (i : >b)))) (export)) exn:unit:signature:match:extra?) +(error-test '(compound-unit/sig (import (i : ((open a) x))) (link (b@ : b (b3@ (i : ((open a) x))))) (export)) exn:unit:signature:match:extra?) +(error-test '(compound-unit/sig (import (i : ((unit b@ : ((open b) w))))) (link (b@ : b (b3u3@ i))) (export)) exn:unit:signature:match:extra?) +(error-test '(compound-unit/sig (import (i : a)) (link (b@ : (w) (b@))) (export)) exn:unit:signature:match:missing?) +(error-test '(compound-unit/sig (import (i : ())) (link (b@ : b (b3u3@ i))) (export)) exn:unit:signature:match:missing?) +(error-test '(compound-unit/sig (import (i : ((unit b@ : ())))) (link (b@ : b (b3u3@ i))) (export)) exn:unit:signature:match:missing?) +(error-test '(compound-unit/sig (import (i : (b@))) (link (b@ : b (b3u3@ i))) (export)) exn:unit:signature:match:kind?) +(error-test '(compound-unit/sig (import (i : ((unit b@ : (x (unit y : ())))))) (link (b@ : b (b3u3@ i))) (export)) exn:unit:signature:match:kind?) +(syntax-test '(compound-unit/sig (import) (link [b@ : b (0 5)]) (export))) +(syntax-test '(compound-unit/sig (import) (link [b@ : b (0 ())]) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : a (5 (i : b)))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var b@)))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x y))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (5 x))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ 5))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@ w) 5))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@ 7) 5))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x . a))))) + +(syntax-test '(compound-unit/sig (import) (link (A : () (0 A))) (export))) ; self-import +(syntax-test '(compound-unit/sig (import) (link (A : (x) (0 A))) (export))) ; self-import + +(test #t unit/sig? (unit/sig a (import))) +(test #t unit/sig? (unit/sig b (import) (define x 1) (define y 2))) +(test #t unit/sig? (unit/sig a (import (i : b)) i:x)) +(test 5 (lambda (f) (invoke-unit/sig f ())) (unit/sig a (import ()) 5)) +(test #t unit/sig? (unit/sig (x) (import) (begin (define x 5)))) +(test #t unit/sig? (unit/sig (x) (import) (define a 14) (begin (define x 5) (define y 10)) (define z 12))) +(test #t unit/sig? (compound-unit/sig (import) (link) (export))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b2@ (i : a)))) (export))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b2@ ((i) : a)))) (export))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b2@ ((i) : ())))) (export))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x))))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x) w)))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@) x) w)))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@)))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit (b@))))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ b@)))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open b@)))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open (b@ : b))))) + +; Include: + +(define i1@ + (unit/sig + () + (import) + + (include "uinc.ss"))) + +(test 9 'include (invoke-unit/sig i1@)) + +(define i2@ + (unit/sig + () + (import) + + (include "uinc.ss") + (include "uinc2.ss") + (include "uinc.ss") + (+ x 2))) + +(test 10 'include (invoke-unit/sig i2@)) + +; Simple: + +(define-signature m1^ + (x y a? set-a-b!)) + +(define m1@ + (unit/sig + m1^ + (import) + + (define-struct a (b c)) + + (define x 7) + (define z 8) + (define y (lambda () (* z x))) + + (list x y z))) + +(test #t apply (lambda (x y z) (and (= x 7) (= z 8) (procedure? y) (= 0 (arity y)))) + (invoke-unit/sig m1@)) + +(test #t apply + (lambda (x y-val a? set-a-b!) + (and (= x 7) (= y-val 56) + (= 1 (arity a?)) + (= 2 (arity set-a-b!)))) + (invoke-unit/sig + (compound-unit/sig + (import) + (link [M@ : m1^ (m1@)] + [N@ : () ((unit/sig + () + (import (i@ : m1^)) + (list i@:x (i@:y) i@:a? i@:set-a-b!)) + M@)]) + (export (open M@))))) + +; More: + +(define-signature m2-1-lite^ + (x struct:a v y)) + +(define-signature m2-1^ + (a? + (open m2-1-lite^))) + +(define-signature m2-2^ + (x? make-x x-z both)) + +(define m2-1@ + (unit/sig + m2-1^ + (import) + + (define x 5) + (define-struct a (b c)) + (define v (make-a 5 6)) + (define (y v) (a? v)))) + +(define m2-2@ + (unit/sig + m2-2^ + (import m2-1^) + + (define-struct (x struct:a) (y z)) + (define both (lambda (v) + (and (a? v) (x? v)))))) + +(define-signature m2-3^ + (simple)) + +(let-signature m2-3^ + ((unit one@ : m2-1-lite^) + (unit two@ : m2-2^) + a?-again) + + (define m2-3@ + (compound-unit/sig + + (import) + (link [O@ : m2-1^ (m2-1@)] + [T@ : m2-2^ (m2-2@ O@)]) + (export (unit (O@ : m2-1-lite^) one@) + (unit T@ two@) + (var (O@ a?) a?-again)))) + + (let ([p (open-output-string)] + [filter (lambda (v) + (if (procedure? v) + `(proc: ,(inferred-name v)) + v))]) + (invoke-unit/sig + (compound-unit/sig + (import) + (link [M@ : m2-3^ (m2-3@)] + [N@ : () ((unit/sig + () + (import (i : m2-3^)) + (display (map + filter + (list i:one@:x i:one@:v i:one@:struct:a i:one@:y + i:two@:make-x i:two@:x? i:two@:x-z i:two@:both + i:a?-again)) + p) + (let ([v2 (i:two@:make-x 1 2 3 4)]) + (display (map + filter + (list i:one@:x (struct-type? i:one@:struct:a) + i:one@:v (i:one@:y i:one@:v) (i:one@:y i:one@:x) + v2 + (i:one@:y v2) + (i:two@:x? v2) + (i:two@:both i:one@:v) + (i:two@:both v2))) + p))) + M@)]) + (export))) + (test (string-append "(5 #(struct:a 5 6) # (proc: y)" + " (proc: make-x) (proc: x?)" + " (proc: x-z) (proc: both) (proc: a?))" + "(5 #t #(struct:a 5 6) #t #f #(struct:x 1 2 3 4) #t #t #f #t)") + get-output-string p))) + +(test 5 'let-sig + (invoke-unit/sig + (unit/sig + m2-3^ + (import) + (define simple 5) + simple))) + +(define-signature big^ + (a b c)) +(define-signature little^ + (a b c)) + +(test 11 + 'link-restrict + (invoke-unit/sig + (compound-unit/sig + (import) + (link [a@ : big^ ((unit/sig big^ (import) (define a 5) (define b 6) (define c 7)))] + [b@ : () ((unit/sig () (import (i : little^)) (+ i:a i:b)) + (a@ : little^))]) + (export)))) + +(define-signature just-a^ + (a)) +(define-signature >just-a^ + ((unit s@ : just-a^))) + +; Test a path for linking: root is a constiuent +(test 12 + 'link-path + (invoke-unit/sig + (compound-unit/sig + (import) + (link [a@ : >just-a^ ((compound-unit/sig + (import) + (link [i@ : just-a^ ((unit/sig + just-a^ + (import) + (define a 5)))]) + (export (unit i@ s@))))] + [r@ : () ((unit/sig + () + (import (i : just-a^)) + (+ i:a 7)) + (a@ s@))]) + (export)))) + +; Test a path for linking: root is an import +(test 12 + 'import-path + (invoke-unit/sig + (compound-unit/sig + (import) + (link [a@ : >just-a^ ((compound-unit/sig + (import) + (link [i@ : just-a^ ((unit/sig + just-a^ + (import) + (define a 5)))]) + (export (unit i@ s@))))] + [u@ : () ((compound-unit/sig + (import (a@ : >just-a^)) + (link [r@ : () ((unit/sig + () + (import (i : just-a^)) + (+ i:a 7)) + (a@ s@))]) + (export)) + a@)]) + (export)))) + +; Export var from embedded unit: + +(define-signature e ((unit w : (embedded-v)))) +(invoke-open-unit/sig + (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) + +; Signature ordering + +(define o1 (unit/sig (num sym) (import) (define num 5) (define sym 'a))) +(define o2 (unit/sig () (import (sym num)) (list sym (+ num)))) + +(test (list 'a 5) + 'order + (invoke-unit/sig + (compound-unit/sig + (import) + (link [one : (num sym) (o1)] + [two : () (o2 one)]) + (export)))) + +; unit->unit/sig, etc. + +(define-signature s1 + (a b c)) +(define-signature s2 + (+)) + +(define us1 + (unit + (import +) + (export a b c) + + (define a 1) + (define b 2) + (define c 3) + (+ a b c))) + +(test 6 'u->s (invoke-unit us1 +)) +(test 6 'u->s (invoke-unit/sig (unit->unit/sig us1 (s2) s1) s2)) + +; Exporting a name twice: + +(syntax-test + '(compound-unit/sig + (import) + (link [A : (a) ((unit/sig (a) (import) (define a 1)))]) + (export (var (A a)) (open A)))) + +(syntax-test + '(compound-unit/sig + (import) + (link [A : (a) ((unit/sig (a) (import) (define a 1)))] + [B : (b) ((unit/sig (b) (import) (define b 2)))]) + (export (unit A x) (unit B x)))) + +(syntax-test + '(compound-unit/sig + (import) + (link [A : (a) ((unit/sig (a) (import) (define a 1)))] + [B : (b) ((unit/sig (b) (import) (define b 2)))]) + (export (unit A) (unit B A)))) + +; Shadowed syntax definitions: + +(test 8 'unit/sig (invoke-unit/sig (unit/sig () (import) (define lambda 8) lambda))) +(test 9 'unit/sig (invoke-unit/sig (unit/sig () (import) (begin (define lambda 9) (define lambda2 lambda)) lambda2))) + +(report-errs) +