From b2df94e06052fb13c7b249b57c1e8269bc6277fe Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 4 Mar 2011 15:32:29 -0500 Subject: [PATCH] working on extendenvironment/prefix --- compile.rkt | 22 ++++++++---------- il-structs.rkt | 54 +++++++++++++++++++++++++------------------ simulator-prims.rkt | 42 +++++++++++++++++++++++++-------- simulator-structs.rkt | 7 +++++- simulator.rkt | 7 ++---- test-simulator.rkt | 14 ++++++++++- 6 files changed, 94 insertions(+), 52 deletions(-) diff --git a/compile.rkt b/compile.rkt index eb97ec1..dc71114 100644 --- a/compile.rkt +++ b/compile.rkt @@ -47,8 +47,7 @@ [names : (Listof Symbol) (Prefix-names (Top-prefix top))]) (append-instruction-sequences (make-instruction-sequence - `(,(make-PerformStatement 'extend-environment/prefix! - (list (make-Const names))))) + `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names)))) (compile (Top-code top) cenv target linkage)))) @@ -127,10 +126,10 @@ (end-with-linkage linkage cenv (make-instruction-sequence - `(,(make-PerformStatement 'check-bound! - (list (make-Const (PrefixAddress-depth lexical-pos)) - (make-Const (PrefixAddress-pos lexical-pos)) - (make-Const (PrefixAddress-name lexical-pos)))) + `(,(make-PerformStatement (make-CheckToplevelBound! + (PrefixAddress-depth lexical-pos) + (PrefixAddress-pos lexical-pos) + (PrefixAddress-name lexical-pos))) ,(make-AssignPrimOpStatement target (make-LookupToplevelAddress @@ -154,10 +153,10 @@ cenv (append-instruction-sequences get-value-code - (make-instruction-sequence `(,(make-PerformStatement 'toplevel-set! - (list (make-Const (PrefixAddress-depth lexical-pos)) - (make-Const (PrefixAddress-pos lexical-pos)) - (make-Const var))) + (make-instruction-sequence `(,(make-PerformStatement (make-SetToplevel! + (PrefixAddress-depth lexical-pos) + (PrefixAddress-pos lexical-pos) + var)) ,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) @@ -247,8 +246,7 @@ (append-instruction-sequences (make-instruction-sequence `(,proc-entry - ,(make-PerformStatement 'install-closure-values! - (list (make-Reg 'proc))))) + ,(make-PerformStatement (make-InstallClosureValues!)))) (compile (Lam-body exp) extended-cenv 'val 'return)))) diff --git a/il-structs.rkt b/il-structs.rkt index c580f96..5868f70 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -87,9 +87,9 @@ (define-struct: GotoStatement ([target : (U Label Reg)]) #:transparent) -(define-struct: PerformStatement ([op : PrimitiveCommand] - [rands : (Listof (U Label Reg Const))]) +(define-struct: PerformStatement ([op : PrimitiveCommand]) #:transparent) + (define-struct: TestAndBranchStatement ([op : PrimitiveTest] [register : AtomicRegisterSymbol] [label : Symbol]) @@ -143,7 +143,6 @@ ;; The following is used with TestStatement: each is passed the register-rand and ;; is expected to (define-type PrimitiveTest (U - ;; register -> boolean ;; Meant to branch when the register value is false. 'false? @@ -155,27 +154,36 @@ )) + +;; Assign the value in the val register into +;; the prefix installed at (depth, pos). +(define-struct: SetToplevel! ([depth : Natural] + [pos : Natural] + [name : Symbol]) + #:transparent) + +;; Check that the value in the prefix has been defined. +;; If not, raise an error and stop evaluation. +(define-struct: CheckToplevelBound! ([depth : Natural] + [pos : Natural] + [name : Symbol]) + #:transparent) + +;; Extends the environment with a prefix that holds +;; lookups to the namespace. +(define-struct: ExtendEnvironment/Prefix! ([names : (Listof Symbol)]) + #:transparent) + +;; Adjusts the environment by pushing the values in the +;; closure (held in the proc register) into itself. +(define-struct: InstallClosureValues! () + #:transparent) + (define-type PrimitiveCommand (U - ;; depth pos symbol - ;; Assign the value in the val register into - ;; the prefix installed at (depth, pos). - 'toplevel-set! - - ;; depth pos symbol -> void - ;; Check that the value in the prefix has been defined. - ;; If not, raise an error and stop evaluation. - 'check-bound! - - ;; (listof symbol) -> void - ;; Extends the environment with a prefix that holds - ;; lookups to the namespace. - 'extend-environment/prefix! - - ;; register -> void - ;; Adjusts the environment by pushing the values in the - ;; closure (held in the register) into itself. - 'install-closure-values! - )) + SetToplevel! + CheckToplevelBound! + ExtendEnvironment/Prefix! + InstallClosureValues!)) diff --git a/simulator-prims.rkt b/simulator-prims.rkt index 25ccb34..004a8c5 100644 --- a/simulator-prims.rkt +++ b/simulator-prims.rkt @@ -1,13 +1,35 @@ #lang racket/base -(require "simulator-structs.rkt") +(require "simulator-structs.rkt" + racket/math + (for-syntax racket/base)) + + +(define-syntax (make-lookup stx) + (syntax-case stx () + [(_ #:functions (name ...) + #:constants (cname ...)) + (with-syntax ([(prim-name ...) (generate-temporaries #'(name ...))]) + (syntax/loc stx + (let ([prim-name (make-primitive-proc + (lambda args + (apply name args)))] + ...) + (lambda (n) + (cond + [(eq? n 'name) + prim-name] + ... + [(eq? n 'cname) + cname] + ... + [else + (error 'lookup)] + )))))])) + + +(define e (exp 1)) (provide lookup-primitive) - -(define (lookup-primitive name) - (cond - [(eq? name '+) - (make-primitive-proc +)] - [(eq? name '=) - (make-primitive-proc =)] - [else - (void)])) \ No newline at end of file +(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= cons list car cdr + display newline displayln) + #:constants (null pi e))) diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 7275c88..e182bd1 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -19,6 +19,11 @@ (define-struct: frame ([return : Symbol]) #:transparent) +(define-struct: toplevel ([vals : (Vectorof Any)]) + #:transparent) ;; Primitive procedure wrapper -(define-struct: primitive-proc ([f : (Any * -> Any)])) \ No newline at end of file +(define-struct: primitive-proc ([f : (Any * -> Any)])) + + + diff --git a/simulator.rkt b/simulator.rkt index 0b5676e..51a9f92 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -65,15 +65,12 @@ (cond [(Label? t) (jump m (Label-name t))] [(Reg? t) - (let: ([reg : RegisterSymbol (Reg-name t)]) + (let: ([reg : AtomicRegisterSymbol (Reg-name t)]) (cond [(AtomicRegisterSymbol? reg) (cond [(eq? reg 'val) (jump m (ensure-symbol (machine-val m)))] [(eq? reg 'proc) - (jump m (ensure-symbol (machine-proc m)))])] - [else - (error 'step-goto "Register '~s is supposed to be either 'val or 'proc" - reg)]))]))) + (jump m (ensure-symbol (machine-proc m)))])]))]))) (: step-assign-immediate (machine AssignImmediateStatement -> machine)) (define (step-assign-immediate m stmt) diff --git a/test-simulator.rkt b/test-simulator.rkt index 0ee1d34..b019b26 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -219,4 +219,16 @@ ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure)) end))]) (test (machine-val (run m)) - 'a-procedure)) \ No newline at end of file + 'a-procedure)) + + + + + +;; AssignPrimOpStatement +(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+ - * =)))))]) + (test (machine-env (run m)) + (list (make-toplevel (vector (lookup-primitive +) + (lookup-primitive -) + (lookup-primitive *) + (lookup-primitive =)))))) \ No newline at end of file