uncommented most of the code; need to work on application

compile.rkt

@@ -9,12 +9,9 @@
 (provide compile-top)
 
 
-;; registers: env, argl, proc, val, cont
-;; as well as the stack.
-(define all-regs '(val control env))
 
 
-(: compile-top (Expression Target Linkage -> InstructionSequence))
+(: compile-top (ExpressionCore Target Linkage -> InstructionSequence))
 (define (compile-top exp target linkage)
   (let*: ([names : (Listof Symbol) (find-toplevel-variables exp)]
           [cenv : CompileTimeEnvironment (list (make-Prefix names))])
@@ -28,24 +25,22 @@
 
 
 ;; compile: expression target linkage -> instruction-sequence
-(: compile (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(: compile (ExpressionCore CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile exp cenv target linkage)
   (cond
     [(Constant? exp)
-     (compile-self-evaluating exp cenv target linkage)]
-    #;[(Quote? exp)
+     (compile-constant exp cenv target linkage)]
+    [(Quote? exp)
      (compile-quoted exp cenv target linkage)]
-    #;[(Var? exp)
+    [(Var? exp)
      (compile-variable exp cenv target linkage)]
-    #;[(Assign? exp)
-     (compile-assignment exp cenv target linkage)]
-    #;[(Def? exp)
+    [(Def? exp)
      (compile-definition exp cenv target linkage)]
-    #;[(Branch? exp)
-     (compile-if exp cenv target linkage)]
+    [(Branch? exp)
+     (compile-branch exp cenv target linkage)]
     #;[(Lam? exp)
      (compile-lambda exp cenv target linkage)]
-    #;[(Seq? exp)
+    [(Seq? exp)
      (compile-sequence (Seq-actions exp)
                        cenv
                        target
@@ -55,39 +50,48 @@
 
 
 
-(: compile-linkage (Linkage -> InstructionSequence))
-(define (compile-linkage linkage)
+(: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
+(define (compile-linkage cenv linkage)
   (cond
-    #;[(eq? linkage 'return)
-       (make-instruction-sequence `(,(make-GotoStatement (make-ControlOffset 0))))]
+    [(eq? linkage 'return)
+     (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc
+                                                               'read-control-label
+                                                               (list (make-Reg 'control)))
+                                  ,(make-PopEnv (lexical-environment-pop-depth cenv))
+                                  ,(make-PopControl)
+                                  ,(make-GotoStatement (make-Reg 'proc))))]
     [(eq? linkage 'next)
      empty-instruction-sequence]
-    [else
+    [(symbol? linkage)
      (make-instruction-sequence `(,(make-GotoStatement (make-Label linkage))))]))
 
-(: end-with-linkage (Linkage InstructionSequence -> InstructionSequence))
-(define (end-with-linkage linkage instruction-sequence)
+(: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence ->
+                             InstructionSequence))
+(define (end-with-linkage linkage cenv instruction-sequence)
   (append-instruction-sequences instruction-sequence
-                                (compile-linkage linkage)))
+                                (compile-linkage cenv linkage)))
 
-(: compile-self-evaluating (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence))
-(define (compile-self-evaluating exp cenv target linkage)
+(: compile-constant (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(define (compile-constant exp cenv target linkage)
   (end-with-linkage linkage
+                    cenv
                     (make-instruction-sequence
                      `(,(make-AssignImmediateStatement target (make-Const (Constant-v exp)))))))
 
-#;(: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence))
-#;(define (compile-quoted exp cenv target linkage)
+(: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(define (compile-quoted exp cenv target linkage)
   (end-with-linkage linkage
+                    cenv
                     (make-instruction-sequence
                      `(,(make-AssignImmediateStatement target (make-Const (Quote-text exp)))))))
 
-#;(: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence))
-#;(define (compile-variable exp cenv target linkage)
+(: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(define (compile-variable exp cenv target linkage)
   (let ([lexical-pos (find-variable (Var-id exp) cenv)])
     (cond
       [(LocalAddress? lexical-pos)
        (end-with-linkage linkage
+                         cenv
                          (make-instruction-sequence
                           `(,(make-AssignPrimOpStatement target
                                                          'lexical-address-lookup
@@ -96,6 +100,7 @@
                                                                (make-Reg 'env))))))]
       [(PrefixAddress? lexical-pos)
        (end-with-linkage linkage
+                         cenv
                          (make-instruction-sequence
                           `(,(make-PerformStatement 'check-bound! 
                                                     (list (make-Const (PrefixAddress-depth lexical-pos))
@@ -110,41 +115,8 @@
                                                                (make-Reg 'env))))))])))
 
 
-#;(: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence))
-#;(define (compile-assignment exp cenv target linkage)
-  (let* ([var (Assign-variable exp)]
-         [get-value-code
-          (compile (Assign-value exp) cenv 'val 'next)]
-         [lexical-address
-          (find-variable var cenv)])
-    (cond
-      [(LocalAddress? lexical-address)
-       (end-with-linkage
-        linkage
-        (append-instruction-sequences get-value-code
-                                      (make-instruction-sequence
-                                       `(,(make-PerformStatement 'lexical-address-set!
-                                                                 (list (make-Const (LocalAddress-depth lexical-address))
-                                                                       (make-Const (LocalAddress-pos lexical-address))
-                                                                       (make-Reg 'env)
-                                                                       (make-Reg 'val)))
-                                         ,(make-AssignImmediateStatement target (make-Const 'ok))))))]
-      [(PrefixAddress? lexical-address)
-       (end-with-linkage
-        linkage
-        (append-instruction-sequences get-value-code
-                                      (make-instruction-sequence
-                                       `(,(make-PerformStatement 'toplevel-set!
-                                                                 (list (make-Const (PrefixAddress-depth lexical-address))
-                                                                       (make-Const (PrefixAddress-pos lexical-address))
-                                                                       (make-Const (PrefixAddress-name lexical-address))
-                                                                       (make-Reg 'env)
-                                                                       (make-Reg 'val)))
-                                         ,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
-
-
-#;(: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence))
-#;(define (compile-definition exp cenv target linkage)
+(: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(define (compile-definition exp cenv target linkage)
   (let* ([var (Def-variable exp)]
          [lexical-pos (find-variable var cenv)]
          [get-value-code
@@ -155,6 +127,7 @@
       [(PrefixAddress? lexical-pos)
        (end-with-linkage
         linkage
+        cenv
         (append-instruction-sequences
          get-value-code
          (make-instruction-sequence `(,(make-PerformStatement 'toplevel-set!
@@ -166,8 +139,8 @@
                                       ,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
 
 
-#;(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
-#;(define (compile-if exp cenv target linkage)  
+(: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(define (compile-branch exp cenv target linkage)  
   (let ([t-branch (make-label 'trueBranch)]
         [f-branch (make-label 'falseBranch)]
         [after-if (make-label 'afterIf)])
@@ -189,8 +162,8 @@
                                        after-if))))))
 
 
-#;(: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence))
-#;(define (compile-sequence seq cenv target linkage) 
+(: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(define (compile-sequence seq cenv target linkage) 
   (if (last-exp? seq)
       (compile (first-exp seq) cenv target linkage)
       (append-instruction-sequences (compile (first-exp seq) cenv target 'next)

lexical-env.rkt

@@ -2,7 +2,7 @@
 
 (require racket/list
          "typed-structs.rkt")
-(provide find-variable extend-lexical-environment)
+(provide find-variable extend-lexical-environment lexical-environment-pop-depth)
 
 
 ;; find-variable: symbol compile-time-environment -> lexical-address
@@ -35,4 +35,14 @@
 ;; extend-lexical-environment: lexical-environment (listof symbol) -> lexical-envrionment
 (: extend-lexical-environment (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment))
 (define (extend-lexical-environment cenv names)
-  (cons names cenv))
+  (cons names cenv))
+
+
+(: lexical-environment-pop-depth (CompileTimeEnvironment -> Natural))
+(define (lexical-environment-pop-depth cenv)
+  (cond [(empty? cenv)
+         (error 'lexical-environment-pop-depth "Empty environment")]
+        [(Prefix? (first cenv))
+         1]
+        [(list? (first cenv))
+         1]))

typed-structs.rkt

@@ -4,7 +4,7 @@
 
 ;; Expressions
 
-(define-type ExpressionCore (U Constant #;Quote #;Var #;Branch #;Def #;Lam #;Seq #;App))
+(define-type ExpressionCore (U Constant Quote Var Branch Def #;Lam Seq #;App))
 (define-type Expression (U ExpressionCore #;Assign))
 (define-struct: Constant ([v : Any]) #:transparent)
 (define-struct: Quote ([text : Any]) #:transparent)
@@ -33,8 +33,11 @@
 (define (rest-exps seq) (cdr seq))
 
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
 (define-type StackRegisterSymbol (U 'control 'env))
-(define-type RegisterSymbol (U StackRegisterSymbol 'val))
+(define-type RegisterSymbol (U StackRegisterSymbol 'val 'proc))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -43,30 +46,25 @@
 (define-type UnlabeledStatement (U 
                                  AssignImmediateStatement
                                  AssignPrimOpStatement
+                                 GotoStatement
                                  PerformStatement
                                  TestStatement
                                  BranchLabelStatement
-                                 GotoStatement
+                                 PopEnv
+                                 PopControl
                                  #;SaveStatement
                                  #;RestoreStatement))
 (define-type Statement (U UnlabeledStatement
                           Symbol  ;; label
                           ))
+
 (define-struct: AssignImmediateStatement ([target : Target]
-                                          [value : (U Const Reg Label)])
+                                          [value : OpArg])
   #:transparent)
 (define-struct: AssignPrimOpStatement ([target : Target]
                                        [op : PrimitiveOperator]
-                                       [rands : (Listof (U Label Reg Const))])
+                                       [rands : (Listof OpArg)])
   #:transparent)
-(define-struct: PerformStatement ([op : PerformOperator]
-                                  [rands : (Listof (U Label Reg Const))]) #:transparent)
-(define-struct: TestStatement ([op : TestOperator]
-                               [register-rand : RegisterSymbol]) #:transparent)
-(define-struct: BranchLabelStatement ([label : Symbol]) #:transparent)
-(define-struct: GotoStatement ([target : (U Label Reg)]) #:transparent)
-#;(define-struct: SaveStatement ([reg : RegisterSymbol]) #:transparent)
-#;(define-struct: RestoreStatement ([reg : RegisterSymbol]) #:transparent)
 
 (define-struct: Label ([name : Symbol])
   #:transparent)
@@ -75,7 +73,25 @@
 (define-struct: Const ([const : Any])
   #:transparent)
 
-(define-type OpArg (U Const Label Reg))
+(define-struct: TopControlProcedure ()) 
+
+(define-type OpArg (U Const Label Reg TopControlProcedure))
+
+(define-struct: PopEnv ([n : Natural]))
+(define-struct: PopControl ())
+
+(define-struct: GotoStatement ([target : (U Label Reg)]) 
+  #:transparent)
+
+
+(define-struct: PerformStatement ([op : PerformOperator]
+                                  [rands : (Listof (U Label Reg Const))]) #:transparent)
+(define-struct: TestStatement ([op : TestOperator]
+                               [register-rand : RegisterSymbol]) #:transparent)
+(define-struct: BranchLabelStatement ([label : Symbol]) #:transparent)
+#;(define-struct: SaveStatement ([reg : RegisterSymbol]) #:transparent)
+#;(define-struct: RestoreStatement ([reg : RegisterSymbol]) #:transparent)
+
 
 
 (define-type PrimitiveOperator (U 'compiled-procedure-entry
@@ -90,6 +106,8 @@
                                   'lexical-address-lookup
                                   'toplevel-lookup
                                   
+                                  'read-control-label
+                                  
                                   'extend-environment
                                   'extend-environment/prefix))
 
@@ -122,13 +140,13 @@
 
 
 ;; Targets
-(define-type Target (U RegisterSymbol ControlOffset EnvOffset))
-(define-struct: ControlOffset ([depth : Natural]))
+(define-type Target (U RegisterSymbol ControlTarget EnvOffset))
+(define-struct: ControlTarget ())
 (define-struct: EnvOffset ([depth : Natural]
                            [pos : Natural]))
 
 ;; Linkage
-(define-type Linkage (U #; 'return 
+(define-type Linkage (U 'return 
                         'next
                         Symbol))