Implement R7RS 'define-values'.

* module/ice-9/boot-9.scm (%define-values-arity-error): New procedure.
  (define-values): New macro.

* doc/ref/api-binding.texi (Binding Multiple Values): Add docs.

* test-suite/tests/syntax.test: Add tests.

3 files changed, 261 insertions, 2 deletions

diff --git a/doc/ref/api-binding.texi b/doc/ref/api-binding.texi
index e3a991871..5857e782f 100644
--- a/doc/ref/api-binding.texi
+++ b/doc/ref/api-binding.texi
@@ -1,7 +1,7 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011
-@c   Free Software Foundation, Inc.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011,
+@c   2014 Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node Binding Constructs
@@ -17,6 +17,7 @@ and expressions.  This is important for modularity and data abstraction.
 * Local Bindings::              Local variable bindings.
 * Internal Definitions::        Internal definitions.
 * Binding Reflection::          Querying variable bindings.
+* Binding Multiple Values::     Binding multiple return values.
 @end menu
 
 
@@ -321,6 +322,28 @@ the current module when @var{module} is not specified; otherwise return
 @end deffn
 
 
+@node Binding Multiple Values
+@subsection Binding multiple return values
+
+@deffn {Syntax} define-values formals expression
+The @var{expression} is evaluated, and the @var{formals} are bound to
+the return values in the same way that the formals in a @code{lambda}
+expression are matched to the arguments in a procedure call.
+@end deffn
+
+@example
+(define-values (q r) (floor/ 10 3))
+(list q r) @result{} (3 1)
+
+(define-values (x . y) (values 1 2 3))
+x @result{} 1
+y @result{} (2 3)
+
+(define-values x (values 1 2 3))
+x @result{} (1 2 3)
+@end example
+
+
 @c Local Variables:
 @c TeX-master: "guile.texi"
 @c End:
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 98cefe9c4..c6cdcd365 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -583,6 +583,67 @@ If there is no handler at all, Guile prints an error and then exits."
     ((do "step" x y)
      y)))
 
+;; XXX FIXME: When 'call-with-values' is fixed to no longer do automatic
+;;     truncation of values (in 2.2 ?), then this hack can be removed.
+(define (%define-values-arity-error)
+  (throw 'wrong-number-of-args
+         #f
+         "define-values: wrong number of return values returned by expression"
+         '()
+         #f))
+
+(define-syntax define-values
+  (lambda (orig-form)
+    (syntax-case orig-form ()
+      ((_ () expr)
+       #`(define dummy
+           (call-with-values (lambda () expr)
+             (case-lambda
+               (() #f)
+               (_ (%define-values-arity-error))))))
+      ((_ (var) expr)
+       (identifier? #'var)
+       #`(define var
+           (call-with-values (lambda () expr)
+             (case-lambda
+               ((v) v)
+               (_ (%define-values-arity-error))))))
+      ((_ (var0 ... varn) expr)
+       (and-map identifier? #'(var0 ... varn))
+       #`(begin
+           (define dummy
+             (call-with-values (lambda () expr)
+               (case-lambda
+                 ((var0 ... varn)
+                  (list var0 ... varn))
+                 (_ (%define-values-arity-error)))))
+           (define var0
+             (let ((v (car dummy)))
+               (set! dummy (cdr dummy))
+               v))
+           ...
+           (define varn (car dummy))))
+      ((_ var expr)
+       (identifier? #'var)
+       #'(define var
+           (call-with-values (lambda () expr)
+             list)))
+      ((_ (var0 ... . varn) expr)
+       (and-map identifier? #'(var0 ... varn))
+       #`(begin
+           (define dummy
+             (call-with-values (lambda () expr)
+               (case-lambda
+                 ((var0 ... . varn)
+                  (list var0 ... varn))
+                 (_ (%define-values-arity-error)))))
+           (define var0
+             (let ((v (car dummy)))
+               (set! dummy (cdr dummy))
+               v))
+           ...
+           (define varn (car dummy)))))))
+
 (define-syntax-rule (delay exp)
   (make-promise (lambda () exp)))
 
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index a1129e9dc..faed56245 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -85,6 +85,9 @@
 (define exception:zero-expression-sequence
   "sequence of zero expressions")
 
+(define exception:define-values-wrong-number-of-return-values
+  (cons 'wrong-number-of-args "^define-values: wrong number of return values returned by expression"))
+
 
 ;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
 (define-syntax pass-if-syntax-error
@@ -911,6 +914,178 @@
     (eval '(let () (define x #t))
           (interaction-environment))))
 
+(with-test-prefix "top-level define-values"
+
+  (pass-if "zero values"
+    (eval '(begin (define-values () (values))
+                  #t)
+          (interaction-environment)))
+
+  (pass-if-equal "one value"
+      1
+    (eval '(begin (define-values (x) 1)
+                  x)
+          (interaction-environment)))
+
+  (pass-if-equal "two values"
+      '(2 3)
+    (eval '(begin (define-values (x y) (values 2 3))
+                  (list x y))
+          (interaction-environment)))
+
+  (pass-if-equal "three values"
+      '(4 5 6)
+    (eval '(begin (define-values (x y z) (values 4 5 6))
+                  (list x y z))
+          (interaction-environment)))
+
+  (pass-if-equal "one value with tail"
+      '(a (b c d))
+    (eval '(begin (define-values (x . y) (values 'a 'b 'c 'd))
+                  (list x y))
+          (interaction-environment)))
+
+  (pass-if-equal "two values with tail"
+      '(x y (z w))
+    (eval '(begin (define-values (x y . z) (values 'x 'y 'z 'w))
+                  (list x y z))
+          (interaction-environment)))
+
+  (pass-if-equal "just tail"
+      '(1 2 3)
+    (eval '(begin (define-values x (values 1 2 3))
+                  x)
+          (interaction-environment)))
+
+  (pass-if-exception "expected 0 values, got 1"
+      exception:define-values-wrong-number-of-return-values
+    (eval '(define-values () 1)
+          (interaction-environment)))
+
+  (pass-if-exception "expected 1 value, got 0"
+      exception:define-values-wrong-number-of-return-values
+    (eval '(define-values (x) (values))
+          (interaction-environment)))
+
+  (pass-if-exception "expected 1 value, got 2"
+      exception:define-values-wrong-number-of-return-values
+    (eval '(define-values (x) (values 1 2))
+          (interaction-environment)))
+
+  (pass-if-exception "expected 1 value with tail, got 0"
+      exception:define-values-wrong-number-of-return-values
+    (eval '(define-values (x . y) (values))
+          (interaction-environment)))
+
+  (pass-if-exception "expected 2 value with tail, got 1"
+      exception:define-values-wrong-number-of-return-values
+    (eval '(define-values (x y . z) 1)
+          (interaction-environment)))
+
+  (pass-if "redefinition"
+    (let ((m (make-module)))
+      (beautify-user-module! m)
+
+      ;; The previous values of `floor' and `round' must still be
+      ;; visible at the time the new `floor' and `round' are defined.
+      (eval '(define-values (floor round) (values floor round)) m)
+      (and (eq? (module-ref m 'floor) floor)
+           (eq? (module-ref m 'round) round))))
+
+  (with-test-prefix "missing expression"
+
+    (pass-if-syntax-error "(define-values)"
+      exception:generic-syncase-error
+      (eval '(define-values)
+	    (interaction-environment)))))
+
+(with-test-prefix "internal define-values"
+
+  (pass-if "zero values"
+    (let ()
+      (define-values () (values))
+      #t))
+
+  (pass-if-equal "one value"
+      1
+    (let ()
+      (define-values (x) 1)
+      x))
+
+  (pass-if-equal "two values"
+      '(2 3)
+    (let ()
+      (define-values (x y) (values 2 3))
+      (list x y)))
+
+  (pass-if-equal "three values"
+      '(4 5 6)
+    (let ()
+      (define-values (x y z) (values 4 5 6))
+      (list x y z)))
+
+  (pass-if-equal "one value with tail"
+      '(a (b c d))
+    (let ()
+      (define-values (x . y) (values 'a 'b 'c 'd))
+      (list x y)))
+
+  (pass-if-equal "two values with tail"
+      '(x y (z w))
+    (let ()
+      (define-values (x y . z) (values 'x 'y 'z 'w))
+      (list x y z)))
+
+  (pass-if-equal "just tail"
+      '(1 2 3)
+    (let ()
+      (define-values x (values 1 2 3))
+      x))
+
+  (pass-if-exception "expected 0 values, got 1"
+      exception:define-values-wrong-number-of-return-values
+    (eval '(let ()
+             (define-values () 1)
+             #f)
+          (interaction-environment)))
+
+  (pass-if-exception "expected 1 value, got 0"
+      exception:define-values-wrong-number-of-return-values
+    (eval '(let ()
+             (define-values (x) (values))
+             #f)
+          (interaction-environment)))
+
+  (pass-if-exception "expected 1 value, got 2"
+      exception:define-values-wrong-number-of-return-values
+    (eval '(let ()
+             (define-values (x) (values 1 2))
+             #f)
+          (interaction-environment)))
+
+  (pass-if-exception "expected 1 value with tail, got 0"
+      exception:define-values-wrong-number-of-return-values
+    (eval '(let ()
+             (define-values (x . y) (values))
+             #f)
+          (interaction-environment)))
+
+  (pass-if-exception "expected 2 value with tail, got 1"
+      exception:define-values-wrong-number-of-return-values
+    (eval '(let ()
+             (define-values (x y . z) 1)
+             #f)
+          (interaction-environment)))
+
+  (with-test-prefix "missing expression"
+
+    (pass-if-syntax-error "(define-values)"
+      exception:generic-syncase-error
+      (eval '(let ()
+               (define-values)
+               #f)
+	    (interaction-environment)))))
+
 (with-test-prefix "set!"
 
   (with-test-prefix "missing or extra expressions"