From b78a1b35c2c498909dd2ab2ca48534c9ad7baa6d Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 18 Feb 2011 18:08:13 -0500 Subject: [PATCH] rest break --- cm.rkt | 86 +++++++++++++++++++++++++---------------------- typed-structs.rkt | 43 +++++++++++++++++++----- 2 files changed, 80 insertions(+), 49 deletions(-) diff --git a/cm.rkt b/cm.rkt index d4bb690..33953f2 100644 --- a/cm.rkt +++ b/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,25 +16,28 @@ ;; 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 (List Number Number)) ;; 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 : (U LexicalAddress 'not-found) ([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. @@ -48,28 +51,29 @@ ;; 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)])) @@ -105,7 +109,7 @@ (make-instruction-sequence '() (list target) - `((assign ,target (const ,(text-of-quotation exp))))))) + `((assign ,target (const ,(Quote-text exp))))))) (define (compile-variable exp cenv target linkage) @@ -139,9 +143,9 @@ (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 @@ -176,9 +180,9 @@ ;; FIXME: exercise 5.43 (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 @@ -203,9 +207,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 @@ -258,7 +262,7 @@ (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,7 +274,7 @@ (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)))) (define (compile-application exp cenv target linkage) @@ -414,7 +418,9 @@ (define (append-instruction-sequences . seqs) - (define (append-2-sequences seq1 seq2) + (append-seq-list seqs)) + +(define (append-2-sequences seq1 seq2) (make-instruction-sequence (list-union (registers-needed seq1) (list-difference (registers-needed seq2) @@ -422,12 +428,12 @@ (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)) + +(define (append-seq-list seqs) + (if (null? seqs) + empty-instruction-sequence + (append-2-sequences (car seqs) + (append-seq-list (cdr seqs))))) (define (list-union s1 s2) (cond [(null? s1) s2] @@ -474,7 +480,7 @@ -(define (test source-code) +#;(define (test source-code) (let ([basic-blocks (fracture (statements (compile source-code '() diff --git a/typed-structs.rkt b/typed-structs.rkt index e123ae1..948ac09 100644 --- a/typed-structs.rkt +++ b/typed-structs.rkt @@ -3,17 +3,42 @@ (define-type Expression (U Constant Quote Var Assign Branch Def Lam Seq App)) (define-struct: Constant ([v : Any]) #:transparent) -(define-struct: Quote ([v : Any]) #:transparent) +(define-struct: Quote ([text : Any]) #:transparent) (define-struct: Var ([id : Symbol]) #:transparent) -(define-struct: Assign ([id : Symbol] - [expr : Expression]) #:transparent) -(define-struct: Branch ([test : Expression] +(define-struct: Assign ([variable : Symbol] + [value : Expression]) #:transparent) +(define-struct: Branch ([predicate : Expression] [consequent : Expression] [alternative : Expression]) #:transparent) -(define-struct: Def ([id : Symbol] - [expr : Expression]) #:transparent) -(define-struct: Lam ([ids : (Listof Symbol)] - [body : Expression]) #:transparent) -(define-struct: Seq ([es : (Listof 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 ([op : Expression] [rands : (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-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))))) \ No newline at end of file