.

original commit: 18323b0c0dc832703cb5b9dfb78acc37f67bf791

collects/mzlib/include.ss

@@ -1,6 +1,7 @@
 
 (module include mzscheme
   (require-for-syntax (lib "stx.ss" "syntax")
+		      (lib "path-spec.ss" "syntax")
 		      "private/increader.ss")
   (require (lib "etc.ss"))
 
@@ -14,13 +15,7 @@
       (syntax-case stx ()
 	[(_ orig-stx ctx loc fn reader)
 	 ;; Parse the file name
-	 (let ([file
+	 (let ([c-file (resolve-path-spec (syntax fn) (syntax loc) (syntax orig-stx) #'build-path)]
-		(syntax-case* (syntax fn) (build-path) module-or-top-identifier=?
-		  [fn
-		   (string? (syntax-e (syntax fn)))
-		   (syntax-e (syntax fn))]
-		  [(build-path elem1 elem ...)
-		   (apply build-path (syntax-object->datum (syntax (elem1 elem ...))))])]
 	       [ctx (syntax ctx)]
 	       [loc (syntax loc)]
 	       [reader (syntax reader)]
@@ -43,87 +38,64 @@
 		"reader is not a procedure of two arguments"
 		orig-stx))
 
-	     ;; Complete the file name
+	     ;; Open the included file
-	     (let ([c-file
+	     (let ([p (with-handlers ([not-break-exn?
-		    (if (complete-path? file)
+				       (lambda (exn)
-			file
+					 (raise-syntax-error
-			(path->complete-path
+					  #f
-			 file
+					  (format
-			 (cond
+					   "can't open include file (~a)"
-			  ;; Src of include expression is a path?
+					   (if (exn? exn)
-			  [(and (string? (syntax-source loc))
+					       (exn-message exn)
-				(complete-path? (syntax-source loc)))
+					       exn))
-			   (let-values ([(base name dir?) 
+					  orig-stx
-					 (split-path (syntax-source loc))])
+					  c-file))])
-			     (if dir?
+			(open-input-file c-file))])
-				 (syntax-source loc)
+	       (port-count-lines! p)
-				 base))]
+	       ;; Read expressions from file
-			  ;; Load relative?
+	       (let ([content
-			  [(current-load-relative-directory)]
+		      (let loop ()
-			  ;; Current directory
+			(let ([r (with-handlers ([not-break-exn?
-			  [(current-directory)]
+						  (lambda (exn)
-			  [else (raise-syntax-error
+						    (raise-syntax-error
-				 #f
+						     #f
-				 "can't determine a base path"
+						     (format
-				 orig-stx)])))])
+						      "read error (~a)"
-	       ;; Open the included file
+						      (if (exn? exn)
-	       (let ([p (with-handlers ([not-break-exn?
+							  (exn-message exn)
-					 (lambda (exn)
+							  exn))
-					   (raise-syntax-error
+						     orig-stx))])
-					    #f
+				   (read-syntax c-file p))])
-					    (format
+			  (if (eof-object? r)
-					     "can't open include file (~a)"
+			      null
-					     (if (exn? exn)
+			      (cons r (loop)))))])
-						 (exn-message exn)
+		 ;; Preserve src info for content, but set its
-						 exn))
+		 ;; lexical context to be that of the include expression
-					    orig-stx
+		 (let ([lexed-content
-					    c-file))])
+			(let loop ([content content])
-			  (open-input-file c-file))])
+			  (cond
-		 (port-count-lines! p)
+			   [(pair? content)
-		 ;; Read expressions from file
+			    (cons (loop (car content))
-		 (let ([content
+				  (loop (cdr content)))]
-			(let loop ()
+			   [(null? content) null]
-			  (let ([r (with-handlers ([not-break-exn?
+			   [else
-						    (lambda (exn)
+			    (let ([v (syntax-e content)])
-						      (raise-syntax-error
+			      (datum->syntax-object
-						       #f
+			       ctx
-						       (format
+			       (cond
-							"read error (~a)"
+				[(pair? v) 
-							(if (exn? exn)
+				 (loop v)]
-							    (exn-message exn)
+				[(vector? v)
-							    exn))
+				 (list->vector (loop (vector->list v)))]
-						       orig-stx))])
+				[(box? v)
-				     (read-syntax c-file p))])
+				 (box (loop (unbox v)))]
-			    (if (eof-object? r)
+				[else
-				null
+				 v])
-				(cons r (loop)))))])
+			       content))]))])
-		   ;; Preserve src info for content, but set its
+		   (datum->syntax-object
-		   ;; lexical context to be that of the include expression
+		    (quote-syntax here)
-		   (let ([lexed-content
+		    `(begin ,@lexed-content)
-			  (let loop ([content content])
+		    orig-stx))))))]))
-			    (cond
-			     [(pair? content)
-			      (cons (loop (car content))
-				    (loop (cdr content)))]
-			     [(null? content) null]
-			     [else
-			      (let ([v (syntax-e content)])
-				(datum->syntax-object
-				 ctx
-				 (cond
-				  [(pair? v) 
-				   (loop v)]
-				  [(vector? v)
-				   (list->vector (loop (vector->list v)))]
-				  [(box? v)
-				   (box (loop (unbox v)))]
-				  [else
-				   v])
-				 content))]))])
-		     (datum->syntax-object
-		      (quote-syntax here)
-		      `(begin ,@lexed-content)
-		      orig-stx)))))))]))
     
     (define (check-fn-form fn stx)
       ;; Check form of fn: