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

changed the allowed set of primitives so we typecheck a bit better. Added chekc-toplevel-bound

Browse Source
This commit is contained in:
Danny Yoo 2011-03-07 15:44:47 -05:00
parent 27ee4739cc
commit 6cb9cf6539
4 changed files with 99 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
simulator-prims.rkt
View File

@ -23,7 +23,7 @@
cname]
...
[else
(void)]
(make-undefined)]
)))))]))

27
simulator-structs.rkt
View File

@ -5,9 +5,19 @@
(require "il-structs.rkt")
(define-struct: machine ([val : Any]
[proc : Any]
[env : (Listof Any)]
(define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean Null
primitive-proc
closure
undefined
(Pairof PrimitiveValue PrimitiveValue)
)))
(define-type SlotValue (U PrimitiveValue toplevel))
(define-struct: machine ([val : SlotValue]
[proc : SlotValue]
[env : (Listof SlotValue)]
[control : (Listof frame)]
[pc : Natural] ;; program counter
@ -25,11 +35,18 @@
#:transparent)
;; Primitive procedure wrapper
(define-struct: primitive-proc ([f : (Any * -> Any)])
(define-struct: primitive-proc ([f : (PrimitiveValue * -> PrimitiveValue)])
#:transparent)
;; Compiled procedure closures
(define-struct: closure ([label : Symbol]
[vals : (Listof Any)])
[vals : (Listof SlotValue)])
#:transparent)
;; undefined value
(define-struct: undefined ()
#:transparent)

57
simulator.rkt
View File

@ -20,7 +20,7 @@
(: new-machine ((Listof Statement) -> machine))
(define (new-machine program-text)
(make-machine (void) (void) '() '() 0 (list->vector program-text)))
(make-machine (make-undefined) (make-undefined) '() '() 0 (list->vector program-text)))
(: can-step? (machine -> Boolean))
@ -75,7 +75,7 @@
(: step-assign-immediate (machine AssignImmediateStatement -> machine))
(define (step-assign-immediate m stmt)
(let: ([t : Target (AssignImmediateStatement-target stmt)]
[v : Any (evaluate-oparg m (AssignImmediateStatement-value stmt))])
[v : SlotValue (evaluate-oparg m (AssignImmediateStatement-value stmt))])
(cond [(eq? t 'proc)
(proc-update m v)]
[(eq? t 'val)
@ -92,7 +92,7 @@
[(= n 0)
m]
[else
(loop (env-push m (void))
(loop (env-push m (make-undefined))
(sub1 n))])))
(: step-pop-environment (machine PopEnvironment -> machine))
@ -146,7 +146,13 @@
(machine-val m)))]
[(CheckToplevelBound!? op)
(error 'step-perform)]
(let: ([a-top : toplevel (ensure-toplevel (env-ref m (CheckToplevelBound!-depth op)))])
(cond
[(undefined? (list-ref (toplevel-vals a-top) (CheckToplevelBound!-pos op)))
(error 'check-toplevel-bound! "Unbound identifier ~s" (CheckToplevelBound!-name op))]
[else
m]))]
[(ExtendEnvironment/Prefix!? op)
(env-push m
(make-toplevel (map lookup-primitive
@ -157,11 +163,11 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(: evaluate-oparg (machine OpArg -> Any))
(: evaluate-oparg (machine OpArg -> SlotValue))
(define (evaluate-oparg m an-oparg)
(cond
[(Const? an-oparg)
(Const-const an-oparg)]
(ensure-primitive-value (Const-const an-oparg))]
[(Label? an-oparg)
(Label-name an-oparg)]
[(Reg? an-oparg)
@ -174,10 +180,39 @@
[(EnvLexicalReference? an-oparg)
(list-ref (machine-env m) (EnvLexicalReference-depth an-oparg))]
[(EnvWholePrefixReference? an-oparg)
;; TODO: check that the value is a prefix value.
(unless (toplevel? (list-ref (machine-env m)
(EnvWholePrefixReference-depth an-oparg)))
(error 'evaluate-oparg "Internal error: not a toplevel at depth ~s"
(EnvWholePrefixReference-depth an-oparg)))
(list-ref (machine-env m) (EnvWholePrefixReference-depth an-oparg))]))
(: ensure-primitive-value (Any -> PrimitiveValue))
;; Make sure the value is primitive.
(define (ensure-primitive-value val)
(let: loop : PrimitiveValue ([v : Any val])
(cond
[(string? v)
v]
[(symbol? v)
v]
[(number? v)
v]
[(boolean? v)
v]
[(null? v)
v]
[(cons? v)
(cons (loop (car v)) (loop (cdr v)))]
[(primitive-proc? v)
v]
[(closure? v)
v]
[(undefined? v)
v]
[else
(error 'ensure-primitive-value "Unable to coerse Const ~s to a primitive value" v)])))
(: ensure-symbol (Any -> Symbol))
;; Make sure the value is a symbol.
(define (ensure-symbol v)
@ -205,19 +240,19 @@
(: val-update (machine Any -> machine))
(: val-update (machine SlotValue -> machine))
(define (val-update m v)
(match m
[(struct machine (val proc env control pc text))
(make-machine v proc env control pc text)]))
(: proc-update (machine Any -> machine))
(: proc-update (machine SlotValue -> machine))
(define (proc-update m v)
(match m
[(struct machine (val proc env control pc text))
(make-machine val v env control pc text)]))
(: env-push (machine Any -> machine))
(: env-push (machine SlotValue -> machine))
(define (env-push m v)
(match m
[(struct machine (val proc env control pc text))
@ -229,7 +264,7 @@
[(struct machine (val proc env control pc text))
(list-ref env i)]))
(: env-mutate (machine Natural Any -> machine))
(: env-mutate (machine Natural SlotValue -> machine))
(define (env-mutate m i v)
(match m
[(struct machine (val proc env control pc text))

38
test-simulator.rkt
View File

@ -47,12 +47,12 @@
;; Assigning to val
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42))))])
(test (machine-val m) (void))
(test (machine-val m) (make-undefined))
(test (machine-val (step m)) 42))
;; Assigning to proc
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const 42))))])
(test (machine-proc m) (void))
(test (machine-proc m) (make-undefined))
(test (machine-proc (step m)) 42))
@ -67,19 +67,19 @@
(let* ([m (new-machine `(,(make-PushEnvironment 2)
,(make-AssignImmediateStatement (make-EnvLexicalReference 1) (make-Const 42))))]
[m (run m)])
(test (machine-env m) `(,(void) 42)))
(test (machine-env m) `(,(make-undefined) 42)))
;; Assigning to another environment reference
(let* ([m (new-machine `(,(make-PushEnvironment 2)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0) (make-Const 42))))]
[m (run m)])
(test (machine-env m) `(42 ,(void))))
(test (machine-env m) `(42 ,(make-undefined))))
;; PushEnv
(let ([m (new-machine `(,(make-PushEnvironment 20)))])
(test (machine-env (run m)) (build-list 20 (lambda (i) (void)))))
(test (machine-env (run m)) (build-list 20 (lambda (i) (make-undefined)))))
;; PopEnv
@ -233,14 +233,14 @@
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-PerformStatement (make-SetToplevel! 0 0 'some-variable))))])
(run m)
(void (run m))
;; FIXME: I'm hitting what appears to be a Typed Racket bug that prevents me from inspecting
;; the toplevel structure in the environment... :(
)
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable another)))
,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-PerformStatement (make-SetToplevel! 0 1 'another))))])
(run m)
(void (run m))
;; FIXME: I'm hitting what appears to be a Typed Racket bug that prevents me from inspecting
;; the toplevel structure in the environment... :(
)
@ -248,7 +248,29 @@
,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-PushEnvironment 5)
,(make-PerformStatement (make-SetToplevel! 5 0 'some-variable))))])
(run m)
(void (run m))
;; FIXME: I'm hitting what appears to be a Typed Racket bug that prevents me from inspecting
;; the toplevel structure in the environment... :(
)
;; check-toplevel-bound
;; This should produce an error.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-PerformStatement (make-CheckToplevelBound! 0 0 'some-variable))))])
(with-handlers ((exn:fail? (lambda (exn)
(void))))
(run m)
(raise "I expected an error")))
;; check-toplevel-bound shouldn't fail here.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-PerformStatement (make-SetToplevel! 0 0 'some-variable))
,(make-PerformStatement (make-CheckToplevelBound! 0 0 'some-variable))))])
(void (run m)))