changing test and branch's test structure from symbols. Some test will need to take more that one operand, eventually.

This commit is contained in:
Danny Yoo 2011-04-29 14:08:11 -04:00
parent e5509eecd3
commit 5d674b18d5
10 changed files with 214 additions and 89 deletions

View File

@ -193,21 +193,21 @@ EOF
[(TestAndBranchStatement? stmt) [(TestAndBranchStatement? stmt)
(let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)]) (let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)])
(cond (cond
[(eq? test 'false?) [(TestFalse? test)
(format "if (~a === false) { ~a }" (format "if (~a === false) { ~a }"
(assemble-oparg (TestAndBranchStatement-operand stmt)) (assemble-oparg (TestFalse-operand test))
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))] (assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]
[(eq? test 'one?) [(TestOne? test)
(format "if (~a === 1) { ~a }" (format "if (~a === 1) { ~a }"
(assemble-oparg (TestAndBranchStatement-operand stmt)) (assemble-oparg (TestOne-operand test))
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))] (assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]
[(eq? test 'zero?) [(TestZero? test)
(format "if (~a === 0) { ~a }" (format "if (~a === 0) { ~a }"
(assemble-oparg (TestAndBranchStatement-operand stmt)) (assemble-oparg (TestZero-operand test))
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))] (assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]
[(eq? test 'primitive-procedure?) [(TestPrimitiveProcedure? test)
(format "if (typeof(~a) === 'function') { ~a };" (format "if (typeof(~a) === 'function') { ~a };"
(assemble-oparg (TestAndBranchStatement-operand stmt)) (assemble-oparg (TestPrimitiveProcedure-operand test))
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]))] (assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]))]
[(GotoStatement? stmt) [(GotoStatement? stmt)

View File

@ -174,8 +174,8 @@
[on-single-value (make-label 'onSingleValue)]) [on-single-value (make-label 'onSingleValue)])
`(,(make-GotoStatement (make-Label after-values-body-defn)) `(,(make-GotoStatement (make-Label after-values-body-defn))
,values-entry ,values-entry
,(make-TestAndBranchStatement 'one? (make-Reg 'argcount) on-single-value) ,(make-TestAndBranchStatement (make-TestOne (make-Reg 'argcount)) on-single-value)
,(make-TestAndBranchStatement 'zero? (make-Reg 'argcount) on-zero-values) ,(make-TestAndBranchStatement (make-TestZero (make-Reg 'argcount)) on-zero-values)
;; Common case: we're running multiple values. Put the first in the val register ;; Common case: we're running multiple values. Put the first in the val register
;; and go to the multiple value return. ;; and go to the multiple value return.

View File

@ -118,8 +118,7 @@
(: collect-primitive-command (PrimitiveCommand -> (Listof Symbol))) (: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
(define (collect-primitive-command op) (define (collect-primitive-command op)
empty (cond
#;(cond
[(CheckToplevelBound!? op) [(CheckToplevelBound!? op)
empty] empty]
[(CheckClosureArity!? op) [(CheckClosureArity!? op)

View File

@ -49,10 +49,11 @@
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignImmediateStatement target (make-Reg 'val)))))))))) `(,(make-AssignImmediateStatement target (make-Reg 'val))))))))))
(define-struct: lam+cenv ([lam : Lam] (define-struct: lam+cenv ([lam : (U Lam CaseLam)]
[cenv : CompileTimeEnvironment])) [cenv : CompileTimeEnvironment]))
(: collect-all-lams (Expression -> (Listof lam+cenv))) (: collect-all-lams (Expression -> (Listof lam+cenv)))
;; Finds all the lambdas in the expression. ;; Finds all the lambdas in the expression.
(define (collect-all-lams exp) (define (collect-all-lams exp)
@ -79,6 +80,12 @@
(cons (make-lam+cenv exp cenv) (cons (make-lam+cenv exp cenv)
(loop (Lam-body exp) (loop (Lam-body exp)
(extract-lambda-cenv exp cenv)))] (extract-lambda-cenv exp cenv)))]
[(CaseLam? exp)
(cons (make-lam+cenv exp cenv)
(apply append (map (lambda: ([lam : Lam])
(loop lam cenv))
(CaseLam-clauses exp))))]
[(Seq? exp) [(Seq? exp)
(apply append (map (lambda: ([e : Expression]) (loop e cenv)) (apply append (map (lambda: ([e : Expression]) (loop e cenv))
(Seq-actions exp)))] (Seq-actions exp)))]
@ -163,6 +170,8 @@
(compile-branch exp cenv target linkage)] (compile-branch exp cenv target linkage)]
[(Lam? exp) [(Lam? exp)
(compile-lambda exp cenv target linkage)] (compile-lambda exp cenv target linkage)]
[(CaseLam? exp)
(compile-case-lambda exp cenv target linkage)]
[(Seq? exp) [(Seq? exp)
(compile-sequence (Seq-actions exp) (compile-sequence (Seq-actions exp)
cenv cenv
@ -380,8 +389,7 @@
p-code p-code
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,(make-TestAndBranchStatement 'false? `(,(make-TestAndBranchStatement (make-TestFalse (make-Reg 'val))
(make-Reg 'val)
f-branch))) f-branch)))
t-branch t-branch
c-code c-code
@ -456,13 +464,90 @@
`(,(make-AssignPrimOpStatement `(,(make-AssignPrimOpStatement
target target
(make-MakeCompiledProcedure (Lam-entry-label exp) (make-MakeCompiledProcedure (Lam-entry-label exp)
(if (Lam-rest? exp) (Lam-arity exp)
(make-ArityAtLeast (Lam-num-parameters exp))
(Lam-num-parameters exp))
(Lam-closure-map exp) (Lam-closure-map exp)
(Lam-name exp))))) (Lam-name exp)))))
singular-context-check)))) singular-context-check))))
(: compile-case-lambda (CaseLam CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Similar to compile-lambda.
(define (compile-case-lambda exp cenv target linkage)
(let ([singular-context-check (emit-singular-context linkage)]
[n (length (CaseLam-clauses exp))])
;; We have to build all the lambda values, and then create a single CaseLam that holds onto
;; all of them.
(end-with-linkage
linkage
cenv
(append-instruction-sequences
;; Make some temporary space for the lambdas
(make-instruction-sequence
`(,(make-PushEnvironment n #f)))
;; Compile each of the lambdas
(apply append-instruction-sequences
(map (lambda: ([lam : Lam]
[target : Target])
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
target
(make-MakeCompiledProcedure (Lam-entry-label lam)
(Lam-arity lam)
(shift-closure-map (Lam-closure-map lam) n)
(Lam-name lam))))))
(CaseLam-clauses exp)
(build-list (length (CaseLam-clauses exp))
(lambda: ([i : Natural])
(make-EnvLexicalReference i #f)))))
;; Make the case lambda as a regular compiled procedure. Its closed values are the lambdas.
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
target
(make-MakeCompiledProcedure (CaseLam-entry-label exp)
(merge-arities (map Lam-arity (CaseLam-clauses exp)))
(build-list n (lambda: ([i : Natural]) i))
(CaseLam-name exp)))
;; Finally, pop off the scratch space.
,(make-PopEnvironment (make-Const n) (make-Const 0))))
singular-context-check))))
(: Lam-arity (Lam -> Arity))
(define (Lam-arity lam)
(if (Lam-rest? lam)
(make-ArityAtLeast (Lam-num-parameters lam))
(Lam-num-parameters lam)))
(: shift-closure-map ((Listof Natural) Natural -> (Listof Natural)))
(define (shift-closure-map closure-map n)
(map (lambda: ([i : Natural]) (+ i n))
closure-map))
(: merge-arities ((Listof Arity) -> Arity))
(define (merge-arities arities)
(cond [(empty? (rest arities))
(first arities)]
[else
(let ([first-arity (first arities)]
[merged-rest (merge-arities (rest arities))])
(cond
[(AtomicArity? first-arity)
(cond [(AtomicArity? merged-rest)
(list first-arity merged-rest)]
[(listof-atomic-arity? merged-rest)
(cons first-arity merged-rest)])]
[(listof-atomic-arity? first-arity)
(cond [(AtomicArity? merged-rest)
(append first-arity (list merged-rest))]
[(listof-atomic-arity? merged-rest)
(append first-arity merged-rest)])]))]))
(: compile-lambda-shell (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-lambda-shell (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Write out code for lambda expressions, minus the closure map. ;; Write out code for lambda expressions, minus the closure map.
@ -517,6 +602,33 @@
lam-body-code))) lam-body-code)))
(: compile-case-lambda-body (CaseLam CompileTimeEnvironment -> InstructionSequence))
(define (compile-case-lambda-body exp cenv)
empty-instruction-sequence
#;(append-instruction-sequences
(make-instruction-sequence
`(,(CaseLam-entry-label exp)))
(apply append-instruction-sequences
;; todo: Add the case-dispatch based on arity matching.
(map (lambda: ([lam : Lam]
[i : Natural])
(let ([not-match (make-label)])
(make-instruction-sequence
`(,(make-TestAndBranchStatement arity-mismatch?
(make-Const (Lam-arity lam))
(make-Reg 'argcount))
;; Set the procedure register to the lam
,(make-AssignImmediateStatement
'proc
(make-CaseLamRef (make-Reg 'proc) (make-Const i)))
,(make-GotoStatement (make-Label (Lam-entry-point lam)))
,not-match))))
(CaseLam-clauses exp)
(build-list (length (CaseLam-clauses)) (lambda: ([i : Natural]) i))))))
(: compile-lambda-bodies ((Listof lam+cenv) -> InstructionSequence)) (: compile-lambda-bodies ((Listof lam+cenv) -> InstructionSequence))
;; Compile several lambda bodies, back to back. ;; Compile several lambda bodies, back to back.
@ -525,9 +637,19 @@
[(empty? exps) [(empty? exps)
(make-instruction-sequence '())] (make-instruction-sequence '())]
[else [else
(append-instruction-sequences (compile-lambda-body (lam+cenv-lam (first exps)) (let: ([lam : (U Lam CaseLam) (lam+cenv-lam (first exps))]
(lam+cenv-cenv (first exps))) [cenv : CompileTimeEnvironment (lam+cenv-cenv (first exps))])
(compile-lambda-bodies (rest exps)))])) (cond
[(Lam? lam)
(append-instruction-sequences (compile-lambda-body lam
cenv)
(compile-lambda-bodies (rest exps)))]
[(CaseLam? lam)
(append-instruction-sequences
(compile-case-lambda-body lam cenv)
(compile-lambda-bodies (rest exps)))]))]))
(: extend-compile-time-environment/scratch-space (CompileTimeEnvironment Natural -> CompileTimeEnvironment)) (: extend-compile-time-environment/scratch-space (CompileTimeEnvironment Natural -> CompileTimeEnvironment))
@ -995,8 +1117,8 @@
(make-NextLinkage (linkage-context linkage))]) (make-NextLinkage (linkage-context linkage))])
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,(make-TestAndBranchStatement 'primitive-procedure? `(,(make-TestAndBranchStatement (make-TestPrimitiveProcedure
(make-Reg 'proc) (make-Reg 'proc))
primitive-branch))) primitive-branch)))
@ -1217,9 +1339,8 @@
`( `(
;; if the wrong number of arguments come in, die ;; if the wrong number of arguments come in, die
,(make-TestAndBranchStatement ,(make-TestAndBranchStatement
'zero? (make-TestZero (make-SubtractArg (make-Reg 'argcount)
(make-SubtractArg (make-Reg 'argcount) (make-Const context)))
(make-Const context))
after-value-check))) after-value-check)))
on-return on-return
(make-instruction-sequence (make-instruction-sequence
@ -1539,7 +1660,7 @@
next-linkage/keep-multiple-on-stack) next-linkage/keep-multiple-on-stack)
(make-instruction-sequence (make-instruction-sequence
`(,(make-TestAndBranchStatement 'zero? (make-Reg 'argcount) after-args-evaluated) `(,(make-TestAndBranchStatement (make-TestZero (make-Reg 'argcount)) after-args-evaluated)
;; In the common case where we do get values back, we push val onto the stack too, ;; In the common case where we do get values back, we push val onto the stack too,
;; so that we have n values on the stack before we jump to the procedure call. ;; so that we have n values on the stack before we jump to the procedure call.
,(make-PushImmediateOntoEnvironment (make-Reg 'val) #f))) ,(make-PushImmediateOntoEnvironment (make-Reg 'val) #f)))
@ -1726,6 +1847,13 @@
(Lam-closure-map exp)) (Lam-closure-map exp))
(Lam-entry-label exp))] (Lam-entry-label exp))]
[(CaseLam? exp)
(make-CaseLam (CaseLam-name exp)
(map (lambda: ([lam : Lam])
(ensure-lam (adjust-expression-depth lam n skip)))
(CaseLam-clauses exp))
(CaseLam-entry-label exp))]
[(Seq? exp) [(Seq? exp)
(make-Seq (map (lambda: ([action : Expression]) (make-Seq (map (lambda: ([action : Expression])
(adjust-expression-depth action n skip)) (adjust-expression-depth action n skip))

View File

@ -8,7 +8,7 @@
(define-type Expression (U Top Constant (define-type Expression (U Top Constant
ToplevelRef LocalRef ToplevelRef LocalRef
ToplevelSet ToplevelSet
Branch Lam Seq Splice App Branch CaseLam Lam Seq Splice App
Let1 Let1
LetVoid LetVoid
LetRec LetRec
@ -24,12 +24,10 @@
(define-struct: Constant ([v : Any]) #:transparent) (define-struct: Constant ([v : Any]) #:transparent)
(define-struct: ToplevelRef ([depth : Natural] (define-struct: ToplevelRef ([depth : Natural]
[pos : Natural]) [pos : Natural]) #:transparent)
#:transparent)
(define-struct: LocalRef ([depth : Natural] (define-struct: LocalRef ([depth : Natural]
[unbox? : Boolean]) [unbox? : Boolean]) #:transparent)
#:transparent)
(define-struct: ToplevelSet ([depth : Natural] (define-struct: ToplevelSet ([depth : Natural]
[pos : Natural] [pos : Natural]
@ -40,6 +38,10 @@
[consequent : Expression] [consequent : Expression]
[alternative : Expression]) #:transparent) [alternative : Expression]) #:transparent)
(define-struct: CaseLam ([name : (U Symbol False)]
[clauses : (Listof Lam)]
[entry-label : Symbol]) #:transparent)
(define-struct: Lam ([name : (U Symbol False)] (define-struct: Lam ([name : (U Symbol False)]
[num-parameters : Natural] [num-parameters : Natural]
[rest? : Boolean] [rest? : Boolean]
@ -53,45 +55,38 @@
[operands : (Listof Expression)]) #:transparent) [operands : (Listof Expression)]) #:transparent)
(define-struct: Let1 ([rhs : Expression] (define-struct: Let1 ([rhs : Expression]
[body : Expression]) [body : Expression]) #:transparent)
#:transparent)
(define-struct: LetVoid ([count : Natural] (define-struct: LetVoid ([count : Natural]
[body : Expression] [body : Expression]
[boxes? : Boolean]) [boxes? : Boolean]) #:transparent)
#:transparent)
(define-struct: LetRec ([procs : (Listof Lam)] (define-struct: LetRec ([procs : (Listof Lam)]
[body : Expression]) [body : Expression]) #:transparent)
#:transparent)
(define-struct: InstallValue ([count : Natural] ;; how many values to install (define-struct: InstallValue ([count : Natural] ;; how many values to install
[depth : Natural] ;; how many slots to skip [depth : Natural] ;; how many slots to skip
[body : Expression] [body : Expression]
[box? : Boolean]) [box? : Boolean]) #:transparent)
#:transparent)
(define-struct: BoxEnv ([depth : Natural] (define-struct: BoxEnv ([depth : Natural]
[body : Expression]) [body : Expression]) #:transparent)
#:transparent)
(define-struct: WithContMark ([key : Expression] (define-struct: WithContMark ([key : Expression]
[value : Expression] [value : Expression]
[body : Expression]) [body : Expression]) #:transparent)
#:transparent)
(define-struct: ApplyValues ([proc : Expression] (define-struct: ApplyValues ([proc : Expression]
[args-expr : Expression]) [args-expr : Expression]) #:transparent)
#:transparent)
;; Multiple value definition ;; Multiple value definition
(define-struct: DefValues ([ids : (Listof ToplevelRef)] (define-struct: DefValues ([ids : (Listof ToplevelRef)]
[rhs : Expression]) [rhs : Expression]) #:transparent)
#:transparent)

View File

@ -178,8 +178,9 @@
(define-struct: PerformStatement ([op : PrimitiveCommand]) (define-struct: PerformStatement ([op : PrimitiveCommand])
#:transparent) #:transparent)
(define-struct: TestAndBranchStatement ([op : PrimitiveTest] (define-struct: TestAndBranchStatement ([op : PrimitiveTest]
[operand : OpArg]
[label : Symbol]) [label : Symbol])
#:transparent) #:transparent)
@ -195,6 +196,7 @@
MakeCompiledProcedureShell MakeCompiledProcedureShell
ApplyPrimitiveProcedure ApplyPrimitiveProcedure
MakeBoxedEnvironmentValue MakeBoxedEnvironmentValue
CaptureEnvironment CaptureEnvironment
@ -215,6 +217,7 @@
[display-name : (U Symbol False)]) [display-name : (U Symbol False)])
#:transparent) #:transparent)
;; Constructs a closure shell. Like MakeCompiledProcedure, but doesn't ;; Constructs a closure shell. Like MakeCompiledProcedure, but doesn't
;; bother with trying to capture the free variables. ;; bother with trying to capture the free variables.
(define-struct: MakeCompiledProcedureShell ([label : Symbol] (define-struct: MakeCompiledProcedureShell ([label : Symbol]
@ -261,21 +264,19 @@
;; The following is used with TestStatement: each is passed the register-rand and ;; Primitive tests (used with TestAndBranch)
;; is expected to
(define-type PrimitiveTest (U (define-type PrimitiveTest (U
;; register -> boolean
;; Meant to branch when the register value is false.
'false?
'one? TestFalse
'zero? TestOne
TestZero
;; register -> boolean TestPrimitiveProcedure
;; Meant to branch when the register value is a primitive
;; procedure
'primitive-procedure?
)) ))
(define-struct: TestFalse ([operand : OpArg]) #:transparent)
(define-struct: TestOne ([operand : OpArg]) #:transparent)
(define-struct: TestZero ([operand : OpArg]) #:transparent)
(define-struct: TestPrimitiveProcedure ([operand : OpArg]) #:transparent)
@ -473,11 +474,13 @@
(define-type Arity (U Natural ArityAtLeast (Listof (U Natural ArityAtLeast)))) ;; Arity
(define-type Arity (U AtomicArity (Listof (U AtomicArity))))
(define-type AtomicArity (U Natural ArityAtLeast))
(define-struct: ArityAtLeast ([value : Natural]) (define-struct: ArityAtLeast ([value : Natural])
#:transparent) #:transparent)
(define-predicate AtomicArity? AtomicArity)
(define-predicate listof-atomic-arity? (Listof (U Natural ArityAtLeast))) (define-predicate listof-atomic-arity? (Listof AtomicArity))

View File

@ -163,7 +163,6 @@
;; undefined value ;; undefined value
(define-struct: undefined () (define-struct: undefined ()
#:transparent) #:transparent)

View File

@ -199,17 +199,18 @@
(: step-test-and-branch! (machine TestAndBranchStatement -> 'ok)) (: step-test-and-branch! (machine TestAndBranchStatement -> 'ok))
(define (step-test-and-branch! m stmt) (define (step-test-and-branch! m stmt)
(let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)] (let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)])
[argval : SlotValue (evaluate-oparg m (TestAndBranchStatement-operand stmt))])
(if (let: ([v : Boolean (cond (if (let: ([v : Boolean (cond
[(eq? test 'false?) [(TestFalse? test)
(not argval)] (not (evaluate-oparg m (TestFalse-operand test)))]
[(eq? test 'one?) [(TestOne? test)
(= (ensure-natural argval) 1)] (= (ensure-natural (evaluate-oparg m (TestOne-operand test)))
[(eq? test 'zero?) 1)]
(= (ensure-natural argval) 0)] [(TestZero? test)
[(eq? test 'primitive-procedure?) (= (ensure-natural (evaluate-oparg m (TestZero-operand test)))
(primitive-proc? argval)])]) 0)]
[(TestPrimitiveProcedure? test)
(primitive-proc? (evaluate-oparg m (TestPrimitiveProcedure-operand test)))])])
v) v)
(jump! m (TestAndBranchStatement-label stmt)) (jump! m (TestAndBranchStatement-label stmt))
'ok))) 'ok)))

View File

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

View File

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