Merge remote branch 'origin/master'

cm.rkt

@@ -1,7 +1,7 @@
-#lang racket/base
+#lang typed/racket/base
 
-(require "structs.rkt"
-         "assemble.rkt"
+(require "typed-structs.rkt"
+         #;"assemble.rkt"
          racket/list)
 
 (provide compile)
@@ -16,66 +16,67 @@
 
 ;; A compile-time environment is a (listof (listof symbol)).
 ;; A lexical address is either a 2-tuple (depth pos), or 'not-found.
-
+(define-type CompileTimeEnvironment (Listof (Listof Symbol)))
+(define-type LexicalAddress (U (List Number Number) 'not-found))
 
 ;; find-variable: symbol compile-time-environment -> lexical-address
 ;; Find where the variable should be located.
+(: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress))
 (define (find-variable name cenv)
+  (: find-pos (Symbol (Listof Symbol) -> Natural))
   (define (find-pos sym los)
     (cond
       [(eq? sym (car los))
        0]
       [else
        (add1 (find-pos sym (cdr los)))]))
-  (let loop ([cenv cenv]
-             [depth 0])
-    (cond [(empty? cenv)
-           'not-found]
-          [(member name (first cenv))
-           (list depth (find-pos name (first cenv)))]
-          [else
-           (loop (rest cenv) (add1 depth))])))
+  (let: loop : LexicalAddress ([cenv : CompileTimeEnvironment cenv]
+                               [depth : Natural 0])
+        (cond [(empty? cenv)
+               'not-found]
+              [(member name (first cenv))
+               (list depth (find-pos name (first cenv)))]
+              [else
+               (loop (rest cenv) (add1 depth))])))
 
-;; global-lexical-address?: lexical-address -> boolean
-;; Produces true if the address refers to the toplevel environment.
-(define (global-lexical-address? address)
-  (eq? address 'not-found))
 
 
 ;; 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))
 
 
 ;; compile: expression target linkage -> instruction-sequence
+(: compile (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile exp cenv target linkage)
   (cond
-    [(self-evaluating? exp)
+    [(Constant? exp)
      (compile-self-evaluating exp cenv target linkage)]
-    [(quoted? exp)
+    [(Quote? exp)
      (compile-quoted exp cenv target linkage)]
-    [(variable? exp)
+    [(Var? exp)
      (compile-variable exp cenv target linkage)]
-    [(assignment? exp)
+    [(Assign? exp)
      (compile-assignment exp cenv target linkage)]
-    [(definition? exp)
+    [(Def? exp)
      (compile-definition exp cenv target linkage)]
-    [(if? exp)
+    [(Branch? exp)
      (compile-if exp cenv target linkage)]
-    [(lambda? exp)
+    [(Lam? exp)
      (compile-lambda exp cenv target linkage)]
-    [(begin? exp)
-     (compile-sequence (begin-actions exp)
+    [(Seq? exp)
+     (compile-sequence (Seq-actions exp)
                        cenv
                        target
                        linkage)]
-    [(application? exp)
+    [(App? exp)
      (compile-application exp cenv target linkage)]
     [else
      (error 'compile "Unknown expression type ~e" exp)]))
 
 
-
+(: compile-linkage (Linkage -> InstructionSequence))
 (define (compile-linkage linkage)
   (cond
     [(eq? linkage 'return)
@@ -86,12 +87,13 @@
      (make-instruction-sequence '() '()
                                 `((goto (label ,linkage))))]))
 
+(: end-with-linkage (Linkage InstructionSequence -> InstructionSequence))
 (define (end-with-linkage linkage instruction-sequence)
   (preserving '(cont)
               instruction-sequence
               (compile-linkage linkage)))
 
-
+(: compile-self-evaluating (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-self-evaluating exp cenv target linkage)
   (end-with-linkage linkage
                     (make-instruction-sequence
@@ -99,19 +101,19 @@
                      (list target)
                      `((assign ,target (const ,exp))))))
 
-
+(: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-quoted exp cenv target linkage)
   (end-with-linkage linkage
                     (make-instruction-sequence
                      '()
                      (list target)
-                     `((assign ,target (const ,(text-of-quotation exp)))))))
-
+                     `((assign ,target (const ,(Quote-text exp)))))))
 
+(: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-variable exp cenv target linkage)
-  (let ([lexical-pos (find-variable exp cenv)])
+  (let ([lexical-pos (find-variable (Var-id exp) cenv)])
     (cond
-      [(global-lexical-address? lexical-pos)
+      [(eq? lexical-pos 'not-found)
        (end-with-linkage linkage
                          (make-instruction-sequence
                           '(env)
@@ -119,11 +121,11 @@
                           ;; Slight modification: explicitly testing for
                           ;; global variable binding before lookup.
                           `((perform (op check-bound-global!)
-                                     (const ,exp)
+                                     (const ,(Var-id exp))
                                      (reg env))
                             (assign ,target
                                     (op lookup-variable-value)
-                                    (const ,exp)
+                                    (const ,(Var-id exp))
                                     (reg env)))))]
       [else
        (end-with-linkage linkage
@@ -137,15 +139,15 @@
                                     (reg env)))))])))
 
 
-
+(: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-assignment exp cenv target linkage)
-  (let* ([var (assignment-variable exp)]
+  (let* ([var (Assign-variable exp)]
          [get-value-code
-          (compile (assignment-value exp) cenv 'val 'next)]
+          (compile (Assign-value exp) cenv 'val 'next)]
          [lexical-address
           (find-variable var cenv)])
     (cond
-      [(global-lexical-address? lexical-address)
+      [(eq? lexical-address 'not-found)
        (end-with-linkage
         linkage
         (preserving '(env)
@@ -175,10 +177,11 @@
 
 
 ;; FIXME: exercise 5.43
+(: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-definition exp cenv target linkage)
-  (let ([var (definition-variable exp)]
+  (let ([var (Def-variable exp)]
         [get-value-code
-         (compile (definition-value exp) cenv 'val 'next)])
+         (compile (Def-value exp) cenv 'val 'next)])
     (end-with-linkage
      linkage
      (preserving
@@ -194,7 +197,7 @@
          (assign ,target (const ok))))))))
 
 
-
+(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-if exp cenv target linkage)  
   (let ([t-branch (make-label 'trueBranch)]
         [f-branch (make-label 'falseBranch)]
@@ -203,9 +206,9 @@
            (if (eq? linkage 'next)
                after-if
                linkage)])
-      (let ([p-code (compile (if-predicate exp) cenv 'val 'next)]
-            [c-code (compile (if-consequent exp) cenv target consequent-linkage)]
-            [a-code (compile (if-alternative exp) cenv target linkage)])
+      (let ([p-code (compile (Branch-predicate exp) cenv 'val 'next)]
+            [c-code (compile (Branch-consequent exp) cenv target consequent-linkage)]
+            [a-code (compile (Branch-alternative exp) cenv target linkage)])
         (preserving '(env cont)
                     p-code
                     (append-instruction-sequences
@@ -220,7 +223,7 @@
                      after-if))))))
 
 
-
+(: 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)
@@ -229,6 +232,7 @@
                   (compile-sequence (rest-exps seq) cenv target linkage))))
 
 
+(: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-lambda exp cenv target linkage) 
   (let ([proc-entry (make-label 'entry)]
         [after-lambda (make-label 'afterLambda)])
@@ -256,9 +260,9 @@
                              proc-entry))
        after-lambda))))
 
-
+(: compile-lambda-body (Lam CompileTimeEnvironment Linkage -> InstructionSequence))
 (define (compile-lambda-body exp cenv proc-entry)
-  (let* ([formals (lambda-parameters exp)]
+  (let* ([formals (Lam-parameters exp)]
          [extended-cenv (extend-lexical-environment cenv formals)])
     (append-instruction-sequences
      (make-instruction-sequence 
@@ -270,20 +274,21 @@
                 (op extend-environment)
                 (reg argl)
                 (reg env))))
-     (compile-sequence (lambda-body exp) extended-cenv 'val 'return))))
-
+     (compile-sequence (Lam-body exp) extended-cenv 'val 'return))))
 
+(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-application exp cenv target linkage) 
-  (let ([proc-code (compile (operator exp) cenv 'proc 'next)]
-        [operand-codes (map (lambda (operand)
+  (let ([proc-code (compile (App-operator exp) cenv 'proc 'next)]
+        [operand-codes (map (lambda: ([operand : Expression])
                               (compile operand cenv 'val 'next))
-                            (operands exp))])
+                            (App-operands exp))])
     (preserving '(env cont)
                 proc-code
                 (preserving '(proc cont)
                             (construct-arglist operand-codes)
                             (compile-procedure-call target linkage)))))
 
+(: construct-arglist ((Listof InstructionSequence) -> InstructionSequence))
 (define (construct-arglist operand-codes)
   (let ([operand-codes (reverse operand-codes)])
     (if (null? operand-codes)
@@ -301,6 +306,7 @@
                           code-to-get-last-arg
                           (code-to-get-rest-args
                            (cdr operand-codes))))))))
+(: code-to-get-rest-args ((Listof InstructionSequence) -> InstructionSequence))
 (define (code-to-get-rest-args operand-codes)
   (let ([code-for-next-arg
          (preserving '(argl)
@@ -315,7 +321,7 @@
                     code-for-next-arg
                     (code-to-get-rest-args (cdr operand-codes))))))
 
-
+(: compile-procedure-call (Target Linkage -> InstructionSequence))
 (define (compile-procedure-call target linkage)
   (let ([primitive-branch (make-label 'primitiveBranch)]
         [compiled-branch (make-label 'compiledBranch)]
@@ -342,6 +348,7 @@
                                       (reg argl)))))))
        after-call))))
 
+(: compile-proc-appl (Target Linkage -> InstructionSequence))
 (define (compile-proc-appl target linkage)
   (cond [(and (eq? target 'val)
               (not (eq? linkage 'return)))
@@ -385,13 +392,15 @@
 
 
 
-
+(: needs-register? (InstructionSequence Symbol -> Boolean))
 (define (needs-register? seq reg)
-  (memq reg (registers-needed seq)))
+  (and (memq reg (registers-needed seq)) #t))
+
+(: modifies-register? (InstructionSequence Symbol -> Boolean))
 (define (modifies-register? seq reg)
-  (memq reg (registers-modified seq)))
-
+  (and (memq reg (registers-modified seq)) #t))
 
+(: preserving ((Listof Symbol) InstructionSequence InstructionSequence -> InstructionSequence))
 (define (preserving regs seq1 seq2)
   (if (null? regs)
       (append-instruction-sequences seq1 seq2)
@@ -412,9 +421,12 @@
 
 
 
-
+(: append-instruction-sequences (InstructionSequence * -> InstructionSequence))
 (define (append-instruction-sequences . seqs)
-  (define (append-2-sequences seq1 seq2)
+  (append-seq-list seqs))
+
+(: append-2-sequences (InstructionSequence InstructionSequence -> InstructionSequence))
+(define (append-2-sequences seq1 seq2)
     (make-instruction-sequence
      (list-union (registers-needed seq1)
                  (list-difference (registers-needed seq2)
@@ -422,19 +434,23 @@
      (list-union (registers-modified seq1)
                  (registers-modified seq2))
      (append (statements seq1) (statements seq2))))
-  (define (append-seq-list seqs)
-    (if (null? seqs)
-        empty-instruction-sequence
-        (append-2-sequences (car seqs)
-                            (append-seq-list (cdr seqs)))))
-  (append-seq-list seqs))
 
+(: append-seq-list ((Listof InstructionSequence) -> InstructionSequence))
+(define (append-seq-list seqs)
+  (if (null? seqs)
+      empty-instruction-sequence
+      (append-2-sequences (car seqs)
+                          (append-seq-list (cdr seqs)))))
+
+(: list-union ((Listof Symbol) (Listof Symbol) -> (Listof Symbol)))
 (define (list-union s1 s2)
   (cond [(null? s1) s2]
         [(memq (car s1) s2)
          (list-union (cdr s1) s2)]
         [else (cons (car s1) (list-union (cdr s1) s2))]))
 
+
+(: list-difference ((Listof Symbol) (Listof Symbol) -> (Listof Symbol)))
 (define (list-difference s1 s2)
   (cond [(null? s1) '()]
         [(memq (car s1) s2)
@@ -443,13 +459,13 @@
          (cons (car s1) (list-difference (cdr s1) s2))]))
 
 
-
+(: tack-on-instruction-sequence (InstructionSequence InstructionSequence -> InstructionSequence))
 (define (tack-on-instruction-sequence seq body-seq)
   (make-instruction-sequence (registers-needed seq)
                              (registers-modified seq)
                              (append (statements seq) (statements body-seq))))
 
-
+(: parallel-instruction-sequences (InstructionSequence InstructionSequence -> InstructionSequence))
 (define (parallel-instruction-sequences seq1 seq2)
   (make-instruction-sequence
    (list-union (registers-needed seq1)
@@ -474,7 +490,7 @@
 
 
 
-(define (test source-code)
+#;(define (test source-code)
   (let ([basic-blocks
          (fracture (statements (compile source-code
                                         '()

typed-parse.rkt

@@ -0,0 +1,6 @@
+#lang typed/racket/base
+(require "typed-structs.rkt")
+(require/typed "parse.rkt"
+               [parse (Any -> Expression)])
+
+(provide parse)

typed-structs.rkt

@@ -0,0 +1,66 @@
+#lang typed/racket/base
+(provide (all-defined-out))
+
+(define-type Expression (U Constant Quote Var Assign Branch Def Lam Seq App))
+(define-struct: Constant ([v : Any]) #:transparent)
+(define-struct: Quote ([text : Any]) #:transparent)
+(define-struct: Var ([id : Symbol]) #:transparent)
+(define-struct: Assign ([variable : Symbol]
+                        [value : Expression]) #:transparent)
+(define-struct: Branch ([predicate : Expression]
+                        [consequent : Expression]
+                        [alternative : Expression]) #:transparent)
+(define-struct: Def ([variable : Symbol] 
+                     [value : Expression]) #:transparent)
+(define-struct: Lam ([parameters : (Listof Symbol)]
+                     [body : (Listof Expression)]) #:transparent)
+(define-struct: Seq ([actions : (Listof Expression)]) #:transparent)
+(define-struct: App ([operator : Expression]
+                     [operands : (Listof Expression)]) #:transparent)
+
+(: last-exp? ((Listof Expression) -> Boolean))
+(define (last-exp? seq) 
+  (null? (cdr seq)))
+
+(: first-exp ((Listof Expression) -> Expression))
+(define (first-exp seq) (car seq))
+
+(: rest-exps ((Listof Expression) -> (Listof Expression)))
+(define (rest-exps seq) (cdr seq))
+
+
+
+;; instruction sequences
+(define-type InstructionSequence (U Symbol instruction-sequence))
+(define-struct: instruction-sequence ([needs : (Listof Symbol)]
+                                      [modifies : (Listof Symbol)]
+                                      [statements : (Listof Any)]) #:transparent)
+(define empty-instruction-sequence (make-instruction-sequence '() '() '()))
+
+(: make-label (Symbol -> Symbol))
+(define make-label
+  (let ([n 0])
+    (lambda (l)
+      (set! n (add1 n))
+      (string->symbol (format "~a~a" l n)))))
+
+
+(: registers-needed (InstructionSequence -> (Listof Symbol)))
+(define (registers-needed s)
+  (if (symbol? s) '() (instruction-sequence-needs s)))
+
+(: registers-modified (InstructionSequence -> (Listof Symbol)))
+(define (registers-modified s)
+  (if (symbol? s) '() (instruction-sequence-modifies s)))
+
+(: statements (InstructionSequence -> (Listof Any)))
+(define (statements s)
+  (if (symbol? s) (list s) (instruction-sequence-statements s)))
+
+
+
+;; Targets
+(define-type Target Symbol)
+
+;; Linkage
+(define-type Linkage (U 'return 'next Symbol))