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

test cases running

Browse Source
This commit is contained in:
Danny Yoo 2011-04-17 13:12:48 -04:00
parent d7648c4ae7
commit 421c826564
4 changed files with 39 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
bootstrapped-primitives.rkt
View File

@ -61,7 +61,7 @@
,(make-PerformStatement
(make-RestoreControl! default-continuation-prompt-tag))
,(make-PerformStatement (make-RestoreEnvironment!))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc)))))))
@ -174,11 +174,11 @@
,(make-TestAndBranchStatement 'one? 'argcount on-single-value)
;; values simply keeps the values on the stack, preserves the argcount, and does a return
;; to the multiple-value-return address.
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel/MultipleValueReturn))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))
,on-single-value
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
,(make-PopEnvironment (make-Const 1) (make-Const 0))
,(make-PopControlFrame)

4
simulator-structs.rkt
View File

@ -66,7 +66,7 @@
#:transparent)
(define-struct: CallFrame ([return : (U Symbol LinkedLabel)]
(define-struct: CallFrame ([return : LinkedLabel]
;; The procedure being called. Used to optimize self-application
[proc : (U closure #f)]
;; TODO: add continuation marks
@ -76,7 +76,7 @@
#:mutable) ;; mutable because we want to allow mutation of proc.
(define-struct: PromptFrame ([tag : ContinuationPromptTagValue]
[return : (U Symbol LinkedLabel)]
[return : LinkedLabel]
[env-depth : Natural]
[temps : (HashTable Symbol PrimitiveValue)]
[marks : (HashTable PrimitiveValue PrimitiveValue)])

68
simulator.rkt
View File

@ -516,46 +516,6 @@
[else
(error 'apply-primitive-procedure)]))]
[(GetControlStackLabel? op)
(target-updater! m (let ([frame (ensure-frame (first (machine-control m)))])
(cond
[(GenericFrame? frame)
(error 'GetControlStackLabel)]
[(PromptFrame? frame)
(let ([label (PromptFrame-return frame)])
(cond
[(symbol? label)
label]
[(LinkedLabel? label)
(LinkedLabel-label label)]))]
[(CallFrame? frame)
(let ([label (CallFrame-return frame)])
(cond
[(symbol? label)
label]
[(LinkedLabel? label)
(LinkedLabel-label label)]))])))]
[(GetControlStackLabel/MultipleValueReturn? op)
(target-updater! m (let ([frame (ensure-frame (first (machine-control m)))])
(cond
[(GenericFrame? frame)
(error 'GetControlStackLabel/MultipleValueReturn)]
[(PromptFrame? frame)
(let ([label (PromptFrame-return frame)])
(cond
[(symbol? label)
(error 'GetControlStackLabel/MultipleValueReturn)]
[(LinkedLabel? label)
(LinkedLabel-linked-to label)]))]
[(CallFrame? frame)
(let ([label (CallFrame-return frame)])
(cond
[(symbol? label)
(error 'GetControlStackLabel/MultipleValueReturn)]
[(LinkedLabel? label)
(LinkedLabel-linked-to label)]))])))]
[(CaptureEnvironment? op)
(target-updater! m (make-CapturedEnvironment (drop (machine-env m)
(CaptureEnvironment-skip op))))]
@ -755,7 +715,33 @@
[(SubtractArg? an-oparg)
(- (ensure-number (evaluate-oparg m (SubtractArg-lhs an-oparg)))
(ensure-number (evaluate-oparg m (SubtractArg-rhs an-oparg))))]))
(ensure-number (evaluate-oparg m (SubtractArg-rhs an-oparg))))]
[(ControlStackLabel? an-oparg)
(let ([frame (ensure-frame (first (machine-control m)))])
(cond
[(GenericFrame? frame)
(error 'GetControlStackLabel)]
[(PromptFrame? frame)
(let ([label (PromptFrame-return frame)])
(LinkedLabel-label label))]
[(CallFrame? frame)
(let ([label (CallFrame-return frame)])
(LinkedLabel-label label))]))]
[(ControlStackLabel/MultipleValueReturn? an-oparg)
(let ([frame (ensure-frame (first (machine-control m)))])
(cond
[(GenericFrame? frame)
(error 'GetControlStackLabel/MultipleValueReturn)]
[(PromptFrame? frame)
(let ([label (PromptFrame-return frame)])
(LinkedLabel-linked-to label))]
[(CallFrame? frame)
(let ([label (CallFrame-return frame)])
(LinkedLabel-linked-to label))]))]))
(: ensure-closure-or-false (SlotValue -> (U closure #f)))

14
test-simulator.rkt
View File

@ -485,19 +485,19 @@
(list 126389 42 (make-toplevel '(+) (list (lookup-primitive '+))))))
;; GetControlStackLabel
;; ControlStackLabel
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
foo
,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))))])
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))))])
(test (machine-proc (run! m))
'foo))
;; GetControlStackLabel
;; ControlStackLabel
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
,(make-PushControlFrame/Call (make-LinkedLabel 'foo-single 'foo-multiple))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-GotoStatement (make-Reg 'proc))
foo-single
,(make-AssignImmediateStatement 'val (make-Const "single"))
@ -510,7 +510,7 @@
"single"))
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
,(make-PushControlFrame/Call (make-LinkedLabel 'foo-single 'foo-multiple))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel/MultipleValueReturn))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
,(make-GotoStatement (make-Reg 'proc))
foo-single
,(make-AssignImmediateStatement 'val (make-Const "single"))
@ -526,7 +526,7 @@
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
,(make-PushControlFrame/Prompt default-continuation-prompt-tag
(make-LinkedLabel 'foo-single 'foo-multiple))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-GotoStatement (make-Reg 'proc))
foo-single
,(make-AssignImmediateStatement 'val (make-Const "single"))
@ -540,7 +540,7 @@
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
,(make-PushControlFrame/Prompt default-continuation-prompt-tag
(make-LinkedLabel 'foo-single 'foo-multiple))
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel/MultipleValueReturn))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
,(make-GotoStatement (make-Reg 'proc))
foo-single
,(make-AssignImmediateStatement 'val (make-Const "single"))