.

original commit: 8e49a06ea8b58b60c54ad365dab66df803c5fde0

collects/mzlib/include.ss

@@ -0,0 +1,106 @@
+
+(module include mzscheme
+
+  (define-syntax include
+    (lambda (stx)
+      ;; Parse the file name
+      (let ([file
+	     (syntax-case stx (build-path)
+	       [(_ fn)
+		(string? (syntax-e (syntax fn)))
+		(syntax-e (syntax fn))]
+	       [(_ (build-path elem1 elem ...))
+		(andmap
+		 (lambda (e)
+		   (or (string? (syntax-e e))
+		       (module-identifier=? e (quote-syntax up))
+		       (module-identifier=? e (quote-syntax same))))
+		 (syntax->list (syntax (elem1 elem ...))))
+		(apply build-path (syntax->datum (syntax (elem1 elem ...))))])])
+	;; Complete the file name
+	(let ([c-file
+	       (if (complete-path? file)
+		   file
+		   (path->complete-path
+		    file
+		    (cond
+		     ;; Src of include expression is a path?
+		     [(and (string? (syntax-source stx))
+			   (complete-path? (syntax-source stx)))
+		      (let-values ([(base name dir?) 
+				    (split-path (syntax-source stx))])
+			(if dir?
+			    (syntax-source stx)
+			    base))]
+		     ;; Load relative?
+		     [(current-load-relative-directory)]
+		     ;; Current directory
+		     [(current-directory)]
+		     [else (raise-syntax-error
+			    'include
+			    "can't determine a base path"
+			    stx)])))])
+	  ;; Open the included file
+	  (let ([p (with-handlers ([not-break-exn?
+				    (lambda (exn)
+				      (raise-syntax-error
+				       'include
+				       (format
+					"can't open include file (~a)"
+					(if (exn? exn)
+					    (exn-message exn)
+					    exn))
+				       stx
+				       c-file))])
+		     (open-input-file c-file))])
+	    ;; Read expressions from file
+	    (let ([content
+		   (let loop ()
+		     (let ([r (with-handlers ([not-break-exn?
+					       (lambda (exn)
+						 (raise-syntax-error
+						  'include
+						  (format
+						   "read error (~a)"
+						   (if (exn? exn)
+						       (exn-message exn)
+						       exn))
+						  stx))])
+				(read-syntax c-file p))])
+		       (if (eof-object? r)
+			   null
+			   (cons r (loop)))))])
+	      ;; Preserve src info for content, but set its
+	      ;; lexical context to be that of the include expression
+	      (let ([lexed-content
+		     (let loop ([content content])
+		       (cond
+			[(pair? content)
+			 (cons (loop (car content))
+			       (loop (cdr content)))]
+			[(null? content) null]
+			[else
+			 (let ([v (syntax-e content)])
+			   (datum->syntax
+			    (cond
+			     [(pair? v) 
+			      (loop v)]
+			    [(vector? v)
+			     (list->vector (loop (vector->list v)))]
+			    [(box? v)
+			     (box (loop (unbox v)))]
+			    [else
+			     v])
+			    content
+			    stx))]))])
+		(datum->syntax 
+		 `(begin ,@lexed-content)
+		 stx
+		 (quote-syntax here)))))))))
+
+  (export include))
+
+		 
+			   
+	      
+		     

collects/mzlib/sigmatch.ss

@@ -74,7 +74,7 @@
 					    "~a: ~a is missing a sub-unit name `~a', required by ~a"
 					    who
 					    src-context
-					    (sig-path-name s path)
+					    (sig-path-name (car s) path)
 					    dest-context)
 					   (current-continuation-marks)))))])
 		(and v

collects/mzlib/sigutil.ss

@@ -467,21 +467,23 @@
 				  (loop (cdr e))
 				  (cons (car e) (loop (cdr e)))))))]
 		   [local-vars (append renamed-internals filtered-exported-names imported-names)])
-	      (let loop ([pre-lines null][lines body][port #f][body null][vars null])
+	      (let loop ([pre-lines null][lines body][port #f][port-name #f][body null][vars null])
 		(cond
 		 [(and (null? pre-lines) (not port) (null? lines))
 		  (make-parse-unit imports renames vars body)]
 		 [(and (null? pre-lines) (not port) (not (pair? lines)))
 		  (syntax-error 'unit/sig expr "improper body list form")]
 		 [else
-		  (let-values ([(line) (local-expand
-					(cond
-					 [(pair? pre-lines) (car pre-lines)]
-					 [port (read-syntax port)]
-					 [else (car lines)])
-					(append
-					 user-stx-forms
-					 local-vars))]
+		  (let-values ([(line) (let ([s (cond
+						 [(pair? pre-lines) (car pre-lines)]
+						 [port (read-syntax port-name port)]
+						 [else (car lines)])])
+					 (if (eof-object? s)
+					   s
+					   (local-expand s    
+							 (append
+							  user-stx-forms
+							  local-vars))))]
 			       [(rest-pre-lines) 
 				(if (null? pre-lines)
 				    null
@@ -502,6 +504,7 @@
 			 (loop rest-pre-lines
 			       rest-lines
 			       port
+			       port-name
 			       (cons line body)
 			       (append (syntax->list (syntax (id ...))) vars))]
 			[else
@@ -518,6 +521,7 @@
 			(loop (append (cdr line-list) rest-pre-lines)
 			      rest-lines
 			      port
+			      port-name
 			      body
 			      vars))]
 		     [(and (stx-pair? line)
@@ -532,9 +536,10 @@
 					     (format "cannot include a directory ~s"
 						     file)))
 			     (let* ([old-dir (current-load-relative-directory)]
-				    [p (open-input-file (if (and old-dir (not (complete-path? file)))
-							    (path->complete-path file old-dir)
-							    file))])
+				    [c-file (if (and old-dir (not (complete-path? file)))
+						(path->complete-path file old-dir)
+						file)]
+				    [p (open-input-file c-file)])
 			       (let-values ([(lines body vars)
 					     (parameterize ([current-load-relative-directory
 							     (if (string? base) 
@@ -552,11 +557,12 @@
 						  (loop null
 							rest-lines
 							p
+							c-file
 							body
 							vars))
 						(lambda ()
 						  (close-input-port p))))])
-				 (loop rest-pre-lines lines port body vars)))))]
+				 (loop rest-pre-lines lines port port-name body vars)))))]
 			[else
 			 (syntax-error 'unit/sig expr 
 				       "improper `include' clause form"
@@ -565,6 +571,7 @@
 		      (loop rest-pre-lines
 			    rest-lines
 			    port
+			    port-name
 			    (cons line body)
 			    vars)]))]))))))))
   
@@ -729,11 +736,11 @@
 						 (get-sig 'compound-unit/sig expr
 							  #f
 							  (syntax sig)))]
-					[(elem ...)
+					[(elem1 elem ...)
 					 (andmap (lambda (s)
 						   (and (identifier? s)
 							(not (eq? (syntax-e s) ':))))
-						 (syntax->list (syntax (elem ...))))
+						 (syntax->list (syntax (elem1 elem ...))))
 					 (values path #f)]
 					[else
 					 (syntax-error 'compound-unit/sig expr
@@ -924,9 +931,10 @@
 							       list
 							       flat
 							       (flatten-signature 
-								(symbol->string (if (stx-null? exname)
-										    last
-										    (syntax-e (stx-car exname))))
+								(symbol->string
+								 (if (stx-null? exname)
+								     last
+								     (syntax-e (stx-car exname))))
 								sig)))))
 						     (syntax-error 
 						      'compound-unit/sig expr 
@@ -948,9 +956,8 @@
 				   (map sig-explode-pair-sigpart exports)))
 				 (lambda (name)
 				   (syntax-error 'compound-unit/sig expr
-						 (format 
-						  "the name \"~s\" is exported twice" 
-						  name))))
+						 "name is exported twice"
+						 name)))
 		   (values (map link-name links)
 			   (map link-expr links)
 			   (map (lambda (link) (explode-sig (link-sig link))) links)

collects/mzlib/unitsig.ss

@@ -100,7 +100,7 @@
 			exploded-imports
 			exploded-exports)
 		       (parse-compound-unit expr (syntax body))]
-		      [(t) (lambda (l) (datum->syntax l expr (quote-syntax here)))])
+		      [(t) (lambda (l) (datum->syntax l expr expr))])
 	   (with-syntax ([(tag ...) (t tags)]
 			 [(uexpr ...) (t exprs)]
 			 [(tagx ...) (t (map (lambda (t) (string->symbol (format "u:~a" t))) tags))]
@@ -137,9 +137,9 @@
 	[(_ u sig ...)
 	 (let ([sigs (parse-invoke-vars 'invoke-unit/sig (syntax (sig ...)) expr)])
 	   (with-syntax ([exploded-sigs (datum->syntax (explode-named-sigs sigs) 
-						       expr (quote-syntax here))]
+						       expr expr)]
 			 [flat-sigs (datum->syntax (flatten-signatures sigs) 
-						   expr (quote-syntax here))])
+						   expr expr)])
 	     (syntax/loc
 	      expr
 	      (let ([unt u])
@@ -156,15 +156,14 @@
     (lambda (expr)
       (syntax-case expr ()
 	[(_ e (im-sig ...) ex-sig)
-	 (let ([e (syntax e)]
-	       [im-sigs (map (lambda (sig)
+	 (let ([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))])
 	   (with-syntax ([exploded-imports (datum->syntax (explode-named-sigs im-sigs)
-							  expr (quote-syntax here))]
+							  expr expr)]
 			 [exploded-exports (datum->syntax (explode-sig ex-sig)
-							  expr (quote-syntax here))])
+							  expr expr)])
 	     (syntax
 	      (make-unit/sig
 	       e