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

test cases

Browse Source
This commit is contained in:
Danny Yoo 2011-04-21 15:25:56 -04:00
parent 7e4ba67db5
commit 44beaffea6
8 changed files with 71 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
assemble.rkt
View File

@ -195,15 +195,19 @@ EOF
(cond
[(eq? test 'false?)
(format "if (~a === false) { ~a }"
(assemble-reg (make-Reg (TestAndBranchStatement-register stmt)))
(assemble-oparg (TestAndBranchStatement-operand stmt))
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]
[(eq? test 'one?)
(format "if (~a === 1) { ~a }"
(assemble-reg (make-Reg (TestAndBranchStatement-register stmt)))
(assemble-oparg (TestAndBranchStatement-operand stmt))
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]
[(eq? test 'zero?)
(format "if (~a === 0) { ~a }"
(assemble-oparg (TestAndBranchStatement-operand stmt))
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]
[(eq? test 'primitive-procedure?)
(format "if (typeof(~a) === 'function') { ~a };"
(assemble-reg (make-Reg (TestAndBranchStatement-register stmt)))
(assemble-oparg (TestAndBranchStatement-operand stmt))
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]))]
[(GotoStatement? stmt)

2
bootstrapped-primitives.rkt
View File

@ -171,7 +171,7 @@
[on-single-value (make-label 'onSingleValue)])
`(,(make-GotoStatement (make-Label after-values-body-defn))
,values-entry
,(make-TestAndBranchStatement 'one? 'argcount on-single-value)
,(make-TestAndBranchStatement 'one? (make-Reg '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-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))

41
compiler.rkt
View File

@ -342,7 +342,7 @@
(append-instruction-sequences
(make-instruction-sequence
`(,(make-TestAndBranchStatement 'false?
'val
(make-Reg 'val)
f-branch)))
t-branch
c-code
@ -926,7 +926,7 @@
(append-instruction-sequences
(make-instruction-sequence
`(,(make-TestAndBranchStatement 'primitive-procedure?
'proc
(make-Reg 'proc)
(LabelLinkage-label primitive-branch))))
@ -1114,19 +1114,44 @@
(cond [(eq? target 'val)
;; This case happens for a function call that isn't in
;; tail position.
(let* ([proc-return-multiple (make-label 'procReturnMultiple)]
(let* ([n (NextLinkage/Expects-expects linkage)]
[proc-return-multiple (make-label 'procReturnMultiple)]
[proc-return (make-LinkedLabel (make-label 'procReturn)
proc-return-multiple)])
proc-return-multiple)]
[after-value-check (make-label 'afterValueCheck)]
[return-point-code
(cond
[(= n 1)
(append-instruction-sequences
proc-return-multiple
(make-instruction-sequence
`(,(make-PerformStatement
(make-RaiseContextExpectedValuesError! 1))))
proc-return)]
[else
(append-instruction-sequences
proc-return-multiple
(make-instruction-sequence
`(
;; if the wrong number of arguments come in, die
,(make-TestAndBranchStatement
'zero?
(make-SubtractArg (make-Reg 'argcount)
(make-Const n))
after-value-check)))
proc-return
(make-instruction-sequence
`(,(make-PerformStatement
(make-RaiseContextExpectedValuesError! n))))
after-value-check)])])
(append-instruction-sequences
(make-instruction-sequence
`(,(make-PushControlFrame/Call proc-return)))
maybe-install-jump-address
(make-instruction-sequence
`(,(make-GotoStatement entry-point-target)))
proc-return-multiple
(make-instruction-sequence `(,(make-PopEnvironment (make-Reg 'argcount)
(make-Const 0))))
proc-return))]
return-point-code))]
[else
;; This case happens for evaluating arguments, since the

3
il-structs.rkt
View File

@ -173,7 +173,7 @@
#:transparent)
(define-struct: TestAndBranchStatement ([op : PrimitiveTest]
[register : AtomicRegisterSymbol]
[operand : OpArg]
[label : Symbol])
#:transparent)
@ -263,6 +263,7 @@
'false?
'one?
'zero?
;; register -> boolean
;; Meant to branch when the register value is a primitive

16
lexical-env.rkt
View File

@ -114,8 +114,6 @@
cenv))
(: collect-lexical-references ((Listof LexicalAddress)
->
(Listof (U EnvLexicalReference EnvWholePrefixReference))))
@ -128,7 +126,12 @@
([addresses : (Listof LexicalAddress) addresses])
(cond
[(empty? addresses)
(append (set->list prefix-references) (set->list lexical-references))]
(append (set->list prefix-references)
((inst sort
EnvLexicalReference
EnvLexicalReference)
(set->list lexical-references)
lex-reference<?))]
[else
(let ([addr (first addresses)])
(cond
@ -143,6 +146,13 @@
(: lex-reference<? (EnvLexicalReference EnvLexicalReference -> Boolean))
(define (lex-reference<? x y)
(< (EnvLexicalReference-depth x)
(EnvLexicalReference-depth y)))
(: lexical-references->compile-time-environment ((Listof EnvReference) ParseTimeEnvironment ParseTimeEnvironment
(Listof Symbol)
-> ParseTimeEnvironment))

4
simulator.rkt
View File

@ -209,12 +209,14 @@
(: step-test-and-branch! (machine TestAndBranchStatement -> 'ok))
(define (step-test-and-branch! m stmt)
(let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)]
[argval : SlotValue (lookup-atomic-register m (TestAndBranchStatement-register stmt))])
[argval : SlotValue (evaluate-oparg m (TestAndBranchStatement-operand stmt))])
(if (let: ([v : Boolean (cond
[(eq? test 'false?)
(not argval)]
[(eq? test 'one?)
(= (ensure-natural argval) 1)]
[(eq? test 'zero?)
(= (ensure-natural argval) 0)]
[(eq? test 'primitive-procedure?)
(primitive-proc? argval)])])
v)

12
test-assemble.rkt
View File

@ -282,7 +282,7 @@
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const 42))
,(make-TestAndBranchStatement 'false? 'val 'onFalse)
,(make-TestAndBranchStatement 'false? (make-Reg 'val) 'onFalse)
,(make-AssignImmediateStatement 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end))
onFalse
@ -292,7 +292,7 @@
;; TestAndBranch: try the false branch
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const #f))
,(make-TestAndBranchStatement 'false? 'val 'onFalse)
,(make-TestAndBranchStatement 'false? (make-Reg 'val) 'onFalse)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end))
onFalse
@ -302,7 +302,7 @@
;; Test for primitive procedure
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+))
,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue)
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'val) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end))
onTrue
@ -313,7 +313,7 @@
;; Give a primitive procedure in val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))
,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue)
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'val) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end))
onTrue
@ -324,7 +324,7 @@
;; Give a primitive procedure in proc, but test val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue)
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'val) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end))
onTrue
@ -335,7 +335,7 @@
;; Give a primitive procedure in proc and test proc
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
,(make-TestAndBranchStatement 'primitive-procedure? 'proc 'onTrue)
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'proc) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end))
onTrue

12
test-simulator.rkt
View File

@ -207,7 +207,7 @@
;; TestAndBranch: try the true branch
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42))
,(make-TestAndBranchStatement 'false? 'val 'on-false)
,(make-TestAndBranchStatement 'false? (make-Reg 'val) 'on-false)
,(make-AssignImmediateStatement 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end))
on-false
@ -217,7 +217,7 @@
'ok))
;; TestAndBranch: try the false branch
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const #f))
,(make-TestAndBranchStatement 'false? 'val 'on-false)
,(make-TestAndBranchStatement 'false? (make-Reg 'val) 'on-false)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end))
on-false
@ -227,7 +227,7 @@
'ok))
;; Test for primitive procedure
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const '+))
,(make-TestAndBranchStatement 'primitive-procedure? 'val 'on-true)
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'val) 'on-true)
,(make-AssignImmediateStatement 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end))
on-true
@ -237,7 +237,7 @@
'ok))
;; Give a primitive procedure in val
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const (lookup-primitive '+)))
,(make-TestAndBranchStatement 'primitive-procedure? 'val 'on-true)
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'val) 'on-true)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end))
on-true
@ -247,7 +247,7 @@
'ok))
;; Give a primitive procedure in proc, but test val
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
,(make-TestAndBranchStatement 'primitive-procedure? 'val 'on-true)
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'val) 'on-true)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end))
on-true
@ -257,7 +257,7 @@
'not-a-procedure))
;; Give a primitive procedure in proc and test proc
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
,(make-TestAndBranchStatement 'primitive-procedure? 'proc 'on-true)
,(make-TestAndBranchStatement 'primitive-procedure? (make-Reg 'proc) 'on-true)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end))
on-true