Implement define-values for R7RS.

diff --git a/src/runtime/lambda-list.scm b/src/runtime/lambda-list.scm
index 14b931a0cf9beb69d0a398036cc5d5cab53a44a6..7b951dd4ebe8a697ed47287b1252de6faf35a5a9 100644 (file)
--- a/src/runtime/lambda-list.scm
+++ b/src/runtime/lambda-list.scm
@@ -56,6 +56,14 @@ USA.
                                bvl)))
     (values (car parsed) (cdr parsed))))
 
+(define (r4rs-lambda-list-names bvl)
+  (fold-r4rs-lambda-list cons
+                        (lambda (var)
+                          (if var
+                              (list var)
+                              '()))
+                        bvl))
+
 (define (r4rs-lambda-list-arity bvl)
   (let ((arity
         (fold-r4rs-lambda-list (lambda (var arity)

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 6d3627e45874f99967ab524fb3c7f147860455e1..51c789a1631f1913f23f9f6a0cbf2c537473f40a 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -425,6 +425,36 @@ USA.
                     (scons-if p (scons-call guard-k c) a)))
                  (scons-call 'raise-continuable condition)
                  clauses)))
+
+(define $define-values
+  (spar-transformer->runtime
+   (delay
+     (scons-rule `(,r4rs-lambda-list? any)
+       (lambda (bvl expr)
+        (if (and (pair? bvl)
+                 (null? (cdr bvl)))
+            (scons-define (car bvl) expr)
+            (let ((temp-bvl
+                   (map-r4rs-lambda-list
+                    (lambda (name)
+                      (new-identifier (symbol 'temp- name)))
+                    bvl)))
+              (let ((names (r4rs-lambda-list-names bvl))
+                    (temps (r4rs-lambda-list-names temp-bvl)))
+                (scons-begin
+                  (apply scons-begin
+                         (map (lambda (name)
+                                (scons-define name (unassigned-expression)))
+                              names))
+                  (scons-call 'call-with-values
+                              (scons-lambda '() expr)
+                              (apply scons-lambda
+                                     temp-bvl
+                                     (map* (list (unspecific-expression))
+                                           (lambda (name temp)
+                                             (scons-set! name temp))
+                                           names
+                                           temps))))))))))))
 \f
 ;;; This optimizes some simple cases, but it could be better.  Among other
 ;;; things it could take advantage of arity-dispatched procedures in the right

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 1ffbb9ba9b4c50c5d0c90587039a1a3827c1286b..82b154b2eac64978eb772362271a10a2049c9325 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3069,6 +3069,7 @@ USA.
          parse-mit-lambda-list
          parse-r4rs-lambda-list
          r4rs-lambda-list-arity
+         r4rs-lambda-list-names
          r4rs-lambda-list?))
 
 (define-package (runtime srfi-1)
@@ -4769,6 +4770,7 @@ USA.
          (define $define)              ;R7RS
          (define-integrable $define-integrable)
          (define-record-type $define-record-type)
+         (define-values $define-values) ;R7RS
          (do $do)                      ;R7RS
          (fluid-let $fluid-let)
          (guard $guard)                ;R7RS