added test cases for parsing it

compiler.rkt

@@ -1501,16 +1501,46 @@
 
 (: compile-def-values (DefValues CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-def-values exp cenv target linkage)
-  (let ([ids (DefValues-ids exp)]
+  (let* ([ids (DefValues-ids exp)]
-        [rhs (DefValues-rhs exp)])
+         [rhs (DefValues-rhs exp)]
-  ;; First, compile the body with expectations for 
+         [n (length ids)])
+  ;; First, compile the body, which will produce right side values.
     (end-with-linkage 
      linkage 
      cenv
      (append-instruction-sequences
       (compile rhs cenv 'val (make-NextLinkage (length ids)))
-      ;; Now install each of the values in place
+
-      ))))
+      ;; Now install each of the values in place.  The first value's in val, and the rest of the
+      ;; values are on the stack.
+      (if (> n 0)
+          (apply append-instruction-sequences
+             (map (lambda: ([id : ToplevelRef]
+                            [from : OpArg])
+                           (make-instruction-sequence
+                            `(,(make-AssignImmediateStatement
+                                ;; Slightly subtle: the toplevelrefs were with respect to the
+                                ;; stack at the beginning of def-values, but at the moment,
+                                ;; there may be additional values that are currently there.
+                                (make-EnvPrefixReference (+ (ensure-natural (sub1 n))
+                                                            (ToplevelRef-depth id))
+                                                         (ToplevelRef-pos id))
+                                from))))
+                  ids
+                  (if (> n 0) 
+                      (cons (make-Reg 'val)
+                            (build-list (sub1 n)
+                                        (lambda: ([i : Natural])
+                                                 (make-EnvLexicalReference i #f))))
+                      empty)))
+          empty-instruction-sequence)
+
+      ;; Finally, make sure any multiple values are off the stack.
+      (if (> (length ids) 1)
+          (make-instruction-sequence 
+           `(,(make-PopEnvironment (make-Const (length ids))
+                                   (make-Const 0))))
+          empty-instruction-sequence)))))
            
 
 

parse.rkt

@@ -90,6 +90,12 @@
           (make-ToplevelRef (EnvPrefixReference-depth address)
                             (EnvPrefixReference-pos address))]))]
 
+    [(define-values? exp)
+     (make-DefValues (map (lambda (id) 
+                            (parse id cenv #f))
+                          (define-values-ids exp))
+                     (parse (define-values-rhs exp) cenv #f))]
+    
     [(definition? exp)
      (let ([address (find-variable (definition-variable exp) cenv)])
        (cond
@@ -241,6 +247,10 @@
        [(variable? exp)
         (list exp)]
        
+       [(define-values? exp)
+        (append (define-values-ids exp)
+                (loop (define-values-rhs exp)))]
+       
        [(definition? exp)
         (cons (definition-variable exp)
               (loop (definition-value exp)))]
@@ -314,6 +324,9 @@
        [(variable? exp)
         '()]
        
+       [(define-values? exp)
+        (loop (define-values-rhs exp))]
+       
        [(definition? exp)
         (loop (definition-value exp))]
        
@@ -398,6 +411,18 @@
 (define (assignment-variable exp) (cadr exp))
 (define (assignment-value exp) (caddr exp))
 
+
+
+(define (define-values? exp)
+  (tagged-list? exp 'define-values))
+
+(define (define-values-ids exp)
+  (cadr exp))
+
+(define (define-values-rhs exp)
+  (caddr exp))
+
+
 (define (definition? exp)
   (tagged-list? exp 'define))
 (define (definition-variable exp)

test-parse.rkt

@@ -499,3 +499,20 @@
       (make-Top (make-Prefix '(x y))
                 (make-ApplyValues (make-ToplevelRef 0 1)
                                   (make-ToplevelRef 0 0))))
+
+
+
+(test (parse '(define-values () (values)))
+      (make-Top (make-Prefix '(values))
+                (make-DefValues '()
+                                (make-App (make-ToplevelRef 0 0) '()))))
+
+(test (parse '(define-values (x y z) (values 'hello 'world 'testing)))
+      (make-Top (make-Prefix '(values x y z))
+                (make-DefValues (list (make-ToplevelRef 0 1)
+                                      (make-ToplevelRef 0 2)
+                                      (make-ToplevelRef 0 3))
+                                (make-App (make-ToplevelRef 3 0) 
+                                          (list (make-Constant 'hello)
+                                                (make-Constant 'world)
+                                                (make-Constant 'testing))))))