continuing to work on module paths

compiler.rkt

@@ -147,7 +147,9 @@
           [(PrimitiveKernelValue? exp)
            '()]
           [(VariableReference? exp)
-           (loop (VariableReference-toplevel exp) cenv)])))
+           (loop (VariableReference-toplevel exp) cenv)]
+          [(Require? exp)
+           '()])))
 
 
 
@@ -270,7 +272,9 @@
     [(PrimitiveKernelValue? exp)
      (compile-primitive-kernel-value exp cenv target linkage)]
     [(VariableReference? exp)
-     (compile-variable-reference exp cenv target linkage)]))
+     (compile-variable-reference exp cenv target linkage)]
+    [(Require? exp)
+     (compile-require exp cenv target linkage)]))
 
 
 
@@ -339,6 +343,14 @@
 
 	   after-module-body))))
 
+(: compile-require (Require CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(define (compile-require exp cenv target linkage)
+  (end-with-linkage linkage cenv
+   (append-instruction-sequences
+    (compile-module-invoke (Require-path exp))
+    (make-instruction-sequence
+     `(,(make-AssignImmediateStatement target (make-Const (void))))))))
+
 
 (: compile-module-invoke (ModuleName -> InstructionSequence))
 ;; Generates code that will invoke a module (if it hasn't been invoked yet)
@@ -357,8 +369,9 @@
      ;; TODO: raise an exception here that says that the module hasn't been
      ;; linked yet.
      ,(make-DebugPrint (make-Const 
-		        (format "DEBUG: the module ~a hasn't been linked in yet!"
+		        (format "DEBUG: the module ~a hasn't been linked in!!!"
 				(ModuleName-name a-module-name))))
+     ,(make-GotoStatement (make-Label already-loaded))
      ,linked
      ,(make-TestAndBranchStatement (make-TestTrue 
 				    (make-IsModuleInvoked a-module-name))
@@ -2233,4 +2246,6 @@
     [(VariableReference? exp)
      (make-VariableReference 
       (ensure-toplevelref
-       (adjust-expression-depth (VariableReference-toplevel exp) n skip)))]))
+       (adjust-expression-depth (VariableReference-toplevel exp) n skip)))]
+    [(Require? exp)
+     exp]))

expression-structs.rkt

@@ -29,7 +29,9 @@
                          DefValues
                          PrimitiveKernelValue
                          Module
-                         VariableReference))
+                         VariableReference
+                         Require))
+
 
 
 (define-struct: Provided ([name : Symbol]
@@ -87,7 +89,7 @@
 
 ;; We may have more information about the lambda's name.  This will show it.
 (define-struct: LamPositionalName ([name : Symbol] 
-                                   [path : String] 
+                                   [path : String]    ;; the source of the name
                                    [line : Natural] 
                                    [column : Natural] 
                                    [offset : Natural] 
@@ -147,7 +149,7 @@
 (define-struct: VariableReference ([toplevel : ToplevelRef]) #:transparent)
 
 
-
+(define-struct: Require ([path : ModuleName]) #:transparent)
 
 
 

lexical-structs.rkt

@@ -17,7 +17,8 @@
 
 
 ;; A ModuleName is an identifier for a Module.
-(define-struct: ModuleName ([name : Symbol])
+(define-struct: ModuleName ([name : Symbol]
+                            [real-path : (U Symbol Path)])
   #:transparent)
 
 

parse-bytecode-5.1.1.rkt

@@ -7,13 +7,16 @@
          syntax/modresolve)
 
 
-;; Parsing Racket 5.1.1 bytecode structures into our own.
+;; Parsing Racket 5.1.1 bytecode structures into our own structures.
+
 (require compiler/zo-parse
          racket/match
          racket/list)
 
+
 (provide parse-bytecode
-         current-module-path-index-resolver
+         ;current-module-path-index-resolver
+         ;current-module-path-resolver
          current-module-path
          reset-lam-label-counter!/unit-testing)
 
@@ -33,6 +36,13 @@
         (resolve-module-path-index mpi relative-to)]))))
 
 
+(define current-module-path-resolver 
+  (make-parameter 
+   (lambda (module-path relative-to)
+     (resolve-module-path module-path relative-to))))
+
+
+
 (define (self-module-path-index? mpi)
   (let-values ([(x y) (module-path-index-split mpi)])
     (and (eq? x #f)
@@ -150,9 +160,16 @@
 (define (wrap-module-name resolved-path-name)
   (cond
     [(symbol? resolved-path-name)
-     (make-ModuleName resolved-path-name)]
+     (make-ModuleName resolved-path-name resolved-path-name)]
     [(path? resolved-path-name)
-     (make-ModuleName (rewrite-path resolved-path-name))]))
+     (let ([rewritten-path (rewrite-path resolved-path-name)])
+       (cond
+         [(symbol? rewritten-path)
+          (make-ModuleName (rewrite-path resolved-path-name) resolved-path-name)]
+         [else
+          (error 'wrap-module-name "Unable to resolve module path ~s" resolved-path-name)]))]))
+          
+       
 
 
 
@@ -199,8 +216,53 @@
   (make-Constant (void)))
 
 
+
 (define (parse-req form)
-  (error 'fixme-req))
+  (let ([resolver (current-module-path-resolver)])
+    (match form
+      [(struct req (reqs dummy))
+       (let ([require-statement (parse-req-reqs reqs)])
+         (match require-statement
+           [(list '#%require (and (? module-path?) path))
+            (let ([resolved-path ((current-module-path-resolver) path (current-module-path))])
+              (cond
+                [(symbol? resolved-path)
+                 (make-Require (make-ModuleName resolved-path resolved-path))]
+                [(path? resolved-path)
+                 (let ([rewritten-path (rewrite-path resolved-path)])
+                   (cond
+                     [(symbol? rewritten-path)
+                      (make-Require (make-ModuleName rewritten-path resolved-path))]
+                     [else
+                      (printf "Internal error: I don't know how to handle the require for ~s" require-statement)
+                      (error 'parse-req)]))]
+                [else
+                 (printf "Internal error: I don't know how to handle the require for ~s" require-statement)
+                 (error 'parse-req)]))]
+           [else
+            (printf "Internal error: I don't know how to handle the require for ~s" require-statement)
+            (error 'parse-req)]))])))
+     
+;; parse-req-reqs: (stx -> (listof ModuleName))
+(define (parse-req-reqs reqs)
+  (match reqs
+    [(struct stx (encoded))
+     (unwrap-wrapped encoded)]))
+
+(define (unwrap-wrapped encoded)
+  (cond [(wrapped? encoded)
+         (match encoded 
+           [(struct wrapped (datum wraps certs))
+            (unwrap-wrapped datum)])]
+        [(pair? encoded)
+         (cons (unwrap-wrapped (car encoded))
+               (unwrap-wrapped (cdr encoded)))]
+        [(null? encoded)
+         null]
+        [else
+         encoded]))
+
+
 
 
 ;; parse-seq: seq -> Expression
@@ -209,6 +271,7 @@
     [(struct seq (forms))
      (make-Seq (map parse-form-item forms))]))
 
+
 ;; parse-form-item: (U form Any) -> Expression
 (define (parse-form-item item)
   (cond
@@ -247,18 +310,23 @@
        (cond
         [(symbol? self-path)
          (make-Module name
-                      (make-ModuleName self-path)
+                      (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)])
+           (cond
+             [(symbol? rewritten-path)
               (make-Module name
-                      (make-ModuleName (rewrite-path self-path))
+                           (make-ModuleName rewritten-path self-path)
                            (parse-prefix prefix)
                            (parse-mod-requires self-modidx requires)
                            (parse-mod-provides provides)
-                      (parse-mod-body body))]))]))
+                           (parse-mod-body body))]
+             [else
+              (error 'parse-mod "Internal error: unable to resolve module path ~s" self-path)]))]))]))
 
 
 ;; parse-mod-requires: module-path-index (listof (pair (U Integer #f) (listof module-path-index))) -> (listof ModuleName)
@@ -411,14 +479,30 @@
     [(vector? name)
      (match name
        [(vector (and (? symbol?) sym)
-                (and (? path?) path) 
+                (and (? path?) source) 
+                (and (? number?) line)
+                (and (? number?) column)
+                (and (? number?) offset)
+                (and (? number?) span)
+                _)
+        (let ([try-to-rewrite (rewrite-path source)])
+          (make-LamPositionalName sym
+                                  (if try-to-rewrite
+                                      (symbol->string try-to-rewrite)
+                                      (path->string source))
+                                  line
+                                  column 
+                                  offset
+                                  span))]
+       [(vector (and (? symbol?) sym)
+                (and (? symbol?) source) 
                 (and (? number?) line)
                 (and (? number?) column)
                 (and (? number?) offset)
                 (and (? number?) span)
                 _)
         (make-LamPositionalName sym
-                                (path->string path)
+                                (symbol->string source)
                                 line
                                 column 
                                 offset
@@ -509,6 +593,8 @@
 
 
 (define (parse-topsyntax expr)
+  ;; We should not get into this because we're only parsing the runtime part of
+  ;; the bytecode.
   (error 'fixme-topsyntax))
 
 

parse.rkt

@@ -52,7 +52,7 @@
     [(current-language)
      => (lambda (lang)
           (if (member sym lang)
-              (make-ModuleVariable sym (make-ModuleName '#%kernel))
+              (make-ModuleVariable sym (make-ModuleName '#%kernel '#%kernel))
               #f))]
     [else
      #f]))

path-rewriter.rkt

@@ -26,18 +26,14 @@
 
 
 ;; The path rewriter takes paths and provides a canonical symbol for it.
-;; Paths located within collects get remapped to collects/....
+;; Paths located within collects get remapped to collects, those within
-
+;; the compiler directory mapped to "js-vm", those within the root to "root".
+;; If none of these work, we return #f.
 
 ;; rewrite-path: path -> (symbol #f)
 (define (rewrite-path a-path)
   (let ([a-path (normalize-path a-path)])
     (cond
-     [(within-root? a-path)
-      (string->symbol
-       (string-append "root/"
-                      (path->string
-                       (find-relative-path (current-root-path) a-path))))]
      [(within-collects? a-path)
       (string->symbol
        (string-append "collects/"
@@ -48,6 +44,11 @@
        (string-append "js-vm/"
                       (path->string
                        (find-relative-path this-normal-path a-path))))]
+     [(within-root? a-path)
+      (string->symbol
+       (string-append "root/"
+                      (path->string
+                       (find-relative-path (current-root-path) a-path))))]
      [else 
       #f])))
 

test-parse-bytecode-5.1.1.rkt

@@ -377,21 +377,18 @@
  (run-my-parse #'(case-lambda [(x) x]
                               [(x y) (list x y)])))
 
-
+(void
-;; make sure we don't see an infinite loop
+ (run-my-parse #'(letrec ([g (lambda () (g))])
-#;(run-zo-parse #'(letrec ([g (lambda () (g))])
+                   (g))))
-                  (g)))
-(run-my-parse #'(letrec ([g (lambda () (g))])
-                        (g)))
-;; todo: add tests to make sure we're parsing this as expected.  We expect to see an EmptyClosureReference here.
 
 
-#;(run-zo-parse #'(letrec ([g (lambda () (h))]
-                           [h (lambda () (g))])
-                    (g)))
-;; FIXME: we need to handle closure cycles here.
 
 
+(void
+ (run-my-parse #'(letrec ([g (case-lambda [() (g)]
+                                          [(x y) (g x y)])])
+                   (g))))
+
 
 
 

test-parse.rkt

@@ -208,7 +208,7 @@
                           'lamEntry2)))
 
 (test (parse '(+ x x))
-      (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel))
+      (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel '#%kernel))
                                x))
                 (make-App (make-ToplevelRef 2 0)
                           (list (make-ToplevelRef 2 1)
@@ -216,7 +216,7 @@
   
 
 (test (parse '(lambda (x) (+ x x)))
-      (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel))))
+      (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel '#%kernel))))
                 (make-Lam 'unknown 1 #f
                           (make-App (make-ToplevelRef 2 0)
                                     (list (make-LocalRef 3 #f)
@@ -226,8 +226,8 @@
 
 (test (parse '(lambda (x) 
                 (+ (* x x) x)))
-      (make-Top (make-Prefix `(,(make-ModuleVariable '* (make-ModuleName '#%kernel))
+      (make-Top (make-Prefix `(,(make-ModuleVariable '* (make-ModuleName '#%kernel '#%kernel))
-                               ,(make-ModuleVariable '+ (make-ModuleName '#%kernel))))
+                               ,(make-ModuleVariable '+ (make-ModuleName '#%kernel '#%kernel))))
                 (make-Lam 'unknown 1 #f
                           ;; stack layout: [???, ???, prefix, x]
                           (make-App (make-ToplevelRef 2 1)
@@ -286,7 +286,7 @@
 (test (parse '(let* ([x 3]
                      [x (add1 x)])
                 (add1 x)))
-      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel))))
+      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel '#%kernel))))
                 
                 ;; stack layout: [prefix]
                 
@@ -415,7 +415,7 @@
 (test (parse '(let ([x 0])
                 (lambda ()
                   (set! x (add1 x)))))
-      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel))))
+      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel '#%kernel))))
                 (make-Let1 (make-Constant 0)
                            (make-BoxEnv 0
                                         (make-Lam 'unknown 0 #f
@@ -434,7 +434,7 @@
                     [y 1])
                 (lambda ()
                   (set! x (add1 x)))))
-      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel))))
+      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel '#%kernel))))
                 (make-LetVoid 2
                               (make-Seq (list
                                          (make-InstallValue 1 0 (make-Constant 0) #t)
@@ -462,7 +462,7 @@
                      (reset!)
                      (list a b)))
       (make-Top
-       (make-Prefix `(a b ,(make-ModuleVariable 'list (make-ModuleName '#%kernel)) reset!))
+       (make-Prefix `(a b ,(make-ModuleVariable 'list (make-ModuleName '#%kernel '#%kernel)) reset!))
        (make-Splice
         (list
          (make-ToplevelSet 0 0 (make-Constant '(hello)))