~ chicken-core (chicken-5) 3a00e602d3babbc89df699446ca6ee38bd4dbe19

commit 3a00e602d3babbc89df699446ca6ee38bd4dbe19
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Thu Jul 3 22:31:09 2014 +1200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sat Jul 12 17:19:54 2014 +0200

    Add full lambda list support for define-values forms in internal definitions
    
    Since ##sys#canonicalize-body does its own rewriting of internal
    definitions (including define-values), this factors the logic for
    expanding multi-valued assignments out of the set!-values transformer
    and into a dedicated procedure that both can use for binding variables.
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/NEWS b/NEWS
index e64569a2..dfaec6d6 100644
--- a/NEWS
+++ b/NEWS
@@ -29,6 +29,9 @@
     ##sys#zap-strings, ##sys#round, ##sys#foreign-number-vector-argument,
     ##sys#check-port-mode, ##sys#check-port*
 
+- Syntax expander
+  - define-values and set!-values now support full lambda lists
+
 - C API
   - Removed deprecated C_get_argument[_2] and
     C_get_environment_variable[_2] functions.
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index ff3f4947..baf6a351 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -326,22 +326,7 @@
  (##sys#er-transformer
   (lambda (form r c)
     (##sys#check-syntax 'set!-values form '(_ lambda-list _))
-    (let ((formals (cadr form))
-	  (exp (caddr form)))
-      (##sys#decompose-lambda-list
-       formals
-       (lambda (vars argc rest)
-	 (let ((aliases    (if (symbol? formals) '() (map gensym formals)))
-	       (rest-alias (if (not rest) '() (gensym rest))))
-	   `(##sys#call-with-values
-	     (##core#lambda () ,exp)
-	     (##core#lambda
-	      ,(append aliases rest-alias)
-	      ,@(map (lambda (v a) `(##core#set! ,v ,a)) vars aliases)
-	      ,@(cond
-		  ((null? formals) '((##core#undefined)))
-		  ((null? rest-alias) '())
-		  (else `((##core#set! ,rest ,rest-alias)))))))))))))
+    (##sys#expand-multiple-values-assignment (cadr form) (caddr form)))))
 
 (set! ##sys#define-values-definition
   (##sys#extend-macro-environment
diff --git a/expand.scm b/expand.scm
index 40f0c501..72e246a4 100644
--- a/expand.scm
+++ b/expand.scm
@@ -438,6 +438,26 @@
    "redefinition of currently used defining form" ; help me find something better
    form))
 
+;;; Expansion of multiple values assignments.
+;
+; Given a lambda list and a multi-valued expression, returns a form that
+; will `set!` each variable to its corresponding value in order.
+
+(define (##sys#expand-multiple-values-assignment formals expr)
+  (##sys#decompose-lambda-list
+   formals
+   (lambda (vars argc rest)
+     (let ((aliases    (if (symbol? formals) '() (map gensym formals)))
+	   (rest-alias (if (not rest) '() (gensym rest))))
+       `(##sys#call-with-values
+	 (##core#lambda () ,expr)
+	 (##core#lambda
+	  ,(append aliases rest-alias)
+	  ,@(map (lambda (v a) `(##core#set! ,v ,a)) vars aliases)
+	  ,@(cond
+	      ((null? formals) '((##core#undefined)))
+	      ((null? rest-alias) '())
+	      (else `((##core#set! ,rest ,rest-alias))))))))))
 
 ;;; Expansion of bodies (and internal definitions)
 ;
@@ -478,18 +498,14 @@
 		 (result 
 		  `(##core#let
 		    ,(##sys#map
-		      (lambda (v) (##sys#list v (##sys#list '##core#undefined))) 
-		      (apply ##sys#append vars mvars) )
+		      (lambda (v) (##sys#list v '(##core#undefined)))
+		      (foldl (lambda (l v) ; flatten multi-value formals
+			       (##sys#append l (##sys#decompose-lambda-list
+						v (lambda (a _ _) a))))
+			     vars
+			     mvars))
 		    ,@(map (lambda (v x) `(##core#set! ,v ,x)) vars (reverse vals))
-		    ,@(map (lambda (vs x)
-			     (let ([tmps (##sys#map gensym vs)])
-			       `(##sys#call-with-values
-				 (##core#lambda () ,x)
-				 (##core#lambda 
-				  ,tmps 
-				  ,@(map (lambda (v t)
-					   `(##core#set! ,v ,t)) 
-					 vs tmps) ) ) ) ) 
+		    ,@(map ##sys#expand-multiple-values-assignment
 			   (reverse mvars)
 			   (reverse mvals) )
 		    ,@body) ) )
@@ -565,7 +581,7 @@
 		     (fini/syntax vars vals mvars mvals body) )
 		    ((comp 'define-values head)
 		     ;;XXX check for any of the variables being `define-values'
-		     (##sys#check-syntax 'define-values x '(_ #(_ 0) _) #f se)
+		     (##sys#check-syntax 'define-values x '(_ lambda-list _) #f se)
 		     (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)))
 		    ((comp '##core#begin head)
 		     (loop (##sys#append (cdr x) rest) vars vals mvars mvals) )
diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm
index 942b4f33..1933b2b3 100644
--- a/tests/r7rs-tests.scm
+++ b/tests/r7rs-tests.scm
@@ -136,6 +136,30 @@
  (lambda () (force (delay (values))))
  (lambda mv (test '() #f mv)))
 
+
+(SECTION 5 3)
+
+(test '(1 2)
+      (lambda ()
+        (define-values (a b) (values 1 2))
+        (list a b)))
+
+(test '(1 (2))
+      (lambda ()
+        (define-values (a . b) (values 1 2))
+        (list a b)))
+
+(test '((1 2))
+      (lambda ()
+        (define-values a (values 1 2))
+        (list a)))
+
+(test 'ok ; Just tests that no error is thrown.
+      (lambda ()
+        (define-values () (values))
+        'ok))
+
+
 (SECTION 6 6)