[PATCH] Implement R7RS 'define-values'

[Mark H Weaver]

This patch implements 'define-values' as a macro, with a similar
implementation strategy to the one used in the sample definition given
in the R7RS.  I hope to provide a more efficient implementation on the
master branch at some point -- one which does not involve any mutation
-- but for now I'd like to provide at least something so that code that
uses it will run on the upcoming Guile 2.0.10.

This patch was made on top of my earlier "custom ellipses" and
"syntax-error" patches, although it does not strictly depend on those
patches.

Comments and suggestions welcome.

      Mark


>From bd4e9d720c62c9b842a59c03d443b9a8cec89432 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Thu, 19 Dec 2013 20:52:06 -0500
Subject: [PATCH] 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.
---
 doc/ref/api-binding.texi     |   23 ++++++
 module/ice-9/boot-9.scm      |   59 ++++++++++++++
 test-suite/tests/syntax.test |  175 ++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 257 insertions(+), 0 deletions(-)

diff --git a/doc/ref/api-binding.texi b/doc/ref/api-binding.texi
index e3a9918..bf9aa81 100644
--- a/doc/ref/api-binding.texi
+++ b/doc/ref/api-binding.texi
@@ -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
 
 
address@hidden Binding Multiple Values
address@hidden Binding multiple return values
+
address@hidden {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.
address@hidden deffn
+
address@hidden
+(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)
address@hidden 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 19c22ea..fe8920b 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -583,6 +583,65 @@ If there is no handler at all, Guile prints an error and 
then exits."
     ((do "step" x y)
      y)))
 
+(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 24fa8b0..a86a8af 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"
-- 
1.7.5.4