From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 24 Oct 1990 15:09:57 +0000 (+0000)
Subject: Provide expanders for `values' and `with-values' that avoid expensive
X-Git-Tag: 20090517-FFI~11119
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4732879206ec27aab67a883e86846be2e31903b6;p=mit-scheme.git

Provide expanders for `values' and `with-values' that avoid expensive
rest arguments and calls to eval.
---

diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm
index dec32de04..7ebeaf0ab 100644
--- a/v7/src/sf/usiexp.scm
+++ b/v7/src/sf/usiexp.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 4.7 1990/10/19 22:25:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 4.8 1990/10/24 15:09:57 cph Rel $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -262,6 +262,43 @@ MIT in each case. |#
       (make-combination (ucode-primitive cons)
 			(list (car rest)
 			      (list-expansion-loop (cdr rest))))))
+
+(define (values-expansion operands if-expanded if-not-expanded block)
+  if-not-expanded
+  (if-expanded
+   (let ((block (block/make block true)))
+     (let ((variables
+	    (map (lambda (operand)
+		   operand
+		   (variable/make block
+				  (string->uninterned-symbol "value")
+				  '()))
+		 operands)))
+       (set-block/bound-variables! block variables)
+       (combination/make
+	(procedure/make
+	 block lambda-tag:let variables '() false
+	 (let ((block (block/make block true)))
+	   (let ((variable (variable/make block 'RECEIVER '())))
+	     (let ((variables* (list variable)))
+	       (set-block/bound-variables! block variables*)
+	       (procedure/make
+		block lambda-tag:unnamed variables* '() false
+		(combination/make (reference/make block variable)
+				  (map (lambda (variable)
+					 (reference/make block variable))
+				       variables)))))))
+	operands)))))
+
+(define (with-values-expansion operands if-expanded if-not-expanded block)
+  block
+  (if (and (pair? operands)
+	   (pair? (cdr operands))
+	   (null? (cddr operands)))
+      (if-expanded
+       (combination/make (combination/make (car operands) '())
+			 (cdr operands)))
+      (if-not-expanded)))
 
 ;;;; General CAR/CDR Encodings
 
@@ -452,8 +489,10 @@ MIT in each case. |#
     seventh
     sixth
     third
+    values
     vector?
     weak-pair?
+    with-values
     zero?
     ))
 
@@ -524,8 +563,10 @@ MIT in each case. |#
    seventh-expansion
    sixth-expansion
    third-expansion
+   values-expansion
    vector?-expansion
    weak-pair?-expansion
+   with-values-expansion
    zero?-expansion
    ))