Merge commit '866af5da3d11ac4a9df44ee8c5b1781a0073c288'

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

diff --cc module/ice-9/boot-9.scm
index bfcce0a,42d7d78..b6ba03c
--- 1/module/ice-9/boot-9.scm
--- 2/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@@ -717,6 -583,81 +717,64 @@@ file with the given name already exists
      ((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)
+        ;; XXX Work around the lack of hygienic top-level identifiers
+        (with-syntax (((dummy) (generate-temporaries '(dummy))))
+          #`(define dummy
+              (call-with-values (lambda () expr)
 -               (case-lambda
 -                 (() #f)
 -                 (_ (%define-values-arity-error)))))))
++               (lambda () #f)))))
+       ((_ (var) expr)
+        (identifier? #'var)
+        #`(define var
+            (call-with-values (lambda () expr)
 -             (case-lambda
 -               ((v) v)
 -               (_ (%define-values-arity-error))))))
++             (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)
 -                 (case-lambda
 -                   ((var0 ... varn)
 -                    (list var0 ... varn))
 -                   (_ (%define-values-arity-error)))))
++                 (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)
 -                 (case-lambda
 -                   ((var0 ... . varn)
 -                    (list var0 ... varn))
 -                   (_ (%define-values-arity-error)))))
++                 (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 --cc test-suite/tests/syntax.test
index d88e791,faed562..6c2891c
--- 1/test-suite/tests/syntax.test
--- 2/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@@ -82,6 -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 -914,178 +979,178 @@@
      (eval '(let () (define x #t))
            (interaction-environment))))
  
 -      exception:define-values-wrong-number-of-return-values
+ (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
++      exception:wrong-number-of-values
+     (eval '(define-values () 1)
+           (interaction-environment)))
+ 
+   (pass-if-exception "expected 1 value, got 0"
 -      exception:define-values-wrong-number-of-return-values
++      exception:wrong-number-of-values
+     (eval '(define-values (x) (values))
+           (interaction-environment)))
+ 
+   (pass-if-exception "expected 1 value, got 2"
 -      exception:define-values-wrong-number-of-return-values
++      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:define-values-wrong-number-of-return-values
++      exception:wrong-number-of-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
++      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:define-values-wrong-number-of-return-values
++      exception:wrong-number-of-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
++      exception:wrong-number-of-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
++      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:define-values-wrong-number-of-return-values
++      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"