ripping out provides, since we don't need it.

compiler.rkt

@@ -6,6 +6,7 @@
          "compiler-structs.rkt"
          "kernel-primitives.rkt"
          "optimize-il.rkt"
+         racket/match
          racket/bool
          racket/list)
 
@@ -308,40 +309,44 @@
   ;; fixme: this is not right yet.  This should instead install a module record
   ;; that has not yet been invoked.
   ;; fixme: This also needs to generate code for the requires and provides.
-  (let*: ([after-module-body (make-label 'afterModuleBody)]
+  (match mod
-	  [module-entry (make-label 'module-entry)]
+    [(struct Module (name path prefix requires code))
-	  [names : (Listof (U False Symbol GlobalBucket ModuleVariable))
+     (let*: ([after-module-body (make-label 'afterModuleBody)]
-                 (Prefix-names (Module-prefix mod))]
+             [module-entry (make-label 'module-entry)]
-	  [module-cenv : CompileTimeEnvironment (list (Module-prefix mod))])
+             [names : (Listof (U False Symbol GlobalBucket ModuleVariable))
+                    (Prefix-names prefix)]
+             [module-cenv : CompileTimeEnvironment (list prefix)])
             
-         (end-with-linkage 
+            (end-with-linkage 
-          linkage cenv
+             linkage cenv
-          (append-instruction-sequences
+             (append-instruction-sequences
-           (make-instruction-sequence
+              (make-instruction-sequence
-	    `(,(make-GotoStatement (make-Label after-module-body))))
+               `(,(make-PerformStatement (make-InstallModuleEntry! name path module-entry))
+                 ,(make-GotoStatement (make-Label after-module-body))))
               
-	   ;; Module body definition
-	   (apply append-instruction-sequences 
-		  (map compile-module-invoke (Module-requires mod)))
               
-	   (make-instruction-sequence 
+              module-entry
-            `(,module-entry
+              ;; Module body definition:
-	      ,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
+              ;; 1.  First invoke all the modules that this requires.
-	   ;; TODO: we need to sequester the prefix of the module with the record.
+              (apply append-instruction-sequences (map compile-module-invoke (Module-requires mod)))
-           (compile (Module-code mod) 
-                    (cons (Module-prefix mod) module-cenv)
-                    target
-                    next-linkage/drop-multiple)
            
-	   ;; Cleanup
+              ;; 2.  Next, evaluate the module body.
-           (make-instruction-sequence
+              (make-instruction-sequence 
-            `(,(make-PopEnvironment (make-Const 1) 
+               `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
-                                    (make-Const 0))
+              ;; TODO: we need to sequester the prefix of the module with the record.
-	      ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
+              (compile (Module-code mod) 
-	      ,(make-PopControlFrame)
+                       (cons (Module-prefix mod) module-cenv)
-	      ,(make-GotoStatement (make-Reg 'proc))))
+                       'val
+                       next-linkage/drop-multiple)
               
-	   after-module-body))))
+              ;; 3. Finally, cleanup and return.
+              (make-instruction-sequence
+               `(,(make-PopEnvironment (make-Const 1) (make-Const 0))
+                 ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
+                 ,(make-PopControlFrame)
+                 ,(make-GotoStatement (make-Reg 'proc))))
+              
+              after-module-body)))]))
 
 (: compile-require (Require CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-require exp cenv target linkage)
@@ -2097,7 +2102,6 @@
                   (Module-path exp)
                   (Module-prefix exp)
                   (Module-requires exp)
-                  (Module-provides exp)
                   (adjust-expression-depth (Module-code exp) n (add1 skip)))]
     
     [(Constant? exp)

expression-structs.rkt

@@ -33,16 +33,10 @@
                          Require))
 
 
-
-(define-struct: Provided ([name : Symbol]
-                          [src-name : Symbol])
-  #:transparent)
-
 (define-struct: Module ([name : Symbol]
                         [path : ModuleName]
                         [prefix : Prefix]
                         [requires : (Listof ModuleName)]
-                        [provides : (Listof Provided)]
                         [code : Expression])
   #:transparent)
 

parameters.rkt

@@ -1,7 +1,19 @@
 #lang typed/racket/base
 
-(require "expression-structs.rkt")
+(require "expression-structs.rkt"
-(provide current-defined-name)
+         racket/path)
+(provide current-defined-name
+         current-module-path
+         current-root-path)
 
 (: current-defined-name (Parameterof (U Symbol LamPositionalName)))
 (define current-defined-name (make-parameter 'unknown))
+
+
+(: current-module-path (Parameterof (U False Path)))
+(define current-module-path (make-parameter #f))
+
+
+(: current-root-path (Parameterof Path))
+(define current-root-path
+  (make-parameter (normalize-path (current-directory))))

parse-bytecode-5.1.1.rkt

@@ -4,6 +4,7 @@
          "lexical-structs.rkt"
          "typed-module-path.rkt"
          "path-rewriter.rkt"
+         "parameters.rkt"
          syntax/modresolve)
 
 
@@ -15,14 +16,10 @@
 
 
 (provide parse-bytecode
-         ;current-module-path-index-resolver
+         parse-bytecode/single-module
-         ;current-module-path-resolver
-         current-module-path
          reset-lam-label-counter!/unit-testing)
 
 
-(define current-module-path (make-parameter #f))
-
 
 ;; current-module-path-index-resolver: (module-path-index (U Path #f) -> (U Symbol Path)) -> void
 ;; The module path index resolver figures out how to translate module path indices to module names.
@@ -30,6 +27,8 @@
   (make-parameter 
    (lambda (mpi relative-to)
      (cond
+       [(eq? mpi #f)
+        'self]
        [(self-module-path-index? mpi)
         'self]
        [else
@@ -112,6 +111,29 @@
       (parse-top compilation-top))))
 
 
+
+;; Similar to parse-bytecode, but does a little cleanup to make
+;; sure the name is as expected.
+(define (parse-bytecode/single-module in path-name)
+  (let ([parsed (parse-bytecode in)])
+    (match parsed
+      [(struct Top 
+         (prefix 
+          (struct Module (name (struct ModuleName ('self 'self))
+                               prefix 
+                               requires
+                               body))))
+       (make-Top prefix
+                 (make-Module name 
+                              (make-ModuleName path-name 'self)
+                              prefix
+                              requires
+                              body))])))
+         
+
+
+
+
 (define (parse-top a-top)
   (match a-top
     [(struct compilation-top (max-let-depth prefix code))
@@ -313,7 +335,6 @@
                       (make-ModuleName self-path self-path)
                       (parse-prefix prefix)
                       (parse-mod-requires self-modidx requires)
-                      (parse-mod-provides provides)
                       (parse-mod-body body))]
         [else
          (let ([rewritten-path (rewrite-path self-path)])
@@ -323,7 +344,6 @@
                            (make-ModuleName rewritten-path self-path)
                            (parse-prefix prefix)
                            (parse-mod-requires self-modidx requires)
-                           (parse-mod-provides provides)
                            (parse-mod-body body))]
              [else
               (error 'parse-mod "Internal error: unable to resolve module path ~s" self-path)]))]))]))
@@ -351,21 +371,6 @@
          (loop (rest requires))]))))
 
 
-(define (parse-mod-provides provides)
-  (let* ([resolver (current-module-path-index-resolver)]
-         [parse-provided (lambda (a-provided)
-                           (match a-provided
-                             [(struct provided (name src src-name nom-mod src-phase protected? insp))
-                              ;; fixme: we're not considering all of the fields here...
-                              (make-Provided name src-name)]))])
-    (let loop ([provides provides])
-      (cond
-        [(empty? provides)
-         empty]
-        [(= (first (first provides)) 0)
-         (map parse-provided (second (first provides)))]
-        [else
-         (loop (rest provides))]))))
 
 
 

path-rewriter.rkt

@@ -1,16 +1,14 @@
 #lang racket/base
 
-(require racket/path
+(require "parameters.rkt"
+         racket/path
          racket/contract
          racket/list
          racket/runtime-path)
 
 
 
-(provide/contract [rewrite-path (complete-path? . -> . (or/c symbol? false/c))]
+(provide/contract [rewrite-path (complete-path? . -> . (or/c symbol? false/c))])
-                  [current-root-path parameter?])
-
-
 
 
 
@@ -21,9 +19,6 @@
 
 
 
-(define current-root-path
-  (make-parameter (normalize-path (current-directory))))
-
 
 ;; The path rewriter takes paths and provides a canonical symbol for it.
 ;; Paths located within collects get remapped to collects, those within

test-parse-bytecode-5.1.1.rkt

@@ -4,6 +4,7 @@
          rackunit
          racket/match
          (for-syntax racket/base)
+         "parameters.rkt"
          "parse-bytecode-5.1.1.rkt"
          "lexical-structs.rkt"
          "expression-structs.rkt")
@@ -335,7 +336,6 @@
                                  (? ModuleName?)
                                  (? Prefix?) ;; the prefix will include a reference to print-values.
                                  _  ;; requires
-                                 _  ;; provides
                                  (struct Splice ((list (struct ApplyValues 
                                                          ((struct ToplevelRef ('0 '0)) (struct Constant ('42)))))))))))
     #t]))
@@ -350,7 +350,6 @@
                                  (? ModuleName?)
                                  (? Prefix?) ;; the prefix will include a reference to print-values.
                                  _  ;; requires
-                                 (list (struct Provided ('x 'x)))  ;; provides
                                  (struct Splice ((list (struct DefValues 
                                                          ((list (struct ToplevelRef ('0 '0)))
                                                           (struct Constant ("x")))))))))))
@@ -391,9 +390,26 @@
 
 
 
+(void
+ (run-my-parse #'(module foo '#%kernel
+                   (define-values (f) 42)
+                   (#%provide f))))
               
 
-
+(check-true
+ (match (parameterize ([current-root-path (build-path "/blah")]
+                       [current-module-path (build-path "/blah" "foo" "bar.rkt")])
+                (run-my-parse '(module foo '#%kernel
+                                 (define-values (f) 'ok)
+                                 (#%provide f))))
+   [(struct Top ((struct Prefix ((list '#f)))
+                 (struct Module ('foo
+                                 (struct ModuleName ('self _ #;(build-path "root/foo/bar.rkt")))
+                                 (struct Prefix ((list 'f)))
+                                 (list (struct ModuleName ('#%kernel '#%kernel)))
+                                 (struct Splice ((list (struct DefValues ((list (struct ToplevelRef (0 0)))
+                                                                          (struct Constant ('ok)))))))))))
+    '#t]))
  
  
 #;(parameterize ([current-module-path