From 5d674b18d5ec5e7e3a5c859d468a0fdb6e45ed86 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 29 Apr 2011 14:08:11 -0400 Subject: [PATCH] changing test and branch's test structure from symbols. Some test will need to take more that one operand, eventually. --- assemble.rkt | 16 ++-- bootstrapped-primitives.rkt | 4 +- collect-jump-targets.rkt | 3 +- compiler.rkt | 160 ++++++++++++++++++++++++++++++++---- expression-structs.rkt | 37 ++++----- il-structs.rkt | 35 ++++---- simulator-structs.rkt | 1 - simulator.rkt | 23 +++--- test-assemble.rkt | 12 +-- test-simulator.rkt | 12 +-- 10 files changed, 214 insertions(+), 89 deletions(-) diff --git a/assemble.rkt b/assemble.rkt index adb1726..b831454 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -193,21 +193,21 @@ EOF [(TestAndBranchStatement? stmt) (let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)]) (cond - [(eq? test 'false?) + [(TestFalse? test) (format "if (~a === false) { ~a }" - (assemble-oparg (TestAndBranchStatement-operand stmt)) + (assemble-oparg (TestFalse-operand test)) (assemble-jump (make-Label (TestAndBranchStatement-label stmt))))] - [(eq? test 'one?) + [(TestOne? test) (format "if (~a === 1) { ~a }" - (assemble-oparg (TestAndBranchStatement-operand stmt)) + (assemble-oparg (TestOne-operand test)) (assemble-jump (make-Label (TestAndBranchStatement-label stmt))))] - [(eq? test 'zero?) + [(TestZero? test) (format "if (~a === 0) { ~a }" - (assemble-oparg (TestAndBranchStatement-operand stmt)) + (assemble-oparg (TestZero-operand test)) (assemble-jump (make-Label (TestAndBranchStatement-label stmt))))] - [(eq? test 'primitive-procedure?) + [(TestPrimitiveProcedure? test) (format "if (typeof(~a) === 'function') { ~a };" - (assemble-oparg (TestAndBranchStatement-operand stmt)) + (assemble-oparg (TestPrimitiveProcedure-operand test)) (assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]))] [(GotoStatement? stmt) diff --git a/bootstrapped-primitives.rkt b/bootstrapped-primitives.rkt index ab70c57..60f9883 100644 --- a/bootstrapped-primitives.rkt +++ b/bootstrapped-primitives.rkt @@ -174,8 +174,8 @@ [on-single-value (make-label 'onSingleValue)]) `(,(make-GotoStatement (make-Label after-values-body-defn)) ,values-entry - ,(make-TestAndBranchStatement 'one? (make-Reg 'argcount) on-single-value) - ,(make-TestAndBranchStatement 'zero? (make-Reg 'argcount) on-zero-values) + ,(make-TestAndBranchStatement (make-TestOne (make-Reg 'argcount)) on-single-value) + ,(make-TestAndBranchStatement (make-TestZero (make-Reg 'argcount)) on-zero-values) ;; Common case: we're running multiple values. Put the first in the val register ;; and go to the multiple value return. diff --git a/collect-jump-targets.rkt b/collect-jump-targets.rkt index 12405b7..ac041d7 100644 --- a/collect-jump-targets.rkt +++ b/collect-jump-targets.rkt @@ -118,8 +118,7 @@ (: collect-primitive-command (PrimitiveCommand -> (Listof Symbol))) (define (collect-primitive-command op) - empty - #;(cond + (cond [(CheckToplevelBound!? op) empty] [(CheckClosureArity!? op) diff --git a/compiler.rkt b/compiler.rkt index 348b9a5..7142977 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -49,10 +49,11 @@ (make-instruction-sequence `(,(make-AssignImmediateStatement target (make-Reg 'val)))))))))) -(define-struct: lam+cenv ([lam : Lam] +(define-struct: lam+cenv ([lam : (U Lam CaseLam)] [cenv : CompileTimeEnvironment])) + (: collect-all-lams (Expression -> (Listof lam+cenv))) ;; Finds all the lambdas in the expression. (define (collect-all-lams exp) @@ -79,6 +80,12 @@ (cons (make-lam+cenv exp cenv) (loop (Lam-body exp) (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) (apply append (map (lambda: ([e : Expression]) (loop e cenv)) (Seq-actions exp)))] @@ -163,6 +170,8 @@ (compile-branch exp cenv target linkage)] [(Lam? exp) (compile-lambda exp cenv target linkage)] + [(CaseLam? exp) + (compile-case-lambda exp cenv target linkage)] [(Seq? exp) (compile-sequence (Seq-actions exp) cenv @@ -380,8 +389,7 @@ p-code (append-instruction-sequences (make-instruction-sequence - `(,(make-TestAndBranchStatement 'false? - (make-Reg 'val) + `(,(make-TestAndBranchStatement (make-TestFalse (make-Reg 'val)) f-branch))) t-branch c-code @@ -456,13 +464,90 @@ `(,(make-AssignPrimOpStatement target (make-MakeCompiledProcedure (Lam-entry-label exp) - (if (Lam-rest? exp) - (make-ArityAtLeast (Lam-num-parameters exp)) - (Lam-num-parameters exp)) + (Lam-arity exp) (Lam-closure-map exp) (Lam-name exp))))) 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)) ;; Write out code for lambda expressions, minus the closure map. @@ -517,7 +602,34 @@ 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 several lambda bodies, back to back. (define (compile-lambda-bodies exps) @@ -525,9 +637,19 @@ [(empty? exps) (make-instruction-sequence '())] [else - (append-instruction-sequences (compile-lambda-body (lam+cenv-lam (first exps)) - (lam+cenv-cenv (first exps))) - (compile-lambda-bodies (rest exps)))])) + (let: ([lam : (U Lam CaseLam) (lam+cenv-lam (first exps))] + [cenv : CompileTimeEnvironment (lam+cenv-cenv (first 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)) @@ -995,8 +1117,8 @@ (make-NextLinkage (linkage-context linkage))]) (append-instruction-sequences (make-instruction-sequence - `(,(make-TestAndBranchStatement 'primitive-procedure? - (make-Reg 'proc) + `(,(make-TestAndBranchStatement (make-TestPrimitiveProcedure + (make-Reg 'proc)) primitive-branch))) @@ -1217,9 +1339,8 @@ `( ;; if the wrong number of arguments come in, die ,(make-TestAndBranchStatement - 'zero? - (make-SubtractArg (make-Reg 'argcount) - (make-Const context)) + (make-TestZero (make-SubtractArg (make-Reg 'argcount) + (make-Const context))) after-value-check))) on-return (make-instruction-sequence @@ -1539,7 +1660,7 @@ next-linkage/keep-multiple-on-stack) (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, ;; so that we have n values on the stack before we jump to the procedure call. ,(make-PushImmediateOntoEnvironment (make-Reg 'val) #f))) @@ -1726,6 +1847,13 @@ (Lam-closure-map 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) (make-Seq (map (lambda: ([action : Expression]) (adjust-expression-depth action n skip)) diff --git a/expression-structs.rkt b/expression-structs.rkt index 034662d..fdd41d2 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -8,7 +8,7 @@ (define-type Expression (U Top Constant ToplevelRef LocalRef ToplevelSet - Branch Lam Seq Splice App + Branch CaseLam Lam Seq Splice App Let1 LetVoid LetRec @@ -24,12 +24,10 @@ (define-struct: Constant ([v : Any]) #:transparent) (define-struct: ToplevelRef ([depth : Natural] - [pos : Natural]) - #:transparent) + [pos : Natural]) #:transparent) (define-struct: LocalRef ([depth : Natural] - [unbox? : Boolean]) - #:transparent) + [unbox? : Boolean]) #:transparent) (define-struct: ToplevelSet ([depth : Natural] [pos : Natural] @@ -40,6 +38,10 @@ [consequent : Expression] [alternative : Expression]) #:transparent) +(define-struct: CaseLam ([name : (U Symbol False)] + [clauses : (Listof Lam)] + [entry-label : Symbol]) #:transparent) + (define-struct: Lam ([name : (U Symbol False)] [num-parameters : Natural] [rest? : Boolean] @@ -53,45 +55,38 @@ [operands : (Listof Expression)]) #:transparent) (define-struct: Let1 ([rhs : Expression] - [body : Expression]) - #:transparent) + [body : Expression]) #:transparent) + (define-struct: LetVoid ([count : Natural] [body : Expression] - [boxes? : Boolean]) - #:transparent) + [boxes? : Boolean]) #:transparent) (define-struct: LetRec ([procs : (Listof Lam)] - [body : Expression]) - #:transparent) + [body : Expression]) #:transparent) (define-struct: InstallValue ([count : Natural] ;; how many values to install [depth : Natural] ;; how many slots to skip [body : Expression] - [box? : Boolean]) - #:transparent) + [box? : Boolean]) #:transparent) (define-struct: BoxEnv ([depth : Natural] - [body : Expression]) - #:transparent) + [body : Expression]) #:transparent) (define-struct: WithContMark ([key : Expression] [value : Expression] - [body : Expression]) - #:transparent) + [body : Expression]) #:transparent) (define-struct: ApplyValues ([proc : Expression] - [args-expr : Expression]) - #:transparent) + [args-expr : Expression]) #:transparent) ;; Multiple value definition (define-struct: DefValues ([ids : (Listof ToplevelRef)] - [rhs : Expression]) - #:transparent) + [rhs : Expression]) #:transparent) diff --git a/il-structs.rkt b/il-structs.rkt index 545ce8f..3f24966 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -178,8 +178,9 @@ (define-struct: PerformStatement ([op : PrimitiveCommand]) #:transparent) + + (define-struct: TestAndBranchStatement ([op : PrimitiveTest] - [operand : OpArg] [label : Symbol]) #:transparent) @@ -194,6 +195,7 @@ MakeCompiledProcedure MakeCompiledProcedureShell ApplyPrimitiveProcedure + MakeBoxedEnvironmentValue @@ -215,6 +217,7 @@ [display-name : (U Symbol False)]) #:transparent) + ;; Constructs a closure shell. Like MakeCompiledProcedure, but doesn't ;; bother with trying to capture the free variables. (define-struct: MakeCompiledProcedureShell ([label : Symbol] @@ -261,21 +264,19 @@ -;; The following is used with TestStatement: each is passed the register-rand and -;; is expected to +;; Primitive tests (used with TestAndBranch) (define-type PrimitiveTest (U - ;; register -> boolean - ;; Meant to branch when the register value is false. - 'false? - 'one? - 'zero? - - ;; register -> boolean - ;; Meant to branch when the register value is a primitive - ;; procedure - 'primitive-procedure? + TestFalse + TestOne + TestZero + TestPrimitiveProcedure )) +(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]) #:transparent) - -(define-predicate listof-atomic-arity? (Listof (U Natural ArityAtLeast))) +(define-predicate AtomicArity? AtomicArity) +(define-predicate listof-atomic-arity? (Listof AtomicArity)) diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 7914a5b..cf49a86 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -163,7 +163,6 @@ - ;; undefined value (define-struct: undefined () #:transparent) diff --git a/simulator.rkt b/simulator.rkt index fb72a0d..24482ef 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -199,17 +199,18 @@ (: step-test-and-branch! (machine TestAndBranchStatement -> 'ok)) (define (step-test-and-branch! m stmt) - (let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)] - [argval : SlotValue (evaluate-oparg m (TestAndBranchStatement-operand stmt))]) + (let: ([test : PrimitiveTest (TestAndBranchStatement-op 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)])]) + [(TestFalse? test) + (not (evaluate-oparg m (TestFalse-operand test)))] + [(TestOne? test) + (= (ensure-natural (evaluate-oparg m (TestOne-operand test))) + 1)] + [(TestZero? test) + (= (ensure-natural (evaluate-oparg m (TestZero-operand test))) + 0)] + [(TestPrimitiveProcedure? test) + (primitive-proc? (evaluate-oparg m (TestPrimitiveProcedure-operand test)))])]) v) (jump! m (TestAndBranchStatement-label stmt)) 'ok))) @@ -500,7 +501,7 @@ (MakeCompiledProcedureShell-arity op) '() (MakeCompiledProcedureShell-display-name op)))] - + [(ApplyPrimitiveProcedure? op) (let: ([prim : SlotValue (machine-proc m)] [args : (Listof PrimitiveValue) diff --git a/test-assemble.rkt b/test-assemble.rkt index e9b24f8..4da9656 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? (make-Reg 'val) 'onFalse) + ,(make-TestAndBranchStatement (make-TestFalse (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? (make-Reg 'val) 'onFalse) + ,(make-TestAndBranchStatement (make-TestFalse (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? (make-Reg 'val) 'onTrue) + ,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (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? (make-Reg 'val) 'onTrue) + ,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (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? (make-Reg 'val) 'onTrue) + ,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (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? (make-Reg 'proc) 'onTrue) + ,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (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 0fd9b1a..1af0360 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? (make-Reg 'val) 'on-false) + ,(make-TestAndBranchStatement (make-TestFalse (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? (make-Reg 'val) 'on-false) + ,(make-TestAndBranchStatement (make-TestFalse (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? (make-Reg 'val) 'on-true) + ,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (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? (make-Reg 'val) 'on-true) + ,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (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? (make-Reg 'val) 'on-true) + ,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (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? (make-Reg 'proc) 'on-true) + ,(make-TestAndBranchStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) 'on-true) ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ,(make-GotoStatement (make-Label 'end)) on-true