Implement let-values and let*-values.

diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm
index 5f0c107b4c0a67c259e128592a4a135724ede7c1..7f8373ce9e5d4ede4f8f7a6f67a835c87dec2625 100644 (file)
--- a/src/runtime/library-standard.scm
+++ b/src/runtime/library-standard.scm
@@ -283,9 +283,9 @@ USA.
     length
     let
     let*
-    ;; let*-values
+    let*-values
     let-syntax
-    ;; let-values
+    let-values
     letrec
     letrec*
     letrec-syntax

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 3ed2e05df8a98be0b61a0b963af7455a3b441f95..06c6c02bc56d55c3859ab6f16451d6a57272b2e5 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -187,6 +187,66 @@ USA.
             (apply scons-begin (map scons-set! ids vals))
             (scons-call (apply scons-lambda '() body-forms)))))))))
 \f
+(define $let-values
+  (spar-transformer->runtime
+   (delay
+     (scons-rule
+        `((subform (* (subform (list ,r4rs-lambda-list? any))))
+          (+ any))
+       (lambda (bindings body-forms)
+        (let ((body (apply scons-begin body-forms)))
+          (case (length bindings)
+            ((0)
+             (scons-let '() body))
+            ((1)
+             (scons-cwv (car (car bindings))
+                        (scons-lambda '() (cadr (car bindings)))
+                        body))
+            (else
+             (let-values-multi bindings body)))))))))
+
+(define (let-values-multi bindings body)
+  (let ((temps
+        (map (lambda (index)
+               (new-identifier (symbol 'temp- index)))
+             (iota (length bindings))))
+       (thunks
+        (map (lambda (binding)
+               (scons-lambda () (cadr binding)))
+             bindings)))
+    (scons-let (map list temps thunks)
+      (let loop ((bvls (map car bindings)) (temps temps))
+       (if (pair? bvls)
+           (scons-cwv (car bvls)
+                      (car temps)
+                      (loop (cdr bvls) (cdr temps)))
+           body)))))
+
+(define-syntax $let*-values
+  (syntax-rules ()
+    ((let*-values () body0 body1 ...)
+     (let () body0 body1 ...))
+    ((let*-values (binding0 binding1 ...) body0 body1 ...)
+     (let-values (binding0)
+       (let*-values (binding1 ...)
+        body0 body1 ...)))))
+
+;;; SRFI 8: receive
+
+(define $receive
+  (spar-transformer->runtime
+   (delay
+     (scons-rule `(,r4rs-lambda-list? any (+ any))
+       (lambda (bvl expr body-forms)
+        (scons-cwv bvl
+                   (scons-lambda '() expr)
+                   (apply scons-begin body-forms)))))))
+
+(define (scons-cwv bvl thunk body)
+  (scons-call (scons-close 'call-with-values)
+             thunk
+             (scons-lambda bvl body)))
+\f
 ;;; SRFI 2: and-let*
 
 ;;; The SRFI document is a little unclear about the semantics, imposes
@@ -215,17 +275,6 @@ USA.
                  (scons-and conjunct (apply scons-begin body-exprs)))
                 (else
                  conjunct))))))))
-
-;;; SRFI 8: receive
-
-(define $receive
-  (spar-transformer->runtime
-   (delay
-     (scons-rule `(,r4rs-lambda-list? any (+ any))
-       (lambda (bvl expr body-forms)
-        (scons-call (scons-close 'call-with-values)
-                    (scons-lambda '() expr)
-                    (apply scons-lambda bvl body-forms)))))))
 \f
 ;;;; Conditionals
 
@@ -925,6 +974,6 @@ USA.
 
 (define-syntax $bundle
   (syntax-rules ()
-    ((_ predicate name ...)
+    (($bundle predicate name ...)
      (alist->bundle predicate
                     (list (cons 'name name) ...)))))
\ No newline at end of file

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d6aeab13cdf965cf8293224ce94fef1236ce3cc6..a413da278c54ef4e91ce623044ce70d27a1b7485 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4813,8 +4813,10 @@ USA.
          (include $include)            ;R7RS
          (include-ci $include-ci)      ;R7RS
          (let $let)                    ;R7RS
+         (let-values $let-values)      ;R7RS
          (let* $let*)                  ;R7RS
          (let*-syntax $let*-syntax)    ;R7RS
+         (let*-values $let*-values)    ;R7RS
          (letrec $letrec)              ;R7RS
          (letrec* $letrec*)            ;R7RS
          (local-declare $local-declare)