continuing to work on multiple value stuff

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))]))
 
 
 

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)))))]))
 
@@ -1039,6 +1041,46 @@
                      (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)
                   ;; This case happens for a function call that isn't in
@@ -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

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)
 
@@ -339,6 +344,8 @@
                                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))
 
 

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;

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))]
           )))