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

testing the simulator

Browse Source
This commit is contained in:
Danny Yoo 2011-04-11 15:57:21 -04:00
parent 18736b41a1
commit 5fa7af7037
3 changed files with 106 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compile.rkt
View File

@ -372,7 +372,7 @@
(make-instruction-sequence
`(,(make-PerformStatement
(make-UnspliceRestFromStack!
(make-Const (add1 (Lam-num-parameters exp)))
(make-Const (Lam-num-parameters exp))
(make-SubtractArg (make-Reg 'argcount)
(make-Const (Lam-num-parameters exp)))))))
empty-instruction-sequence)]

35
simulator.rkt
View File

@ -316,7 +316,24 @@
(length arg-list)
-1)))
'ok)]
[(UnspliceRestFromStack!? op)
(let: ([depth : Natural (ensure-natural
(evaluate-oparg m (UnspliceRestFromStack!-depth op)))]
[len : Natural (ensure-natural
(evaluate-oparg m (UnspliceRestFromStack!-length op)))])
(let ([rest-arg (list->mutable-pair-list (map ensure-primitive-value
(take (drop (machine-env m) depth) len)))])
(set-machine-env! m
(append (take (machine-env m) depth)
(list rest-arg)
(drop (machine-env m) (+ depth len))))
(set-machine-stack-size! m (ensure-natural
(+ (machine-stack-size m)
(add1 (- len)))))
(set-machine-argcount! m (ensure-natural (+ (ensure-natural (machine-argcount m))
(add1 (- len)))))
'ok))]
[(RestoreControl!? op)
(let: ([tag-value : ContinuationPromptTagValue
@ -528,7 +545,14 @@
(drop-continuation-to-tag (rest frames) tag)])]))]))
(: list->mutable-pair-list ((Listof PrimitiveValue) -> PrimitiveValue))
(define (list->mutable-pair-list rand-vals)
(let: loop : PrimitiveValue ([rand-vals : (Listof PrimitiveValue) rand-vals])
(cond [(empty? rand-vals)
null]
[else
(make-MutablePair (first rand-vals)
(loop (rest rand-vals)))])))
@ -569,12 +593,7 @@
[(cdr)
(MutablePair-t (ensure-mutable-pair (first rand-vals)))]
[(list)
(let: loop : PrimitiveValue ([rand-vals : (Listof PrimitiveValue) rand-vals])
(cond [(empty? rand-vals)
null]
[else
(make-MutablePair (first rand-vals)
(loop (rest rand-vals)))]))]
(list->mutable-pair-list rand-vals)]
[(null?)
(null? (first rand-vals))]
[(not)

79
test-simulator.rkt
View File

@ -521,4 +521,81 @@
(test (machine-argcount m)
5)
(test (machine-env m)
'("hello" "world" 1 2 3)))
'("hello" "world" 1 2 3)))
;; Testing immediate pushing
(let ([m (new-machine `(,(make-PushImmediateOntoEnvironment (make-Const "this is a message")
#f)))])
(run! m)
(test (machine-env m)
'("this is a message")))
(let ([m (new-machine `(,(make-PushImmediateOntoEnvironment (make-Const "this is a message")
#t)))])
(run! m)
(test (machine-env m)
`(,(box "this is a message"))))
(let ([m (new-machine `(,(make-PushImmediateOntoEnvironment (make-Const "this is a message")
#f)
,(make-PushImmediateOntoEnvironment (make-Const "again")
#f)
))])
(run! m)
(test (machine-env m)
'("again" "this is a message")))
(let ([m (new-machine `(,(make-PushImmediateOntoEnvironment (make-Const "this is a message")
#f)
,(make-PushImmediateOntoEnvironment (make-Const "again")
#t)
))])
(run! m)
(test (machine-env m)
`(,(box "again") "this is a message")))
;; testing rest splicing
(let ([m (new-machine `(,(make-PushEnvironment 1 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const "hello"))
,(make-AssignImmediateStatement 'argcount (make-Const 1))
,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0)
(make-Const 1)))))])
(run! m)
(test (machine-argcount m)
1)
(test (machine-env m)
(list (make-MutablePair "hello" null))))
(let ([m (new-machine
`(,(make-PushEnvironment 5 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const "hello"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const "world"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f)
(make-Const 'x))
,(make-AssignImmediateStatement (make-EnvLexicalReference 3 #f)
(make-Const 'y))
,(make-AssignImmediateStatement (make-EnvLexicalReference 4 #f)
(make-Const 'z))
,(make-AssignImmediateStatement 'argcount (make-Const 5))
,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 2) (make-Const 3)))))])
(run! m)
(test (machine-argcount m)
3)
(test (machine-env m)
(list "hello"
"world"
(make-MutablePair 'x (make-MutablePair 'y (make-MutablePair 'z null))))))