From c198298d257d92e151f6b8badfe74bd6f0c972d3 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 11 Nov 2005 21:28:22 +0000
Subject: [PATCH] req-for-syntax repairs

svn: r1288
---
 collects/compiler/private/driver.ss  | 45 +++++++++++++++-------------
 collects/compiler/private/to-core.ss | 33 ++++++++++++++++----
 2 files changed, 52 insertions(+), 26 deletions(-)

diff --git a/collects/compiler/private/driver.ss b/collects/compiler/private/driver.ss
index a6d2294963..b67cdda912 100644
--- a/collects/compiler/private/driver.ss
+++ b/collects/compiler/private/driver.ss
@@ -638,20 +638,22 @@
 		      [_else (void)]))
 		  
 		  ;;-----------------------------------------------------------------------
-		  ;; ensure that no `module' expression is inside a `begin'
-		  ;;
+		  ;; ensure that no `module', `require', or `require-for-syntax'
+		  ;; expression is inside a `begin'
 
 		  (letrec ([needs-split?
 			    (lambda (stx saw-begin?)
-			      (syntax-case stx (begin module)
+			      (syntax-case stx (begin module require require-for-syntax)
 				[(module . _) saw-begin?]
+				[(require . _) saw-begin?]
+				[(require-for-syntax . _) saw-begin?]
 				[(begin . e)
 				 (ormap (lambda (x) (needs-split? x #t))
 					(syntax->list #'e))]
 				[_else #f]))]
 			   [split
 			    (lambda (stx)
-			      (syntax-case stx (begin module)
+			      (syntax-case stx (begin)
 				[(begin . e)
 				 (apply append (map split (syntax->list #'e)))]
 				[_else (list stx)]))])
@@ -674,25 +676,26 @@
 
 		  (let ([core-thunk
 			 (lambda ()
-			   (let ([sources+bytecodes+magics
-				  (map (lambda (src)
-					 (let-values ([(src bytecode magic-sym)
-						       (top-level-to-core src 
-									  #`'#,zodiac:global-lookup-id
-									  #`'#,zodiac:global-assign-id
-									  #`'#,zodiac:safe-vector-ref-id
-									  #`'#,zodiac:global-prepare-id)])
-					   (list (zodiac:syntax->zodiac src) 
-						 bytecode magic-sym)))
-				       (block-source s:file-block))])
-			     (set-block-source! s:file-block (map car sources+bytecodes+magics))
-			     (set-block-bytecodes! s:file-block 
-						   (parameterize ([current-namespace elaborate-namespace])
+			   (parameterize ([current-namespace elaborate-namespace]
+					  [current-load-relative-directory input-directory])
+			     (let ([sources+bytecodes+magics
+				    (map (lambda (src)
+					   (let-values ([(src bytecode magic-sym)
+							 (top-level-to-core src 
+									    #`'#,zodiac:global-lookup-id
+									    #`'#,zodiac:global-assign-id
+									    #`'#,zodiac:safe-vector-ref-id
+									    #`'#,zodiac:global-prepare-id)])
+					     (list (zodiac:syntax->zodiac src) 
+						   bytecode magic-sym)))
+					 (block-source s:file-block))])
+			       (set-block-source! s:file-block (map car sources+bytecodes+magics))
+			       (set-block-bytecodes! s:file-block 
 						     (map compile
-							  (map cadr sources+bytecodes+magics))))
-			     (set-block-magics! s:file-block (map caddr sources+bytecodes+magics))))])
+							  (map cadr sources+bytecodes+magics)))
+			       (set-block-magics! s:file-block (map caddr sources+bytecodes+magics)))))])
 		    (verbose-time core-thunk))
-	      
+
 		  ;;-----------------------------------------------------------------------
 		  ;; Run a preprocessing phase on the input
 		  ;;
diff --git a/collects/compiler/private/to-core.ss b/collects/compiler/private/to-core.ss
index 98856134eb..bf813c2eda 100644
--- a/collects/compiler/private/to-core.ss
+++ b/collects/compiler/private/to-core.ss
@@ -5,7 +5,12 @@
            (lib "boundmap.ss" "syntax"))
 
   (provide top-level-to-core)
-    
+
+  ;; `module', `require', and `require-for-syntax' declarations must
+  ;;  not be embedded in a `begin' sequence. For `require' and
+  ;;  `require-for-syntax', it's a timing issue. For `module', it's
+  ;;  because the transformation can only handle a single `module'
+  ;;  declaration.
   (define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx)
     (syntax-case stx (module begin)
       [(module m lang (plain-module-begin decl ...))
@@ -154,7 +159,17 @@
                   (filter is-run-time? decls))]
             [ct-rhs #`((let ([magic (car (cons '#,magic-sym 2))])
                          (if (symbol? magic) 
-                             (lambda (x) (make-vector #,(length decls) void))
+                             (lambda (x) (vector
+					  #,@(map (lambda (stx)
+						    (syntax-case stx ()
+						      [(def (id) . _)
+						       #'void]
+						      [(def (id ...) . _)
+						       (with-syntax ([(v ...) (map (lambda (x) #f)
+										   (syntax->list #'(id ...)))])
+							 
+							 #`(lambda () (values v ...)))]))
+						  (filter (lambda (x) (not (is-run-time? x))) decls))))
                              (car magic)))
                        (vector #,@(vars-sequence ct-vars)))]
             [rt-rhs #`((cdr '#,magic-sym) (vector #,@(vars-sequence rt-vars)))]
@@ -184,7 +199,15 @@
                  (lambda (#,run-time)
                    #,@(extract-vars rt-vars run-time extract-stx)
                    (vector #,@rt-converted)))
-         #`(;; Lift define-for-values binding to front, so they can be referenced
+         #`(;; Lift require and require-for-syntaxes to the front, so they're ready for
+	    ;;  variable references
+	    #,@(filter (lambda (decl)
+			 (syntax-case decl (require require-for-syntax)
+			   [(require . _) #t]
+			   [(require-for-syntax . _) #t]
+			   [_else #f]))
+		       decls)
+	    ;; Lift define-for-values binding to front, so they can be referenced
             ;;  in compile-time definition
             #,@(let ([ids (apply
                            append
@@ -212,9 +235,9 @@
                             [(provide . _)
                              (car decls)]
                             [(require . _)
-                             (car decls)]
+                             #'(void)]
                             [(require-for-syntax . _)
-                             (car decls)]
+                             #'(void)]
                             [(require-for-template . _)
                              (car decls)]
                             [(define-values (id ...) rhs)