From d3e4d224726dd482879b506f2fc380c04186b3f7 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 30 Oct 2001 04:07:45 +0000
Subject: [PATCH] .

original commit: 0f289e6be219405304897fa8a2e8f57b51a9a481
---
 collects/mzlib/include.ss | 72 +++++++++++++++++++++++++++------------
 1 file changed, 50 insertions(+), 22 deletions(-)

diff --git a/collects/mzlib/include.ss b/collects/mzlib/include.ss
index 5a68ea1..ff4bba9 100644
--- a/collects/mzlib/include.ss
+++ b/collects/mzlib/include.ss
@@ -2,24 +2,27 @@
 (module include mzscheme
   (require-for-syntax (lib "stx.ss" "syntax"))
 
-  (define-syntax include
+  (define-syntax include-at/relative-to
     (lambda (stx)
       ;; Parse the file name
-      (let ([file
-	     (syntax-case* stx (build-path) module-or-top-identifier=?
-	       [(_ fn)
-		(string? (syntax-e (syntax fn)))
-		(syntax-e (syntax fn))]
-	       [(_ (build-path elem1 elem ...))
-		(andmap
-		 (lambda (e)
-		   (or (string? (syntax-e e))
-		       (and (identifier? e)
-			    (or
-			     (module-identifier=? e (quote-syntax up))
-			     (module-identifier=? e (quote-syntax same))))))
-		 (syntax->list (syntax (elem1 elem ...))))
-		(apply build-path (syntax-object->datum (syntax (elem1 elem ...))))])])
+      (let-values ([(ctx loc file)
+		    (syntax-case* stx (build-path) module-or-top-identifier=?
+		      [(_ ctx loc fn)
+		       (string? (syntax-e (syntax fn)))
+		       (values (syntax ctx) (syntax loc) (syntax-e (syntax fn)))]
+		      [(_ ctx loc (build-path elem1 elem ...))
+		       (andmap
+			(lambda (e)
+			  (or (string? (syntax-e e))
+			      (and (identifier? e)
+				   (or
+				    (module-identifier=? e (quote-syntax up))
+				    (module-identifier=? e (quote-syntax same))))))
+			(syntax->list (syntax (elem1 elem ...))))
+		       (values 
+			(syntax ctx)
+			(syntax loc)
+			(apply build-path (syntax-object->datum (syntax (elem1 elem ...)))))])])
 	;; Complete the file name
 	(let ([c-file
 	       (if (complete-path? file)
@@ -28,12 +31,12 @@
 		    file
 		    (cond
 		     ;; Src of include expression is a path?
-		     [(and (string? (syntax-source stx))
-			   (complete-path? (syntax-source stx)))
+		     [(and (string? (syntax-source loc))
+			   (complete-path? (syntax-source loc)))
 		      (let-values ([(base name dir?) 
-				    (split-path (syntax-source stx))])
+				    (split-path (syntax-source loc))])
 			(if dir?
-			    (syntax-source stx)
+			    (syntax-source loc)
 			    base))]
 		     ;; Load relative?
 		     [(current-load-relative-directory)]
@@ -86,7 +89,7 @@
 			[else
 			 (let ([v (syntax-e content)])
 			   (datum->syntax-object
-			    stx
+			    ctx
 			    (cond
 			     [(pair? v) 
 			      (loop v)]
@@ -102,7 +105,32 @@
 		 `(begin ,@lexed-content)
 		 stx))))))))
 
-  (provide include))
+  (define-syntax include
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ fn)
+	 ;; Check form of fn:
+	 (syntax-case* (syntax fn) (build-path) module-or-top-identifier=?
+	   [fn
+	    (string? (syntax-e (syntax fn)))
+	    'ok]
+	   [(build-path elem1 elem ...)
+	    (andmap
+	     (lambda (e)
+	       (or (string? (syntax-e e))
+		   (and (identifier? e)
+			(or
+			 (module-identifier=? e (quote-syntax up))
+			 (module-identifier=? e (quote-syntax same))))))
+	     (syntax->list (syntax (elem1 elem ...))))
+	    'ok]
+	   [_else (raise-syntax-error #f "bad syntax" stx (syntax fn))])
+	 ;; Expand to include-at/relative-to:
+	 (with-syntax ([_stx stx])
+	   (syntax/loc stx (include-at/relative-to _stx _stx fn)))])))
+  
+  (provide include
+	   include-at/relative-to))