diff --git a/assemble-helpers.rkt b/assemble-helpers.rkt index 7a69ccc..32ae6e4 100644 --- a/assemble-helpers.rkt +++ b/assemble-helpers.rkt @@ -12,7 +12,6 @@ assemble-whole-prefix-reference assemble-reg assemble-label - assemble-input assemble-listof-assembled-values) @@ -30,7 +29,9 @@ [(EnvPrefixReference? v) (assemble-prefix-reference v)] [(EnvWholePrefixReference? v) - (assemble-whole-prefix-reference v)])) + (assemble-whole-prefix-reference v)] + [(SubtractArg? v) + (assemble-subtractarg v)])) @@ -116,20 +117,8 @@ (define (assemble-label a-label) (symbol->string (Label-name a-label))) - - -(: assemble-input (OpArg -> String)) -(define (assemble-input an-input) - (cond - [(Reg? an-input) - (assemble-reg an-input)] - [(Const? an-input) - (assemble-const an-input)] - [(Label? an-input) - (assemble-label an-input)] - [(EnvLexicalReference? an-input) - (assemble-lexical-reference an-input)] - [(EnvPrefixReference? an-input) - (assemble-prefix-reference an-input)] - [(EnvWholePrefixReference? an-input) - (assemble-whole-prefix-reference an-input)])) +(: assemble-subtractarg (SubtractArg -> String)) +(define (assemble-subtractarg s) + (format "(~a - ~a)" + (assemble-oparg (SubtractArg-lhs s)) + (assemble-oparg (SubtractArg-rhs s)))) diff --git a/assemble-open-coded.rkt b/assemble-open-coded.rkt index f1e1a99..8ef2ccf 100644 --- a/assemble-open-coded.rkt +++ b/assemble-open-coded.rkt @@ -14,7 +14,7 @@ (: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String)) (define (open-code-kernel-primitive-procedure op) (let*: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)] - [operands : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))] + [operands : (Listof String) (map assemble-oparg (CallKernelPrimitiveProcedure-operands op))] [checked-operands : (Listof String) (map maybe-typecheck-operand (CallKernelPrimitiveProcedure-expected-operand-types op) diff --git a/assemble.rkt b/assemble.rkt index 4809c11..9ecb597 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -117,7 +117,10 @@ EOF [(EnvPrefixReference? an-input) empty] [(EnvWholePrefixReference? an-input) - empty])) + empty] + [(SubtractArg? an-input) + (append (collect-input (SubtractArg-lhs an-input)) + (collect-input (SubtractArg-rhs an-input)))])) (: collect-location ((U Reg Label) -> (Listof Symbol))) (define (collect-location a-location) @@ -182,19 +185,7 @@ EOF empty] [(AssignImmediateStatement? stmt) (let: ([v : OpArg (AssignImmediateStatement-value stmt)]) - (cond - [(Reg? v) - empty] - [(Label? v) - (list (Label-name v))] - [(Const? v) - empty] - [(EnvLexicalReference? v) - empty] - [(EnvPrefixReference? v) - empty] - [(EnvWholePrefixReference? v) - empty]))] + (collect-input v))] [(AssignPrimOpStatement? stmt) (collect-primitive-operator (AssignPrimOpStatement-op stmt))] [(PerformStatement? stmt) diff --git a/compile.rkt b/compile.rkt index 8d8d864..256162c 100644 --- a/compile.rkt +++ b/compile.rkt @@ -872,7 +872,7 @@ `(,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)))) (make-instruction-sequence `(,(make-PopEnvironment (make-Const num-slots-to-delete) - (make-Const n)))) + (make-Reg 'argcount)))) (make-instruction-sequence `(;; Assign the proc value of the existing call frame ,(make-PerformStatement diff --git a/il-structs.rkt b/il-structs.rkt index 640695f..cfa9fa4 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -26,6 +26,7 @@ EnvLexicalReference ;; a reference into the stack EnvPrefixReference ;; a reference into an element in the toplevel. EnvWholePrefixReference ;; a reference into a toplevel prefix in the stack. + SubtractArg )) @@ -44,6 +45,11 @@ (define-struct: Const ([const : Any]) #:transparent) +;; Limited arithmetic on OpArgs +(define-struct: SubtractArg ([lhs : OpArg] + [rhs : OpArg]) + #:transparent) + (define-struct: PrimitivesReference ([name : Symbol]) diff --git a/simulator.rkt b/simulator.rkt index 18bbce2..c4224b7 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -608,7 +608,11 @@ [else (error 'evaluate-oparg "Internal error: not a toplevel at depth ~s: ~s" (EnvWholePrefixReference-depth an-oparg) - v)]))])) + v)]))] + + [(SubtractArg? an-oparg) + (- (ensure-number (evaluate-oparg m (SubtractArg-lhs an-oparg))) + (ensure-number (evaluate-oparg m (SubtractArg-rhs an-oparg))))])) (: ensure-closure-or-false (SlotValue -> (U closure #f)))