From b8785b524f09635bcfcd3acc64add974d8d8933f Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Wed, 27 Apr 2011 21:58:18 -0400
Subject: [PATCH] added test cases for parsing it

---
 compiler.rkt   | 40 +++++++++++++++++++++++++++++++++++-----
 parse.rkt      | 25 +++++++++++++++++++++++++
 test-parse.rkt | 19 ++++++++++++++++++-
 3 files changed, 78 insertions(+), 6 deletions(-)

diff --git a/compiler.rkt b/compiler.rkt
index c9b63dc..504e506 100644
--- a/compiler.rkt
+++ b/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)]
-        [rhs (DefValues-rhs exp)])
-  ;; First, compile the body with expectations for 
+  (let* ([ids (DefValues-ids exp)]
+         [rhs (DefValues-rhs exp)]
+         [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)))))
            
 
 
diff --git a/parse.rkt b/parse.rkt
index 56051b2..a6a312f 100644
--- a/parse.rkt
+++ b/parse.rkt
@@ -89,6 +89,12 @@
          [(EnvPrefixReference? address)
           (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)])
@@ -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)
diff --git a/test-parse.rkt b/test-parse.rkt
index 653f38c..824902c 100644
--- a/test-parse.rkt
+++ b/test-parse.rkt
@@ -498,4 +498,21 @@
 (test (parse '(call-with-values (lambda () x) y))
       (make-Top (make-Prefix '(x y))
                 (make-ApplyValues (make-ToplevelRef 0 1)
-                                  (make-ToplevelRef 0 0))))
\ No newline at end of file
+                                  (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))))))
\ No newline at end of file