testing parse

expression-structs.rkt

@@ -33,25 +33,30 @@
                         [alternative : ExpressionCore]) #:transparent)
 
 (define-struct: Lam ([num-parameters : Natural]
-                     [body : ExpressionCore]) #:transparent)
+                     [body : ExpressionCore]
+                     [closure-map : (Listof EnvReference)]) #:transparent)
 
 (define-struct: Seq ([actions : (Listof ExpressionCore)]) #:transparent)
 (define-struct: App ([operator : ExpressionCore]
                      [operands : (Listof ExpressionCore)]) #:transparent)
 
-(define-struct: Let1 ([rhs : ExpressionCore ]
+(define-struct: Let1 ([rhs : ExpressionCore]
                       [body : ExpressionCore])
   #:transparent)
 (define-struct: Let ([count : Natural]
                      [rhss : (Listof ExpressionCore)]
                      [body : ExpressionCore])
   #:transparent)
+
 (define-struct: LetRec ([count : Natural]
                         [rhss : (Listof ExpressionCore)]
                         [body : ExpressionCore])
   #:transparent)
 
 
+
+
+
 (: last-exp? ((Listof Expression) -> Boolean))
 (define (last-exp? seq) 
   (null? (cdr seq)))

lexical-env.rkt

@@ -14,7 +14,7 @@
 
 
 ;; Find where the variable is located in the lexical environment
-(: 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)
@@ -23,11 +23,11 @@
        0]
       [else
        (add1 (find-pos sym (cdr los)))]))
-  (let: loop : (U LexicalAddress False)
+  (let: loop : LexicalAddress
         ([cenv : CompileTimeEnvironment cenv]
          [depth : Natural 0])
         (cond [(empty? cenv)
-               #f]
+               (error 'find-variable "~s not in lexical environment" cenv)]
               [else
                (let: ([elt : CompileTimeEnvironmentEntry (first cenv)])
                  (cond

lexical-structs.rkt

@@ -10,8 +10,7 @@
 ;; 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

@@ -3,15 +3,14 @@
 (require "expression-structs.rkt"
          "lexical-env.rkt"
          "lexical-structs.rkt"
+         "helpers.rkt"
          racket/list)
 
 (provide (rename-out (-parse parse)))
 
 (define (-parse exp)
-  (let* ([prefix (make-Prefix '())]
+  (let* ([prefix (make-Prefix (find-unbound-names exp))])
-         [cenv (list prefix)])
+    (make-Top prefix (parse exp (extend-lexical-environment '() prefix)))))
-    (let ([expr (parse exp cenv)])
-      (make-Top prefix expr))))
 
 
 ;; find-prefix: CompileTimeEnvironment -> Natural
@@ -25,21 +24,6 @@
      (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)
@@ -51,7 +35,7 @@
      (make-Constant (text-of-quotation exp))]
     
     [(variable? exp)
-     (let ([address (find-variable* exp cenv)])
+     (let ([address (find-variable exp cenv)])
        (cond
          [(EnvLexicalReference? address)
           (make-LocalRef (EnvLexicalReference-depth address))]
@@ -60,7 +44,7 @@
                             (EnvPrefixReference-pos address))]))]
     
     [(definition? exp)
-     (let ([address (find-variable* exp cenv)])
+     (let ([address (find-variable (definition-variable exp) cenv)])
        (cond
          [(EnvLexicalReference? address)
           (error 'parse "Can't define except in toplevel context")]
@@ -79,23 +63,22 @@
      (parse (desugar-cond exp) cenv)]
     
     [(lambda? exp)
-     ;; Fixme: need to know what variables are treated as free here!
+     (let* ([unbound-names (find-unbound-names exp)]
-     (let* ([prefix (list-ref cenv (find-prefix cenv))]
+            [closure-references (collect-lexical-references
-            [prefix-length (length (Prefix-names prefix))]
+                                 (map (lambda (var)
-            [body-cenv (extend-lexical-environment/names 
+                                        (find-variable var cenv))
-                        '() 
+                                      unbound-names))]
-                        (lambda-parameters exp))])
+            [body-cenv (lexical-references->compile-time-environment
+                        closure-references
+                        cenv
+                        (extend-lexical-environment/names '() (lambda-parameters exp))
+                        unbound-names)])
        (let ([lam-body (make-Seq (map (lambda (b)
-                                        (parse b (cons prefix body-cenv)))
+                                        (parse b body-cenv))
                                       (lambda-body exp)))])
-         (cond [(= prefix-length (length (Prefix-names prefix)))
+         (make-Lam (length (lambda-parameters exp))
-                (make-Lam (length (lambda-parameters exp))
+                   lam-body
-                          lam-body)]
+                   closure-references)))]
-               [else
-                (make-Lam (length (lambda-parameters exp))
-                          (make-Seq (map (lambda (b)
-                                           (parse b body-cenv))
-                                         (lambda-body exp))))])))]
  
     [(begin? exp)
      (let ([actions (map (lambda (e)
@@ -108,13 +91,13 @@
           (make-Seq actions)]))]
 
     [(named-let? exp)
-     (parse-named-let exp cenv)]
+     (parse (desugar-named-let exp) cenv)]
-    
-    [(let? exp)
-     (parse-let exp cenv)]
     
     [(let*? exp)
-     (parse-let* exp cenv)]
+     (parse (desugar-let* exp) cenv)]
+
+    [(let? exp)
+     (parse-let exp cenv)]
     
     [(letrec? exp)
      (parse-letrec exp cenv)]
@@ -125,12 +108,73 @@
        (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)]))
 
 
 
+
+
+;; find-unbound-names: Any -> (Listof Symbol)
+(define (find-unbound-names exp)
+  (cond
+    [(self-evaluating? exp)
+     '()]
+    
+    [(quoted? exp)
+     '()]
+    
+    [(variable? exp)
+     (list exp)]
+    
+    [(definition? exp)
+     (let ([address (find-variable (definition-variable exp))])
+       (cons (definition-variable address)
+             (find-unbound-names (definition-value exp))))]
+    
+    [(if? exp)
+     (append (find-unbound-names (if-predicate exp))
+             (find-unbound-names (if-consequent exp))
+             (find-unbound-names (if-alternative exp)))]
+    
+    [(cond? exp)
+     (find-unbound-names (desugar-cond exp))]
+    
+    [(lambda? exp)
+     (list-difference (apply append (map find-unbound-names (lambda-body exp)))
+                      (lambda-parameters exp))]
+ 
+    [(begin? exp)
+     (apply append (map find-unbound-names (begin-actions exp)))]
+
+    [(named-let? exp)
+     (find-unbound-names (desugar-named-let exp))]
+
+    [(let*? exp)
+     (find-unbound-names (desugar-let* exp))]
+    
+    [(let? exp)
+     (append (apply append (map find-unbound-names (let-rhss exp)))
+             (list-difference (apply append (map find-unbound-names (let-body exp)))
+                              (let-variables exp)))]
+    
+    [(letrec? exp)
+     (list-difference (append (apply append (map find-unbound-names (let-rhss exp)))
+                              (apply append (map find-unbound-names (let-body exp))))
+      (let-variables exp))]
+
+    [(application? exp)
+     (append (find-unbound-names (operator exp))
+             (apply append (map find-unbound-names (operands exp))))]
+
+    [else
+     (error 'find-unbound-names "Unknown expression type ~e" exp)]))
+
+
+
+
+
+
 ;; expression selectors
 
 (define (self-evaluating? exp)
@@ -257,28 +301,26 @@
                       (parse `(begin ,@body) new-cenv)))])))
 
 
-(define (parse-let* exp cenv)
+(define (desugar-let* exp)
-  (parse
+  (let ([body (let-body exp)])
-   (let ([body (let-body exp)])
+    (let loop ([vars (let-variables exp)]
-     (let loop ([vars (let-variables exp)]
+               [rhss (let-rhss exp)])
-                [rhss (let-rhss exp)])
+      (cond
-       (cond
+        [(null? vars)
-         [(null? vars)
+         `(begin ,@body)]
-          `(begin ,@body)]
+        [else
-         [else
          `(let ([,(car vars) ,(car rhss)])
-            ,(loop (cdr vars) (cdr rhss)))])))
+            ,(loop (cdr vars) (cdr rhss)))]))))
-   cenv))
+
               
 
 
-(define (parse-named-let exp cenv)
+(define (desugar-named-let exp)
-  (parse
+  `(letrec [(,(named-let-name exp)
-   `(letrec [(,(named-let-name exp)
+             (lambda ,(named-let-variables exp)
-	      (lambda ,(named-let-variables exp)
+               ,@(named-let-body 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)