From: Andy Wingo <wingo@pobox.com>
Date: Fri, 7 Feb 2014 14:15:08 +0000 (+0100)
Subject: Merge commit '866af5da3d11ac4a9df44ee8c5b1781a0073c288'
X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/b00c9b221401082449fd733a78bb1b4f88e41ebe?hp=cd36c69619e406082100efb1e62998fc67bbc2a6

Merge commit '866af5da3d11ac4a9df44ee8c5b1781a0073c288'

Removes the special arity handler, and instead relies on the procedure
returning the correct number of values.
---

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 bfcce0a59..b6ba03c4d 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -717,6 +717,64 @@ file with the given name already exists, the effect is unspecified."
     ((do "step" x y)
      y)))
 
+(define-syntax define-values
+  (lambda (orig-form)
+    (syntax-case orig-form ()
+      ((_ () expr)
+       ;; XXX Work around the lack of hygienic top-level identifiers
+       (with-syntax (((dummy) (generate-temporaries '(dummy))))
+         #`(define dummy
+             (call-with-values (lambda () expr)
+               (lambda () #f)))))
+      ((_ (var) expr)
+       (identifier? #'var)
+       #`(define var
+           (call-with-values (lambda () expr)
+             (lambda (v) v))))
+      ((_ (var0 ... varn) expr)
+       (and-map identifier? #'(var0 ... varn))
+       ;; XXX Work around the lack of hygienic toplevel identifiers
+       (with-syntax (((dummy) (generate-temporaries '(dummy))))
+         #`(begin
+             ;; Avoid mutating the user-visible variables
+             (define dummy
+               (call-with-values (lambda () expr)
+                 (lambda (var0 ... varn)
+                   (list var0 ... varn))))
+             (define var0
+               (let ((v (car dummy)))
+                 (set! dummy (cdr dummy))
+                 v))
+             ...
+             (define varn
+               (let ((v (car dummy)))
+                 (set! dummy #f)  ; blackhole dummy
+                 v)))))
+      ((_ var expr)
+       (identifier? #'var)
+       #'(define var
+           (call-with-values (lambda () expr)
+             list)))
+      ((_ (var0 ... . varn) expr)
+       (and-map identifier? #'(var0 ... varn))
+       ;; XXX Work around the lack of hygienic toplevel identifiers
+       (with-syntax (((dummy) (generate-temporaries '(dummy))))
+         #`(begin
+             ;; Avoid mutating the user-visible variables
+             (define dummy
+               (call-with-values (lambda () expr)
+                 (lambda (var0 ... . varn)
+                   (list var0 ... varn))))
+             (define var0
+               (let ((v (car dummy)))
+                 (set! dummy (cdr dummy))
+                 v))
+             ...
+             (define varn
+               (let ((v (car dummy)))
+                 (set! dummy #f)  ; blackhole dummy
+                 v))))))))
+
 (define-syntax-rule (delay exp)
   (make-promise (lambda () exp)))
 
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index d88e791cc..6c2891cbb 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -82,6 +82,8 @@
 
 (define exception:too-many-args
   "too many arguments")
+(define exception:wrong-number-of-values
+  '(wrong-number-of-args . "number of (values)|(arguments)"))
 (define exception:zero-expression-sequence
   "sequence of zero expressions")
 
@@ -977,6 +979,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:wrong-number-of-values
+    (eval '(define-values () 1)
+          (interaction-environment)))
+
+  (pass-if-exception "expected 1 value, got 0"
+      exception:wrong-number-of-values
+    (eval '(define-values (x) (values))
+          (interaction-environment)))
+
+  (pass-if-exception "expected 1 value, got 2"
+      exception:wrong-number-of-values
+    (eval '(define-values (x) (values 1 2))
+          (interaction-environment)))
+
+  (pass-if-exception "expected 1 value with tail, got 0"
+      exception:wrong-number-of-values
+    (eval '(define-values (x . y) (values))
+          (interaction-environment)))
+
+  (pass-if-exception "expected 2 value with tail, got 1"
+      exception:wrong-number-of-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:wrong-number-of-values
+    (eval '(let ()
+             (define-values () 1)
+             #f)
+          (interaction-environment)))
+
+  (pass-if-exception "expected 1 value, got 0"
+      exception:wrong-number-of-values
+    (eval '(let ()
+             (define-values (x) (values))
+             #f)
+          (interaction-environment)))
+
+  (pass-if-exception "expected 1 value, got 2"
+      exception:wrong-number-of-values
+    (eval '(let ()
+             (define-values (x) (values 1 2))
+             #f)
+          (interaction-environment)))
+
+  (pass-if-exception "expected 1 value with tail, got 0"
+      exception:wrong-number-of-values
+    (eval '(let ()
+             (define-values (x . y) (values))
+             #f)
+          (interaction-environment)))
+
+  (pass-if-exception "expected 2 value with tail, got 1"
+      exception:wrong-number-of-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"