[PATCH] Implement R7RS 'define-values'

[Mark H Weaver <mhw@netris.org>]

[-- Attachment #1: Type: text/plain, Size: 589 bytes --]

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



[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Implement R7RS 'define-values' --]
[-- Type: text/x-patch, Size: 9938 bytes --]

From bd4e9d720c62c9b842a59c03d443b9a8cec89432 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
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
 
 
+@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 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