in the middle of making the expressions close to the racket machine

expression-structs.rkt

@@ -5,33 +5,48 @@
 
 ;; Expressions
 
-(define-type ExpressionCore (U Top Constant Var Branch Def Lam Seq App
+(define-type ExpressionCore (U Top Constant 
+                               ToplevelRef LocalRef
+                               SetToplevel
+                               Branch Lam Seq App
                                Let1 Let LetRec))
 
 (define-struct: Top ([prefix : Prefix]
                      [code : ExpressionCore]) #:transparent)
+
 (define-struct: Constant ([v : Any]) #:transparent)
-(define-struct: Var ([id : Symbol]) #:transparent)
+
+(define-struct: ToplevelRef ([depth : Natural]
+                             [pos : Natural])
+  #:transparent)
+
+(define-struct: LocalRef ([depth : Natural])
+  #:transparent)
+
+(define-struct: SetToplevel ([depth : Natural]
+                             [pos : Natural]
+                             [name : Symbol] 
+                             [value : ExpressionCore]) #:transparent)
+
 (define-struct: Branch ([predicate : ExpressionCore]
                         [consequent : ExpressionCore]
                         [alternative : ExpressionCore]) #:transparent)
-(define-struct: Def ([variable : Symbol] 
+
-                     [value : ExpressionCore]) #:transparent)
+(define-struct: Lam ([num-parameters : Natural]
-(define-struct: Lam ([parameters : (Listof Symbol)]
                      [body : ExpressionCore]) #:transparent)
+
 (define-struct: Seq ([actions : (Listof ExpressionCore)]) #:transparent)
 (define-struct: App ([operator : ExpressionCore]
                      [operands : (Listof ExpressionCore)]) #:transparent)
 
-(define-struct: Let1 ([name : Symbol]
+(define-struct: Let1 ([rhs : ExpressionCore ]
-                      [rhs : ExpressionCore ]
                       [body : ExpressionCore])
   #:transparent)
-(define-struct: Let ([names : (Listof Symbol)]
+(define-struct: Let ([count : Natural]
                      [rhss : (Listof ExpressionCore)]
                      [body : ExpressionCore])
   #:transparent)
-(define-struct: LetRec ([names : (Listof Symbol)]
+(define-struct: LetRec ([count : Natural]
                         [rhss : (Listof ExpressionCore)]
                         [body : ExpressionCore])
   #:transparent)
@@ -48,8 +63,4 @@
 (define (rest-exps seq) (cdr seq))
 
 
-
+(define-type Expression (U ExpressionCore))
-
-(define-struct: Assign ([variable : Symbol]
-                        [value : Expression]) #:transparent)
-(define-type Expression (U ExpressionCore #;Assign))

lexical-env.rkt

@@ -13,9 +13,8 @@
          place-prefix-mask)
 
 
-;; find-variable: symbol compile-time-environment -> lexical-address
+;; Find where the variable is located in the lexical environment
-;; Find where the variable should be located.
+(: find-variable (Symbol CompileTimeEnvironment -> (U LexicalAddress False)))
-(: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress))
 (define (find-variable name cenv)
   (: find-pos (Symbol (Listof (U Symbol False)) -> Natural))
   (define (find-pos sym los)
@@ -24,10 +23,11 @@
        0]
       [else
        (add1 (find-pos sym (cdr los)))]))
-  (let: loop : LexicalAddress ([cenv : CompileTimeEnvironment cenv]
+  (let: loop : (U LexicalAddress False)
-                               [depth : Natural 0])
+        ([cenv : CompileTimeEnvironment cenv]
+         [depth : Natural 0])
         (cond [(empty? cenv)
-               (error 'find-variable "Unable to find ~s in the environment" name)]
+               #f]
               [else
                (let: ([elt : CompileTimeEnvironmentEntry (first cenv)])
                  (cond

lexical-structs.rkt

@@ -10,7 +10,8 @@
 ;; A toplevel prefix contains a list of toplevel variables.  Some of the
 ;; names may be masked out by #f.
 (define-struct: Prefix ([names : (Listof (U Symbol False))])
-  #:transparent)
+  #:transparent
+  #:mutable)
 
 
 (define-struct: NamedBinding ([name : Symbol]))

parse.rkt

@@ -1,8 +1,48 @@
 #lang racket/base
-(require "expression-structs.rkt")
-(provide parse)
 
-(define (parse exp)
+(require "expression-structs.rkt"
+         "lexical-env.rkt"
+         "lexical-structs.rkt"
+         racket/list)
+
+(provide (rename-out (-parse parse)))
+
+(define (-parse exp)
+  (let* ([prefix (make-Prefix '())]
+         [cenv (list prefix)])
+    (let ([expr (parse exp cenv)])
+      (make-Top prefix expr))))
+
+
+;; find-prefix: CompileTimeEnvironment -> Natural
+(define (find-prefix cenv)
+  (cond
+    [(empty? cenv)
+     (error 'impossible)]
+    [(Prefix? (first cenv))
+     0]
+    [else
+     (add1 (find-prefix (rest cenv)))]))
+
+
+;; find-variable*: Any CompileTimeEnvironment -> LexicalAddress
+(define (find-variable* exp cenv)
+  (let ([address (find-variable exp cenv)])
+    (cond
+      [(eq? address #f)
+       (let* ([prefix-depth (find-prefix cenv)]
+              [prefix (list-ref cenv prefix-depth)])
+         (set-Prefix-names! prefix (append (Prefix-names prefix)
+                                           (list exp)))
+         (find-variable* exp cenv))]
+      [else
+       address])))
+
+
+
+;; parse: Any CompileTimeEnvironment -> ExpressionCore
+;; Compile an expression.
+(define (parse exp cenv)
   (cond
     [(self-evaluating? exp)
      (make-Constant exp)]
@@ -11,26 +51,56 @@
      (make-Constant (text-of-quotation exp))]
     
     [(variable? exp)
-     (make-Var exp)] 
+     (let ([address (find-variable* exp cenv)])
+       (cond
+         [(EnvLexicalReference? address)
+          (make-LocalRef (EnvLexicalReference-depth address))]
+         [(EnvPrefixReference? address)
+          (make-ToplevelRef (EnvPrefixReference-depth address)
+                            (EnvPrefixReference-pos address))]))]
     
     [(definition? exp)
-     (make-Def (definition-variable exp)
+     (let ([address (find-variable* exp cenv)])
-               (parse (definition-value exp)))]
+       (cond
+         [(EnvLexicalReference? address)
+          (error 'parse "Can't define except in toplevel context")]
+         [(EnvPrefixReference? address)
+          (make-SetToplevel (EnvPrefixReference-depth address)
+                            (EnvPrefixReference-pos address)
+                            (EnvPrefixReference-name address)
+                            (parse (definition-value exp) cenv))]))] 
     
     [(if? exp)
-     (make-Branch (parse (if-predicate exp))
+     (make-Branch (parse (if-predicate exp) cenv)
-                  (parse (if-consequent exp))
+                  (parse (if-consequent exp) cenv)
-                  (parse (if-alternative exp)))]
+                  (parse (if-alternative exp) cenv))]
     
     [(cond? exp)
-     (parse (desugar-cond exp))]
+     (parse (desugar-cond exp) cenv)]
     
     [(lambda? exp)
-     (make-Lam (lambda-parameters exp)
+     ;; Fixme: need to know what variables are treated as free here!
-               (make-Seq (map parse (lambda-body exp))))]
+     (let* ([prefix (list-ref cenv (find-prefix cenv))]
+            [prefix-length (length (Prefix-names prefix))]
+            [body-cenv (extend-lexical-environment/names 
+                        '() 
+                        (lambda-parameters exp))])
+       (let ([lam-body (make-Seq (map (lambda (b)
+                                        (parse b (cons prefix body-cenv)))
+                                      (lambda-body exp)))])
+         (cond [(= prefix-length (length (Prefix-names prefix)))
+                (make-Lam (length (lambda-parameters exp))
+                          lam-body)]
+               [else
+                (make-Lam (length (lambda-parameters exp))
+                          (make-Seq (map (lambda (b)
+                                           (parse b body-cenv))
+                                         (lambda-body exp))))])))]
  
     [(begin? exp)
-     (let ([actions (map parse (begin-actions exp))])
+     (let ([actions (map (lambda (e)
+                           (parse e cenv))
+                         (begin-actions exp))])
        (cond
          [(= 1 (length actions))
           (car actions)]
@@ -38,20 +108,23 @@
           (make-Seq actions)]))]
 
     [(named-let? exp)
-     (parse-named-let exp)]
+     (parse-named-let exp cenv)]
     
     [(let? exp)
-     (parse-let exp)]
+     (parse-let exp cenv)]
     
     [(let*? exp)
-     (parse-let* exp)]
+     (parse-let* exp cenv)]
     
     [(letrec? exp)
-     (parse-letrec exp)]
+     (parse-letrec exp cenv)]
     
     [(application? exp)
-     (make-App (parse (operator exp))
+     (let ([cenv-with-scratch-space
-               (map parse (operands exp)))]
+            (extend-lexical-environment/placeholders cenv (length (operands exp)))])
+       (make-App (parse (operator exp) cenv-with-scratch-space)
+                 (map (lambda (rand) (parse rand cenv-with-scratch-space))
+                      (operands exp))))]
     
     [else
      (error 'compile "Unknown expression type ~e" exp)]))
@@ -152,7 +225,7 @@
          
 
 
-(define (parse-let exp)
+(define (parse-let exp cenv)
   (let ([vars (let-variables exp)]
         [rhss (let-rhss exp)]
         [body (let-body exp)])
@@ -160,27 +233,31 @@
       [(= 0 (length vars))
        (parse `(begin ,@body))]
       [(= 1 (length vars))
-       (make-Let1 (car vars)
+       (make-Let1 (parse (car rhss) (extend-lexical-environment/placeholders cenv 1))
-                  (parse (car rhss))
+                  (parse `(begin ,@body)
-                  (parse `(begin ,@body)))]
+                         (extend-lexical-environment/names cenv (list (first vars)))))]
       [else
-       (make-Let vars
+       (let ([rhs-cenv (extend-lexical-environment/placeholders cenv (length vars))])
-                 (map parse rhss)
+         (make-Let (length vars)
-                 (parse `(begin ,@body)))])))
+                   (map (lambda (rhs) (parse rhs rhs-cenv)) rhss)
+                   (parse `(begin ,@body)
+                          (extend-lexical-environment/names vars))))])))
 
-(define (parse-letrec exp)
+(define (parse-letrec exp cenv)
   (let ([vars (let-variables exp)]
         [rhss (let-rhss exp)]
         [body (let-body exp)])
     (cond 
       [(= 0 (length vars))
-       (parse `(begin ,@body))]
+       (parse `(begin ,@body) cenv)]
       [else
-       (make-LetRec vars
+       (let ([new-cenv (extend-lexical-environment/names cenv vars)])
-                    (map parse rhss)
+         (make-LetRec (length vars)
-                    (parse `(begin ,@body)))])))
+                      (map (lambda (rhs) (parse rhs new-cenv)) rhss)
+                      (parse `(begin ,@body) new-cenv)))])))
 
-(define (parse-let* exp)
+
+(define (parse-let* exp cenv)
   (parse
    (let ([body (let-body exp)])
      (let loop ([vars (let-variables exp)]
@@ -190,16 +267,18 @@
           `(begin ,@body)]
          [else
          `(let ([,(car vars) ,(car rhss)])
-            ,(loop (cdr vars) (cdr rhss)))])))))
+            ,(loop (cdr vars) (cdr rhss)))])))
+   cenv))
               
 
 
-(define (parse-named-let exp)
+(define (parse-named-let exp cenv)
   (parse
    `(letrec [(,(named-let-name exp)
 	      (lambda ,(named-let-variables exp)
 		,@(named-let-body exp)))]
-      (,(named-let-name exp) ,@(named-let-rhss exp)))))
+      (,(named-let-name exp) ,@(named-let-rhss exp)))
+   cenv))
   
     
 (define (named-let? exp)