From 44beaffea6476c170b35a6e16c6ad95fc4e70c39 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Thu, 21 Apr 2011 15:25:56 -0400 Subject: [PATCH] test cases --- assemble.rkt | 10 ++++++--- bootstrapped-primitives.rkt | 2 +- compiler.rkt | 41 +++++++++++++++++++++++++++++-------- il-structs.rkt | 3 ++- lexical-env.rkt | 16 ++++++++++++--- simulator.rkt | 4 +++- test-assemble.rkt | 12 +++++------ test-simulator.rkt | 12 +++++------ 8 files changed, 71 insertions(+), 29 deletions(-) diff --git a/assemble.rkt b/assemble.rkt index ef48a3c..adb1726 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -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) diff --git a/bootstrapped-primitives.rkt b/bootstrapped-primitives.rkt index 8aa8b87..72d47f6 100644 --- a/bootstrapped-primitives.rkt +++ b/bootstrapped-primitives.rkt @@ -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)) diff --git a/compiler.rkt b/compiler.rkt index 0c6eef4..b223f89 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -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 diff --git a/il-structs.rkt b/il-structs.rkt index aadc63a..725269d 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -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 diff --git a/lexical-env.rkt b/lexical-env.rkt index 740a5b5..df1f0b4 100644 --- a/lexical-env.rkt +++ b/lexical-env.rkt @@ -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 Boolean)) +(define (lex-referencecompile-time-environment ((Listof EnvReference) ParseTimeEnvironment ParseTimeEnvironment (Listof Symbol) -> ParseTimeEnvironment)) diff --git a/simulator.rkt b/simulator.rkt index 399684c..e5fbb44 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -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) diff --git a/test-assemble.rkt b/test-assemble.rkt index f132224..e9b24f8 100644 --- a/test-assemble.rkt +++ b/test-assemble.rkt @@ -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 diff --git a/test-simulator.rkt b/test-simulator.rkt index b6253e0..0fd9b1a 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -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