working on parse-bytecode

parse-bytecode-5.1.1.rkt

@@ -9,10 +9,28 @@
          racket/match
          racket/list)
 
-(provide parse-bytecode)
+(provide parse-bytecode
+         current-module-path-index-resolver)
 
 
+;; The module-path-index of self is:
+(define self-idx (module-path-index-join #f #f))
 
+(define (self-idx? mpi)
+  (let-values ([(path subpath)
+                (module-path-index-split mpi)])
+    (eq? path #f)))
+
+
+;; current-module-path-index-resolver: (module-path-index -> ModuleName) -> void
+;; The module path index resolver figures out how to translate module path indices to module names.
+(define current-module-path-index-resolver 
+  (make-parameter 
+   (lambda (an-mpi)
+     (error 'current-module-path-index-resolver))))
+
+
+;; parse-bytecode: Input-Port -> Expression
 (define (parse-bytecode in)
   (let ([compilation-top (zo-parse in)])
     (parse-top compilation-top)))
@@ -21,7 +39,8 @@
 (define (parse-top a-top)
   (match a-top
     [(struct compilation-top (max-let-depth prefix code))
-     (make-Top (parse-prefix prefix) (parse-top-code code))]))
+     (make-Top (parse-prefix prefix) 
+               (parse-top-code code))]))
 
 
 (define (parse-prefix a-prefix)
@@ -56,9 +75,9 @@
     [(global-bucket? a-toplevel)
      (make-GlobalBucket (global-bucket-name a-toplevel))]
     [(module-variable? a-toplevel)
-     (make-ModuleVariable 
-      ;; fixme: we need to remember more than just the name of the symbol!
-      (module-variable-sym a-toplevel))]))
+     (let ([resolver (current-module-path-index-resolver)])
+       (make-ModuleVariable (module-variable-sym a-toplevel)
+                            (resolver self-idx (module-variable-modidx a-toplevel))))]))
 
 
 ;; parse-form: form -> (U Expression)
@@ -68,8 +87,7 @@
      (parse-def-values a-form)]
 
     [(def-syntaxes? a-form)
-     ;; Ignore def-syntaxes.
-     (parse-def-syntaxes? a-form)]
+     (parse-def-syntaxes a-form)]
     
     [(req? a-form)
      (parse-req a-form)]
@@ -90,20 +108,125 @@
      (error 'parse-form "~s" a-form)]))
 
 
+;; parse-def-values: def-values -> Expression
 (define (parse-def-values form)
-  (error 'fixme))
+  (match form 
+    [(struct def-values (ids rhs))
+     (make-DefValues (map parse-toplevel ids)
+                     (parse-def-values-body rhs))]))
+
+;; parse-def-values-body: (U expr seq Any) -> Expression
+(define (parse-def-values-body rhs)
+  (cond
+    [(expr? rhs)
+     (parse-expr rhs)]
+    [(seq? rhs)
+     (parse-seq rhs)]
+    [else
+     (make-Constant rhs)]))
+
+
+
 (define (parse-def-syntaxes form)
-  (error 'fixme))
+  ;; Currently, treat def-syntaxes as a no-op.  The compiler will not produce
+  ;; syntax transformers.
+  (make-Constant (void)))
+
+
 (define (parse-req form)
   (error 'fixme))
-(define (parse-seq form)
-  (error 'fixme))
-(define (parse-splice form)
-  (error 'fixme))
-(define (parse-mod form)
-  (error 'fixme))
 
 
+;; parse-seq: seq -> Expression
+(define (parse-seq form)
+  (match form
+    [(struct seq (forms))
+     (make-Seq (map parse-form-item forms))]))
+
+;; parse-form-item: (U form Any) -> Expression
+(define (parse-form-item item)
+  (cond
+    [(form? item)
+     (parse-form item)]
+    [else
+     (make-Constant item)]))
+
+
+;; parse-splice: splice -> Expression
+(define (parse-splice form)
+  (match form
+    [(struct splice (forms))
+     (make-Splice (map parse-splice-item forms))]))
+
+
+;; parse-splice-item: (U form Any) -> Expression
+(define (parse-splice-item item)
+  (cond
+    [(form? item)
+     (parse-form item)]
+    [else
+     (make-Constant item)]))
+
+
+;; parse-mod: mod -> Expression
+(define (parse-mod form)
+  (match form
+    [(struct mod (name srcname self-modidx prefix provides requires
+       body syntax-body unexported max-let-depth dummy lang-info
+       internal-context))
+     (let ([resolver (current-module-path-index-resolver)])
+       (make-Module (make-ModuleName name)
+                    (parse-prefix prefix)
+                    (parse-mod-requires self-modidx requires)
+                    (parse-mod-provides provides)
+                    (parse-mod-body body)))]))
+
+
+;; parse-mod-requires: module-path-index (listof (pair (U Integer #f) (listof module-path-index))) -> (listof ModuleName)
+(define (parse-mod-requires enclosing-module-path-index requires)
+  ;; We only care about phase 0 --- the runtime.
+  (let ([resolver (current-module-path-index-resolver)])
+    (let loop ([requires requires])
+      (cond
+        [(empty? requires)
+         empty]
+        [(= (car (first requires))
+              0)
+         (map (lambda (m) (resolver enclosing-module-path-index m))
+              (cdr (first requires)))]
+        [else
+         (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)
+         (parse-provided (second (first provides)))]
+        [else
+         (loop (rest provides))]))))
+
+
+
+
+;; parse-mod-body: (listof (or/c form? any/c))
+(define (parse-mod-body body)
+  (let ([parse-item (lambda (item)
+                      (cond
+                        [(form? item)
+                         (parse-form item)]
+                        [else
+                         (make-Constant item)]))])
+  (make-splice (map parse-item body))))
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -149,40 +272,79 @@
      (parse-primval expr)]))
 
 (define (parse-lam expr)
-  (error 'fixme))
+  (match expr
+    [(struct lam (name flags num-params rest? closure-map closure-types max-let-depth body))
+     (let ([lam-name (cond
+                       [(symbol? name)
+                        name]
+                       [(vector? name)
+                        ...]
+                       [else
+                        (error
+     (make-Lam 
+     ...]))
+
+(define (parse-lam-body body)
+  (cond
+    [(expr? body)
+     (parse-expr body)]
+    [(seq? body)
+     (parse-seq body)]
+    [else
+     (make-Constant body)]))
+
+
+
 (define (parse-closure expr)
   (error 'fixme))
+
 (define (parse-case-lam exp)
   (error 'fixme))
+
 (define (parse-let-one expr)
   (error 'fixme))
+
 (define (parse-let-void expr)
   (error 'fixme))
+
 (define (parse-install-value expr)
   (error 'fixme))
+
 (define (parse-let-rec expr)
   (error 'fixme))
+
 (define (parse-boxenv expr)
   (error 'fixme))
+
 (define (parse-localref expr)
   (error 'fixme))
+
 (define (parse-toplevel expr)
   (error 'fixme))
+
 (define (parse-topsyntax expr)
   (error 'fixme))
+
 (define (parse-application expr)
   (error 'fixme))
+
 (define (parse-branch expr)
   (error 'fixme))
+
 (define (parse-with-cont-mark expr)
   (error 'fixme))
+
 (define (parse-beg0 expr)
   (error 'fixme))
+
 (define (parse-varref expr)
   (error 'fixme))
+
 (define (parse-assign expr)
   (error 'fixme))
+
 (define (parse-apply-values expr)
   (error 'fixme))
+
 (define (parse-primval expr)
   (error 'fixme))