support `(define-values (x y . z) ...)`

piclib/built-in.scm

@@ -343,24 +343,63 @@
      (lambda (form r c)
        `(,(r 'let*-values) ,@(cdr form)))))
 
+  (define (vector-map proc vect)
+    (do ((i 0 (+ i 1))
+         (u (make-vector (vector-length vect))))
+        ((= i (vector-length vect))
+         u)
+      (vector-set! u i (proc (vector-ref vect i)))))
+
+  (define (walk proc expr)
+    (cond
+     ((null? expr)
+      '())
+     ((pair? expr)
+      (cons (proc (car expr))
+            (walk proc (cdr expr))))
+     ((vector? expr)
+      (vector-map proc expr))
+     (else
+      (proc expr))))
+
+  (define (flatten expr)
+    (let ((list '()))
+      (walk
+       (lambda (x)
+         (set! list (cons x list)))
+       expr)
+      (reverse list)))
+
+  (define (predefine var)
+    `(define ,var #f))
+
+  (define (predefines vars)
+    (map predefine vars))
+
+  (define (assign var val)
+    `(set! ,var ,val))
+
+  (define (assigns vars vals)
+    (map assign vars vals))
+
+  (define uniq
+    (let ((counter 0))
+      (lambda (x)
+        (let ((sym (string->symbol (string-append "var$" (number->string counter)))))
+          (set! counter (+ counter 1))
+          sym))))
+
   (define-syntax define-values
-    (er-macro-transformer
+    (ir-macro-transformer
-     (lambda (form r c)
+     (lambda (form inject compare)
-       (let ((formals (cadr form)))
+       (let* ((formal  (cadr form))
-         `(,(r 'begin)
+              (formal* (walk uniq formal))
-            ,@(do ((vars formals (cdr vars))
+              (exprs   (cddr form)))
-                   (defs '()))
+         `(begin
-                  ((null? vars)
+            ,@(predefines (flatten formal))
-                   defs)
+            (call-with-values (lambda () ,@exprs)
-                (set! defs (cons `(,(r 'define) ,(car vars) #f) defs)))
+              (lambda ,formal*
-            (,(r 'call-with-values)
+                ,@(assigns (flatten formal) (flatten formal*)))))))))
-                (,(r 'lambda) () ,@(cddr form))
-              (,(r 'lambda) (,@(map r formals))
-                ,@(do ((vars formals (cdr vars))
-                       (assn '()))
-                      ((null? vars)
-                       assn)
-                    (set! assn (cons `(,(r 'set!) ,(car vars) ,(r (car vars))) assn))))))))))
 
   (export let-values
           let*-values