From 6c44b13d583dfe24965de84a0d5398155cb70096 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 16 Jan 2001 19:15:14 +0000
Subject: [PATCH] .

original commit: 289402f746d5c41baa22c1a1f5ccdda17ef65871
---
 collects/mzlib/{signedunit.ss => sigutils.ss} | 360 ++----------------
 collects/mzlib/unitsig.ss                     | 294 ++++++++++++++
 2 files changed, 328 insertions(+), 326 deletions(-)
 rename collects/mzlib/{signedunit.ss => sigutils.ss} (73%)
 create mode 100644 collects/mzlib/unitsig.ss

diff --git a/collects/mzlib/signedunit.ss b/collects/mzlib/sigutils.ss
similarity index 73%
rename from collects/mzlib/signedunit.ss
rename to collects/mzlib/sigutils.ss
index 2b5bf93..29deb90 100644
--- a/collects/mzlib/signedunit.ss
+++ b/collects/mzlib/sigutils.ss
@@ -1,22 +1,13 @@
 
-(module signedunit mzscheme
-  
-  ; Parse-time structs:
+(module sigutils mzscheme
+
+  ;; Used by signedunit.ss 
+
   (define-struct signature (name    ; sym
 			    src     ; sym
 			    elems)) ; list of syms and signatures
   (define-struct parse-unit (imports renames vars body))
 
-  ; Transform time:
-  (define-struct sig (content))
-  
-  (define d-s 'define-signature)
-  (define l-s 'let-signature)
-  (define unit/sig 'unit/sig)
-  (define u->u/sig 'unit->unit/sig)
-  (define cpd-unit/sig 'compound-unit/sig)
-  (define invoke-unit/sig 'invoke-unit/sig)
-
   (define inline-sig-name '<unnamed>)
 
   (define syntax-error
@@ -309,28 +300,6 @@
 			     (flatten-signature id s)))
 			 sigs))))
 
-  (define-syntax define-signature
-    (lambda (expr)
-      (syntax-case expr ()
-	[(_ name sig)
-	 (identifier? (syntax name))
-	 (let ([sig (get-sig d-s expr (syntax-e (syntax name))
-			     (syntax sig))])
-	   (with-syntax ([content (explode-sig sig)])
-	     (syntax (define-syntax name
-		       (make-sig (quote content))))))])))
-
-  (define-syntax let-signature
-    (lambda (expr)
-      (syntax-case expr ()
-	[(_ name sig . body)
-	 (identifier? (syntax name))
-	 (let ([sig (get-sig d-s expr (syntax-e (syntax name))
-			     (syntax sig))])
-	   (with-syntax ([content (explode-sig sig)])
-	     (syntax (letrec-syntax ([name (make-sig (quote content))])
-		       . body))))])))
-  
   (define signature-parts
     (lambda (q?)
       (lambda (sig)
@@ -584,32 +553,6 @@
 			    (cons line body)
 			    vars)]))]))))))))
   
-  (define-syntax unit/sig
-    (lambda (expr)
-      (syntax-case expr ()
-	[(_ sig . rest)
-	 (let ([sig (get-sig 'unit/sig expr #f (syntax sig))])
-	  (let ([a-unit (parse-unit expr (syntax rest) sig)])
-	    (check-signature-unit-body sig a-unit (parse-unit-renames a-unit) 'unit/sig expr)
-	    (with-syntax ([imports (flatten-signatures
-				    (parse-unit-imports a-unit))]
-			  [exports (map
-				    (lambda (name)
-				      (list (do-rename name (parse-unit-renames a-unit))
-					    name))
-				    (signature-vars sig))]
-			  [body (reverse! (parse-unit-body a-unit))]
-			  [import-sigs (explode-named-sigs (parse-unit-imports a-unit))]
-			  [export-sig (explode-sig sig)])
-	    (syntax
-	     (make-unit-with-signature
-	      (unit
-		(import . imports)
-		(export . exports)
-		. body)
-	      (quote import-sigs)
-	      (quote export-sig))))))])))
-  
   (define-struct link (name sig expr links))
   (define-struct sig-explode-pair (sigpart exploded))
 
@@ -619,15 +562,15 @@
 	[((import . imports)
 	  (link . links)
 	  (export . exports))
-	 (let* ([imports (parse-imports cpd-unit/sig #f #t expr (syntax imports))])
+	 (let* ([imports (parse-imports 'compound-unit/sig #f #t expr (syntax imports))])
 	   (let ([link-list (syntax->list (syntax links))])
 	     (unless link-list
-	       (syntax-error cpd-unit/sig expr 
+	       (syntax-error 'compound-unit/sig expr 
 			     "improper `link' clause form"
 			     (syntax links)))
 	     (let* ([bad
 		     (lambda (why sub)
-		       (syntax-error cpd-unit/sig expr 
+		       (syntax-error 'compound-unit/sig expr 
 				     (format "bad `link' element~a" why)
 				     sub))]
 		    [links
@@ -639,7 +582,7 @@
 			     (unless (identifier? (syntax tag))
 			       (bad ": link tag is not an identifier" line))
 			     (make-link (syntax-e (syntax tag))
-					(get-sig cpd-unit/sig expr #f (syntax sig))
+					(get-sig 'compound-unit/sig expr #f (syntax sig))
 					(syntax expr)
 					(syntax->list (syntax (linkage ...)))))]
 			  [(tag . x)
@@ -685,10 +628,10 @@
 				   (when use-sig
 				     (with-handlers ([exn:unit? (lambda (exn)
 								  (syntax-error 
-								   cpd-unit/sig expr
+								   'compound-unit/sig expr
 								   (exn-message exn)))])
 				       (verify-signature-match
-					cpd-unit/sig #f
+					'compound-unit/sig #f
 					(format "signature ~s" (signature-src use-sig))
 					(explode-sig use-sig)
 					(format "signature ~s" (signature-src sig))
@@ -703,7 +646,7 @@
 								sig))]
 				    [(or (not (stx-pair? p))
 					 (not (identifier? (stx-car p))))
-				     (syntax-error cpd-unit/sig expr
+				     (syntax-error 'compound-unit/sig expr
 						   (format "bad `~a' path" clause)
 						   path)]
 				    [(memq (syntax-e (stx-car p)) (signature-vars sig))
@@ -716,7 +659,7 @@
 									(symbol->string id-nopath)))
 							id-nopath)])
 					   (var-k base id id-nopath))
-					 (syntax-error cpd-unit/sig expr
+					 (syntax-error 'compound-unit/sig expr
 						       (format 
 							"bad `~a' path: \"~a\" is a variable" 
 							clause
@@ -736,7 +679,7 @@
 							s
 							(stx-cdr p)))]
 				    [else
-				     (syntax-error cpd-unit/sig expr
+				     (syntax-error 'compound-unit/sig expr
 						   (format 
 						    "bad `~a' path: \"~a\" not found"
 						    clause
@@ -750,7 +693,7 @@
 					[(name : sig)
 					 (identifier? (syntax name))
 					 (values (list (syntax name))
-						 (get-sig cpd-unit/sig expr
+						 (get-sig 'compound-unit/sig expr
 							  #f
 							  (syntax sig)))]
 					[((elem ...) : sig)
@@ -759,7 +702,7 @@
 							(not (eq? (syntax-e s) ':))))
 						 (syntax (elem ...)))
 					 (values (syntax (elem ...))
-						 (get-sig cpd-unit/sig expr
+						 (get-sig 'compound-unit/sig expr
 							  #f
 							  (syntax sig)))]
 					[(elem ...)
@@ -769,7 +712,7 @@
 						 (syntax (elem ...)))
 					 (values path #f)]
 					[else
-					 (syntax-error cpd-unit/sig expr
+					 (syntax-error 'compound-unit/sig expr
 						       (format 
 							"bad `~a' path"
 							clause)
@@ -793,7 +736,7 @@
 						     sig
 						     (stx-cdr p))))]
 			    [else
-			     (syntax-error cpd-unit/sig expr
+			     (syntax-error 'compound-unit/sig expr
 					   (format 
 					    "bad `~a' path: \"~a\" not found"
 					    clause
@@ -801,16 +744,16 @@
 					   path)]))))])
 	  (check-unique (map link-name links)
 			(lambda (name)
-			  (syntax-error cpd-unit/sig expr
+			  (syntax-error 'compound-unit/sig expr
 					(format "duplicate sub-unit tag \"~s\"" name))))
 	  (check-unique (map signature-name imports)
 			(lambda (name)
-			  (syntax-error cpd-unit/sig expr
+			  (syntax-error 'compound-unit/sig expr
 					(format "duplicate import identifier \"~s\"" name))))
 	  (check-unique (append (map signature-name imports)
 				(map link-name links))
 			(lambda (name)
-			  (syntax-error cpd-unit/sig expr
+			  (syntax-error 'compound-unit/sig expr
 					(format 
 					 "name \"~s\" is both import and sub-unit identifier" 
 					 name))))
@@ -839,7 +782,7 @@
 	   links)
 	  (let ([export-list (syntax->list (syntax exports))])
 	    (unless export-list
-	      (syntax-error cpd-unit/sig expr 
+	      (syntax-error 'compound-unit/sig expr 
 			    "improper `export' clause form"
 			    (syntax exports))))
 	  (let* ([upath? (lambda (p)
@@ -851,7 +794,7 @@
 			     [(name : sig)
 			      (and (upath? (syntax name))
 				   (or (identifier? (syntax sig))
-				       (parse-signature cpd-unit/sig expr #f (syntax sig))))
+				       (parse-signature 'compound-unit/sig expr #f (syntax sig))))
 			      #t]
 			     [_else
 			      (upath? p)]))]
@@ -862,14 +805,14 @@
 		       [(open spath)
 			(begin
 			  (unless (spath? (syntax spath))
-			    (syntax-error cpd-unit/sig expr 
+			    (syntax-error 'compound-unit/sig expr 
 					  "bad `open' sub-clause of `export'"
 					  export))
 			  (flatten-path 'export
 					(syntax spath)
 					(lambda (base var var-nopath)
 					  (syntax-error 
-					   cpd-unit/sig expr 
+					   'compound-unit/sig expr 
 					   "`open' sub-clause path is a variable"
 					   (car export)))
 					(lambda (base last name sig)
@@ -882,7 +825,7 @@
 						      (flatten-signature name sig)
 						      (flatten-signature #f sig))))
 					      (syntax-error 
-					       cpd-unit/sig expr 
+					       'compound-unit/sig expr 
 					       "cannot export imported variables"
 					       export)))))]
 		       [(var upath vname . exname)
@@ -895,7 +838,7 @@
 					   (and (stx-pair? exname)
 						(identifier? (stx-car exname))
 						(stx-null? (stx-cdr exname)))))
-			    (syntax-error cpd-unit/sig expr 
+			    (syntax-error 'compound-unit/sig expr 
 					  "bad `var' sub-clause of `export'"
 					  export))
 			  (flatten-path 'export
@@ -913,12 +856,12 @@
 							 (list var var-nopath)
 							 (list var (syntax-e (stx-car exname))))))
 					      (syntax-error 
-					       cpd-unit/sig expr 
+					       'compound-unit/sig expr 
 					       "cannot export imported variables"
 					       export)))
 					(lambda (base last name var)
 					  (syntax-error 
-					   cpd-unit/sig expr 
+					   'compound-unit/sig expr 
 					   "`var' sub-clause path specifies a unit"
 					   export))))]
 		       [(unit spath . exname)
@@ -929,14 +872,14 @@
 					   (and (stx-pair? exname)
 						(identifier? (stx-car exname))
 						(stx-null? (stx-cdr exname)))))
-			    (syntax-error cpd-unit/sig expr 
+			    (syntax-error 'compound-unit/sig expr 
 					  "bad `unit' sub-clause of `export'"
 					  export))
 			  (flatten-path 'export
 					spath
 					(lambda (base var var-nopath)
 					  (syntax-error 
-					   cpd-unit/sig expr 
+					   'compound-unit/sig expr 
 					   "`unit' sub-clause path is a variable"
 					   export))
 					(lambda (base last name sig)
@@ -958,11 +901,11 @@
 									     (syntax-e (stx-car exname))))
 							 sig)))))
 					      (syntax-error 
-						 cpd-unit/sig expr 
+						 'compound-unit/sig expr 
 						 "cannot export imported variables"
 						 export)))))]
 		       [_else
-			(syntax-error cpd-unit/sig expr 
+			(syntax-error 'compound-unit/sig expr 
 				      (format 
 				       "bad `export' sub-clause")
 				      export)]))
@@ -976,7 +919,7 @@
 			    append
 			    (map sig-explode-pair-sigpart exports)))
 			  (lambda (name)
-			    (syntax-error cpd-unit/sig expr
+			    (syntax-error 'compound-unit/sig expr
 					  (format 
 					   "the name \"~s\" is exported twice" 
 					   name))))
@@ -987,7 +930,7 @@
 			     (link-expr link)))
 		     links)
 		(verify-linkage-signature-match
-		 (quote ,cpd-unit/sig)
+		 (quote ,'compound-unit/sig)
 		 (quote ,(map link-name links))
 		 (list ,@(map link-name links))
 		 (quote ,(map (lambda (link) (explode-sig (link-sig link))) links))
@@ -1024,243 +967,8 @@
 			    (map sig-explode-pair-sigpart exports)))))))
 	     (quote-syntax here)
 	     expr)))))])))
-  
-  (define-syntax compound-unit/sig
-    (lambda (expr)
-      (syntax-case expr ()
-	[(_ . body)
-	 (parse-compound-unit expr (syntax body))])))
 
   (define parse-invoke-vars
     (lambda (who rest expr)
       (parse-imports who #t #f expr rest)))
 
-  (define-syntax invoke-unit/sig
-    (lambda (expr)
-      (syntax-case expr ()
-	[(_ u sig ...)
-	 (let ([u (syntax u)]
-	       [sigs (parse-invoke-vars invoke-unit/sig (syntax (sig ...)) expr)])
-	   (datum->syntax
-	    `(let ([u ,u])
-	       (verify-linkage-signature-match
-		(quote invoke-unit/sig)
-		(quote (invoke))
-		(list u)
-		(quote (#()))
-		(quote (,(explode-named-sigs sigs))))
-	       (invoke-unit (unit-with-signature-unit u)
-			    ,@(flatten-signatures
-			       sigs)))
-	    (quote-syntax here)
-	    expr))])))
-  
-  (define unit->unit/sig
-    (lambda (expr)
-      (syntax-case expr ()
-	[(_ e (im-sig ...) ex-sig)
-	 (let ([e (syntax e)]
-	       [im-sigs (map (lambda (sig)
-			       (get-sig u->u/sig expr #f sig))
-			     (syntax->list (syntax (im-sig ...))))]
-	       [ex-sig (get-sig u->u/sig expr #f (syntax ex-sig))])
-	   (datum->syntax
-	    `(make-unit-with-signature
-	      ,e
-	      (quote ,(explode-named-sigs im-sigs))
-	      (quote ,(explode-sig ex-sig)))
-	    (quote-syntax here)
-	    expr))])))
-
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-  (define verify-linkage-signature-match
-    (let ([make-exn make-exn:unit]
-	  [p-suffix (lambda (pos) (case pos [(1) 'st][(2) 'nd][(3) 'rd][else 'th]))])
-      (lambda (who tags units esigs isigs)
-	(for-each
-	 (lambda (u tag)
-	   (unless (unit-with-signature? u)
-	     (raise
-	      (make-exn
-	       (string->immutable-string
-		(format
-		 "~s: expression for \"~s\" is not a signed unit: ~e"
-		 who tag u))
-	       (current-continuation-marks)))))
-	 units tags)
-	(for-each
-	 (lambda (u tag esig)
-	   (verify-signature-match
-	    who #f
-	    (format "specified export signature for ~a" tag)
-	    esig
-	    (format "export signature for actual ~a sub-unit" tag)
-	    (unit-with-signature-exports u)))
-	 units tags esigs)
-	(for-each
-	 (lambda (u tag isig)
-	   (let ([n (length (unit-with-signature-imports u))]
-		 [c (length isig)])
-	     (unless (= c n)
-	       (raise
-		(make-exn
-		 (string->immutable-string
-		  (format
-		   "~s: ~a unit imports ~a units, but ~a units were provided"
-		   who tag n c))
-		 (current-continuation-marks))))))
-	 units tags isigs)
-	(for-each
-	 (lambda (u tag isig)
-	   (let loop ([isig isig][expecteds (unit-with-signature-imports u)][pos 1])
-	     (unless (null? isig)
-	       (let ([expected (car expecteds)]
-		     [provided (car isig)])
-		 (verify-signature-match
-		  who #t
-		  (format "~a unit's ~s~s import (which is ~a)" tag
-			  pos (p-suffix pos)
-			  (car expected))
-		  (cdr expected)
-		  (format "~a's ~s~s linkage (which is ~a)"
-			  tag
-			  pos (p-suffix pos)
-			  (car provided))
-		  (cdr provided))
-		 (loop (cdr isig) (cdr expecteds) (add1 pos))))))
-	 units tags isigs))))
-
-  (define (hash-sig src-sig table)
-    (and (vector? src-sig)
-	 (andmap
-	  (lambda (s)
-	    (cond
-	     [(symbol? s)
-	      (if (hash-table-get table s (lambda () #f))
-		  #f
-		  (begin
-		    (hash-table-put! table s s)
-		    #t))]
-	     [(and (pair? s) (symbol? (car s)))
-	      (let ([name (car s)])
-		(if (hash-table-get table name (lambda () #f))
-		  #f
-		  (let ([t (make-hash-table)])
-		    (hash-table-put! table name t)
-		    (hash-sig (cdr s) t))))]
-	     [else #f]))
-	  (vector->list src-sig))))
-
-  (define (sig-path-name name path)
-    (let loop ([s (symbol->string name)]
-	       [path path])
-      (if (null? path)
-	  s
-	  (loop (format "~a:~a" s (car path))
-		(cdr path)))))
-
-  (define (check-sig-match table sig path exact? who src-context dest-context)
-    (and (vector? sig)
-	 (andmap
-	  (lambda (s)
-	    (cond
-	     [(symbol? s)
-	      (let ([v (hash-table-get table s
-				       (lambda ()
-					 (raise
-					  (make-exn:unit
-					   (format
-					    "~a: ~a is missing a value name `~a', required by ~a",
-					    who
-					    src-context
-					    (sig-name-path s path)
-					    dest-context)
-					   (current-continuation-marks)))))])
-		(and v
-		     (begin
-		       (unless (symbol? v)
-			 (let ([p (sig-name-path s path)])
-			   (raise
-			    (make-exn:unit
-			     (format
-			      "~a: ~a contains `~a' as a sub-unit name, but ~a contains `~a' as a value name"
-			      who
-			      src-context
-			      p
-			      dest-context
-			      p)
-			     (current-continuation-marks)))))
-		       (hash-table-put! table s #f)
-		       #t)))]
-	     [(and (pair? s) (symbol? (car s)))
-	      (let ([v (hash-table-get table (car s)
-				       (lambda ()
-					 (raise
-					  (make-exn:unit
-					   (format
-					    "~a: ~a is missing a sub-unit name `~a', required by ~a",
-					    who
-					    src-context
-					    (sig-name-path s path)
-					    dest-context)
-					   (current-continuation-marks)))))])
-		(and v
-		     (begin
-		       (unless (hash-table? v)
-			 (let ([p (sig-name-path (car s) path)])
-			   (raise
-			    (make-exn:unit
-			     (format
-			      "~a: ~a contains `~a' as a value name, but ~a contains `~a' as a sub-unit name"
-			      who
-			      src-context
-			      p
-			      dest-context
-			      p)
-			     (current-continuation-marks)))))
-		       (hash-table-put! table (car s) #f)
-		       (chec-sig-match v (cdr s) (cons (car s) path)
-				       exact? who src-context dest-context))))]
-	     [else #f]))
-	  (vector->list sig))
-	 (or (not exact?)
-	     (hash-table-for-each
-	      table
-	      (lambda (k v)
-		(when v
-		  (let ([p (sig-name-path k path)])
-		    (raise
-		     (make-exn:unit
-		      (format
-		       "~a: ~a contains an extra ~a name `~a' that is not required by ~a"
-		       who
-		       src-context
-		       (if (symbol? v) 'value 'sub-unit)
-		       p
-		       dest-context)
-		      (current-continuation-marks)))))))
-	     #t)))
-
-  (define (verify-signature-match who exact? dest-context dest-sig src-context src-sig)
-    (unless (symbol? who)
-      (raise-type-error 'verify-signature-match "symbol" who))
-    (unless (string? dest-context)
-      (raise-type-error 'verify-signature-match "string" dest-context))
-    (unless (string? src-context)
-      (raise-type-error 'verify-signature-match "string" src-context))
-
-    (let ([src-table (make-hash-table)])
-      (unless (hash_sig src-sig, src-table)
-	(raise-type-error 'verify-signature-match "signature" src-sig))
-
-      (unless (check-sig-match src-table dest-sig null
-			       exact? who src-context dest-context)
-	(raise-type-error 'verify-signature-match "signature" dest-sig))))
-
-  (export define-signature
-	  let-signature
-          unit/sig
-          compound-unit/sig
-	  invoke-unit/sig
-	  unit->unit/sig)))
diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss
new file mode 100644
index 0000000..c023677
--- /dev/null
+++ b/collects/mzlib/unitsig.ss
@@ -0,0 +1,294 @@
+
+(module signedunit mzscheme
+  (import "unit.ss")
+  (import "sigutils.ss")
+  
+  ; Transform time:
+  (define-struct sig (content))
+  
+  (define-syntax define-signature
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ name sig)
+	 (identifier? (syntax name))
+	 (let ([sig (get-sig d-s expr (syntax-e (syntax name))
+			     (syntax sig))])
+	   (with-syntax ([content (explode-sig sig)])
+	     (syntax (define-syntax name
+		       (make-sig (quote content))))))])))
+
+  (define-syntax let-signature
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ name sig . body)
+	 (identifier? (syntax name))
+	 (let ([sig (get-sig 'let-signature expr (syntax-e (syntax name))
+			     (syntax sig))])
+	   (with-syntax ([content (explode-sig sig)])
+	     (syntax (letrec-syntax ([name (make-sig (quote content))])
+		       . body))))])))
+  
+  (define-syntax unit/sig
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ sig . rest)
+	 (let ([sig (get-sig 'unit/sig expr #f (syntax sig))])
+	  (let ([a-unit (parse-unit expr (syntax rest) sig)])
+	    (check-signature-unit-body sig a-unit (parse-unit-renames a-unit) 'unit/sig expr)
+	    (with-syntax ([imports (flatten-signatures
+				    (parse-unit-imports a-unit))]
+			  [exports (map
+				    (lambda (name)
+				      (list (do-rename name (parse-unit-renames a-unit))
+					    name))
+				    (signature-vars sig))]
+			  [body (reverse! (parse-unit-body a-unit))]
+			  [import-sigs (explode-named-sigs (parse-unit-imports a-unit))]
+			  [export-sig (explode-sig sig)])
+	    (syntax
+	     (make-unit-with-signature
+	      (unit
+		(import . imports)
+		(export . exports)
+		. body)
+	      (quote import-sigs)
+	      (quote export-sig))))))])))  
+
+  (define-syntax compound-unit/sig
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ . body)
+	 (parse-compound-unit expr (syntax body))])))
+
+  (define-syntax invoke-unit/sig
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ u sig ...)
+	 (let ([u (syntax u)]
+	       [sigs (parse-invoke-vars 'invoke-unit/sig (syntax (sig ...)) expr)])
+	   (datum->syntax
+	    `(let ([u ,u])
+	       (verify-linkage-signature-match
+		(quote invoke-unit/sig)
+		(quote (invoke))
+		(list u)
+		(quote (#()))
+		(quote (,(explode-named-sigs sigs))))
+	       (invoke-unit (unit-with-signature-unit u)
+			    ,@(flatten-signatures
+			       sigs)))
+	    (quote-syntax here)
+	    expr))])))
+  
+  (define-syntax unit->unit/sig
+    (lambda (expr)
+      (syntax-case expr ()
+	[(_ e (im-sig ...) ex-sig)
+	 (let ([e (syntax e)]
+	       [im-sigs (map (lambda (sig)
+			       (get-sig 'unit->unit/sig expr #f sig))
+			     (syntax->list (syntax (im-sig ...))))]
+	       [ex-sig (get-sig 'unit->unit/sig expr #f (syntax ex-sig))])
+	   (datum->syntax
+	    `(make-unit-with-signature
+	      ,e
+	      (quote ,(explode-named-sigs im-sigs))
+	      (quote ,(explode-sig ex-sig)))
+	    (quote-syntax here)
+	    expr))])))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define verify-linkage-signature-match
+    (let ([make-exn make-exn:unit]
+	  [p-suffix (lambda (pos) (case pos [(1) 'st][(2) 'nd][(3) 'rd][else 'th]))])
+      (lambda (who tags units esigs isigs)
+	(for-each
+	 (lambda (u tag)
+	   (unless (unit-with-signature? u)
+	     (raise
+	      (make-exn
+	       (string->immutable-string
+		(format
+		 "~s: expression for \"~s\" is not a signed unit: ~e"
+		 who tag u))
+	       (current-continuation-marks)))))
+	 units tags)
+	(for-each
+	 (lambda (u tag esig)
+	   (verify-signature-match
+	    who #f
+	    (format "specified export signature for ~a" tag)
+	    esig
+	    (format "export signature for actual ~a sub-unit" tag)
+	    (unit-with-signature-exports u)))
+	 units tags esigs)
+	(for-each
+	 (lambda (u tag isig)
+	   (let ([n (length (unit-with-signature-imports u))]
+		 [c (length isig)])
+	     (unless (= c n)
+	       (raise
+		(make-exn
+		 (string->immutable-string
+		  (format
+		   "~s: ~a unit imports ~a units, but ~a units were provided"
+		   who tag n c))
+		 (current-continuation-marks))))))
+	 units tags isigs)
+	(for-each
+	 (lambda (u tag isig)
+	   (let loop ([isig isig][expecteds (unit-with-signature-imports u)][pos 1])
+	     (unless (null? isig)
+	       (let ([expected (car expecteds)]
+		     [provided (car isig)])
+		 (verify-signature-match
+		  who #t
+		  (format "~a unit's ~s~s import (which is ~a)" tag
+			  pos (p-suffix pos)
+			  (car expected))
+		  (cdr expected)
+		  (format "~a's ~s~s linkage (which is ~a)"
+			  tag
+			  pos (p-suffix pos)
+			  (car provided))
+		  (cdr provided))
+		 (loop (cdr isig) (cdr expecteds) (add1 pos))))))
+	 units tags isigs))))
+
+  (define (hash-sig src-sig table)
+    (and (vector? src-sig)
+	 (andmap
+	  (lambda (s)
+	    (cond
+	     [(symbol? s)
+	      (if (hash-table-get table s (lambda () #f))
+		  #f
+		  (begin
+		    (hash-table-put! table s s)
+		    #t))]
+	     [(and (pair? s) (symbol? (car s)))
+	      (let ([name (car s)])
+		(if (hash-table-get table name (lambda () #f))
+		  #f
+		  (let ([t (make-hash-table)])
+		    (hash-table-put! table name t)
+		    (hash-sig (cdr s) t))))]
+	     [else #f]))
+	  (vector->list src-sig))))
+
+  (define (sig-path-name name path)
+    (let loop ([s (symbol->string name)]
+	       [path path])
+      (if (null? path)
+	  s
+	  (loop (format "~a:~a" s (car path))
+		(cdr path)))))
+
+  (define (check-sig-match table sig path exact? who src-context dest-context)
+    (and (vector? sig)
+	 (andmap
+	  (lambda (s)
+	    (cond
+	     [(symbol? s)
+	      (let ([v (hash-table-get table s
+				       (lambda ()
+					 (raise
+					  (make-exn:unit
+					   (format
+					    "~a: ~a is missing a value name `~a', required by ~a",
+					    who
+					    src-context
+					    (sig-name-path s path)
+					    dest-context)
+					   (current-continuation-marks)))))])
+		(and v
+		     (begin
+		       (unless (symbol? v)
+			 (let ([p (sig-name-path s path)])
+			   (raise
+			    (make-exn:unit
+			     (format
+			      "~a: ~a contains `~a' as a sub-unit name, but ~a contains `~a' as a value name"
+			      who
+			      src-context
+			      p
+			      dest-context
+			      p)
+			     (current-continuation-marks)))))
+		       (hash-table-put! table s #f)
+		       #t)))]
+	     [(and (pair? s) (symbol? (car s)))
+	      (let ([v (hash-table-get table (car s)
+				       (lambda ()
+					 (raise
+					  (make-exn:unit
+					   (format
+					    "~a: ~a is missing a sub-unit name `~a', required by ~a",
+					    who
+					    src-context
+					    (sig-name-path s path)
+					    dest-context)
+					   (current-continuation-marks)))))])
+		(and v
+		     (begin
+		       (unless (hash-table? v)
+			 (let ([p (sig-name-path (car s) path)])
+			   (raise
+			    (make-exn:unit
+			     (format
+			      "~a: ~a contains `~a' as a value name, but ~a contains `~a' as a sub-unit name"
+			      who
+			      src-context
+			      p
+			      dest-context
+			      p)
+			     (current-continuation-marks)))))
+		       (hash-table-put! table (car s) #f)
+		       (chec-sig-match v (cdr s) (cons (car s) path)
+				       exact? who src-context dest-context))))]
+	     [else #f]))
+	  (vector->list sig))
+	 (or (not exact?)
+	     (hash-table-for-each
+	      table
+	      (lambda (k v)
+		(when v
+		  (let ([p (sig-name-path k path)])
+		    (raise
+		     (make-exn:unit
+		      (format
+		       "~a: ~a contains an extra ~a name `~a' that is not required by ~a"
+		       who
+		       src-context
+		       (if (symbol? v) 'value 'sub-unit)
+		       p
+		       dest-context)
+		      (current-continuation-marks)))))))
+	     #t)))
+
+  (define (verify-signature-match who exact? dest-context dest-sig src-context src-sig)
+    (unless (symbol? who)
+      (raise-type-error 'verify-signature-match "symbol" who))
+    (unless (string? dest-context)
+      (raise-type-error 'verify-signature-match "string" dest-context))
+    (unless (string? src-context)
+      (raise-type-error 'verify-signature-match "string" src-context))
+
+    (let ([src-table (make-hash-table)])
+      (unless (hash_sig src-sig, src-table)
+	(raise-type-error 'verify-signature-match "signature" src-sig))
+
+      (unless (check-sig-match src-table dest-sig null
+			       exact? who src-context dest-context)
+	(raise-type-error 'verify-signature-match "signature" dest-sig))))
+
+  (export-indirect verify-linkage-signature-match)
+
+  (export define-signature
+	  let-signature
+          unit/sig
+          compound-unit/sig
+	  invoke-unit/sig
+	  unit->unit/sig))
+