suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

working on extendenvironment/prefix

Browse Source
This commit is contained in:
Danny Yoo 2011-03-04 15:32:29 -05:00
parent 9277109351
commit b2df94e060
6 changed files with 94 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
compile.rkt
View File

@ -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))))

54
il-structs.rkt
View File

@ -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!))

42
simulator-prims.rkt
View File

@ -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)]))
(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= cons list car cdr
display newline displayln)
#:constants (null pi e)))

7
simulator-structs.rkt
View File

@ -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)]))
(define-struct: primitive-proc ([f : (Any * -> Any)]))

7
simulator.rkt
View File

@ -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)

14
test-simulator.rkt
View File

@ -219,4 +219,16 @@
,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
end))])
(test (machine-val (run m))
'a-procedure))
'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 =))))))