From 2fc61607ab7914f231880bf2aa166ca9728ab14e Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 23 Oct 2018 21:28:42 -0700
Subject: [PATCH] Implement let-values and let*-values.

---
 src/runtime/library-standard.scm |  4 +-
 src/runtime/mit-macros.scm       | 73 ++++++++++++++++++++++++++------
 src/runtime/runtime.pkg          |  2 +
 3 files changed, 65 insertions(+), 14 deletions(-)

diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm
index 5f0c107b4..7f8373ce9 100644
--- 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 3ed2e05df..06c6c02bc 100644
--- 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)))))))))
 
+(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)))
+
 ;;; 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)))))))
 
 ;;;; 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 d6aeab13c..a413da278 100644
--- 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)
-- 
2.25.1