startup

original commit: 3a0f0320d6b793ce1e5bf05aff04f77f67a0141c

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) #<weak-box> 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)

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)

collects/tests/mzscheme/uinc.ss

@@ -0,0 +1,2 @@
+
+(+ 4 5)

collects/tests/mzscheme/uinc2.ss

@@ -0,0 +1,2 @@
+
+(define x 8)

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) #<struct-type> (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)

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) #<struct-type> (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)
+