summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2014-02-07 15:15:08 +0100
committerAndy Wingo <wingo@pobox.com>2014-02-07 15:24:43 +0100
commitb00c9b221401082449fd733a78bb1b4f88e41ebe (patch)
treef51128624515a1a3d8f3115b730a11d04d2c31ee
parentcd36c69619e406082100efb1e62998fc67bbc2a6 (diff)
parent866af5da3d11ac4a9df44ee8c5b1781a0073c288 (diff)
downloadguile-b00c9b221401082449fd733a78bb1b4f88e41ebe.tar.gz
Merge commit '866af5da3d11ac4a9df44ee8c5b1781a0073c288'
Removes the special arity handler, and instead relies on the procedure returning the correct number of values.
-rw-r--r--doc/ref/api-binding.texi27
-rw-r--r--module/ice-9/boot-9.scm58
-rw-r--r--test-suite/tests/syntax.test174
3 files changed, 257 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 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"