From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 19 May 2018 06:42:54 +0000 (-0700)
Subject: Implement define-values for R7RS.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~30
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3463bf98c98d7c3766050d84b1b0e3cc31d50067;p=mit-scheme.git

Implement define-values for R7RS.
---

diff --git a/src/runtime/lambda-list.scm b/src/runtime/lambda-list.scm
index 14b931a0c..7b951dd4e 100644
--- 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 6d3627e45..51c789a16 100644
--- 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))))))))))))
 
 ;;; 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 1ffbb9ba9..82b154b2e 100644
--- 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