diff --git a/assemble.rkt b/assemble.rkt index 67bc917..1ba7885 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -230,6 +230,8 @@ EOF [(FixClosureShellMap!? op) empty] [(InstallContinuationMarkEntry!? op) + empty] + [(RaiseContextExpectedValuesError!? op) empty])) (unique/eq? @@ -594,7 +596,10 @@ EOF [(InstallContinuationMarkEntry!? op) (string-append "RUNTIME.installContinuationMarkEntry(MACHINE," "MACHINE.control[MACHINE.control.length-1].pendingContinuationMarkKey," - "MACHINE.val);")])) + "MACHINE.val);")] + [(RaiseContextExpectedValuesError!? op) + (format "RUNTIME.raiseContextExpectedValuesError(MACHINE, ~a);" + (RaiseContextExpectedValuesError!-expected op))])) diff --git a/compiler.rkt b/compiler.rkt index 5c7deea..8310cc5 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -216,6 +216,8 @@ ,(make-GotoStatement (make-Reg 'proc))))] [(NextLinkage? linkage) empty-instruction-sequence] + [(NextLinkage/Expects? linkage) + empty-instruction-sequence] [(LabelLinkage? linkage) (make-instruction-sequence `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))])) @@ -1038,6 +1040,46 @@ proc-return (make-instruction-sequence `(,(make-AssignImmediateStatement target (make-Reg 'val))))))])] + + [(NextLinkage/Expects? linkage) + (cond [(eq? target 'val) + ;; This case happens for a function call that isn't in + ;; tail position. + (let* ([proc-return-multiple (make-label 'procReturnMultiple)] + [proc-return (make-LinkedLabel (make-label 'procReturn) + proc-return-multiple)]) + (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))] + + [else + ;; This case happens for evaluating arguments, since the + ;; arguments are being installed into the scratch space. + (let* ([proc-return-multiple (make-label 'procReturnMultiple)] + [proc-return (make-LinkedLabel (make-label 'procReturn) + proc-return-multiple)]) + (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 + ;; FIMXE: this needs to raise a runtime error! + (make-instruction-sequence `(,(make-PopEnvironment (make-Reg 'argcount) + (make-Const 0)))) + proc-return + (make-instruction-sequence + `(,(make-AssignImmediateStatement target (make-Reg 'val))))))])] + + [(LabelLinkage? linkage) (cond [(eq? target 'val) @@ -1131,6 +1173,8 @@ (cond [(NextLinkage? linkage) linkage] + [(NextLinkage/Expects? linkage) + linkage] [(ReturnLinkage? linkage) linkage] [(ReturnLinkage/NonTail? linkage) @@ -1165,6 +1209,8 @@ (cond [(NextLinkage? linkage) linkage] + [(NextLinkage/Expects? linkage) + linkage] [(ReturnLinkage? linkage) linkage] [(ReturnLinkage/NonTail? linkage) @@ -1207,6 +1253,8 @@ [letrec-linkage : Linkage (cond [(NextLinkage? linkage) linkage] + [(NextLinkage/Expects? linkage) + linkage] [(ReturnLinkage? linkage) linkage] [(ReturnLinkage/NonTail? linkage) @@ -1287,6 +1335,7 @@ (compile (WithContMark-body exp) cenv target linkage))] [(or (NextLinkage? linkage) + (NextLinkage/Expects? linkage) (LabelLinkage? linkage)) (end-with-linkage linkage cenv diff --git a/il-structs.rkt b/il-structs.rkt index 2cc9c5c..95af445 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -314,6 +314,11 @@ [closed-vals : (Listof Natural)]) #:transparent) +;; Raises an exception that says that we expected a number of values. +;; Assume that argcount is not equal to expected. +(define-struct: RaiseContextExpectedValuesError! ([expected : Natural]) + #:transparent) + ;; Changes over the control located at the given argument from the structure in env[1] (define-struct: RestoreControl! ([tag : (U DefaultContinuationPromptTag OpArg)]) #:transparent) @@ -338,6 +343,8 @@ SetFrameCallee! SpliceListIntoStack! UnspliceRestFromStack! + + RaiseContextExpectedValuesError! RestoreEnvironment! RestoreControl!)) @@ -376,6 +383,12 @@ (define-struct: NextLinkage ()) (define next-linkage (make-NextLinkage)) +;; NextLinkage/Expects works like NextLinkage, but should check that +;; it is returning 'expects' values back. +(define-struct: NextLinkage/Expects ([expects : Natural])) +(define next-linkage-expects-single (make-NextLinkage/Expects 1)) + + (define-struct: ReturnLinkage ()) (define return-linkage (make-ReturnLinkage)) @@ -385,8 +398,11 @@ (define-struct: LabelLinkage ([label : Symbol])) (define-type Linkage (U NextLinkage + NextLinkage/Expects + ReturnLinkage ReturnLinkage/NonTail + LabelLinkage)) diff --git a/runtime.js b/runtime.js index 004cec8..b468888 100644 --- a/runtime.js +++ b/runtime.js @@ -254,6 +254,12 @@ } }; + var raiseContextExpectedValuesError = function(MACHINE, expected) { + raise(MACHINE, + new Error("expected " + expected + + " values, received " + + MACHINE.argcount + " values")); + }; // captureControl implements the continuation-capturing part of @@ -1069,6 +1075,8 @@ exports['testArgument'] = testArgument; exports['testArity'] = testArity; exports['raise'] = raise; + exports['raiseContextExpectedValuesError'] = raiseContextExpectedValuesError; + exports['captureControl'] = captureControl; exports['restoreControl'] = restoreControl; diff --git a/simulator.rkt b/simulator.rkt index f9c95e5..d0f09a5 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -383,6 +383,11 @@ (ensure-primitive-value key) (ensure-primitive-value val)) 'ok)] + + [(RaiseContextExpectedValuesError!? op) + (error "context expected ~a values, received ~a values." + (RaiseContextExpectedValuesError!-expected op) + (machine-argcount m))] )))