From: Joe Marshall <eval.apply@gmail.com>
Date: Mon, 6 Feb 2012 16:55:54 +0000 (-0800)
Subject: Add MAKE-LAMBDA-LIST.
X-Git-Tag: release-9.2.0~319
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=98a081afdaf55c969eb6dc6c9a5e618bac409051;p=mit-scheme.git

Add MAKE-LAMBDA-LIST.
---

diff --git a/src/runtime/lambda-list.scm b/src/runtime/lambda-list.scm
index 44936b94c..b65b7f801 100644
--- a/src/runtime/lambda-list.scm
+++ b/src/runtime/lambda-list.scm
@@ -202,4 +202,25 @@ USA.
 	      (loop (cdr bvl)))
 	(if (identifier? bvl)
 	    (procedure bvl)
-	    '()))))
\ No newline at end of file
+	    '()))))
+
+;;; Aux is almost always the empty list.
+(define (make-lambda-list required optional rest aux)
+  (guarantee-list-of-unique-symbols required)
+  (guarantee-list-of-unique-symbols optional)
+  (if rest
+      (guarantee-symbol rest))
+  (guarantee-list-of-unique-symbols aux)
+  (let ((rest-aux-tail (if (not rest)
+			   (if (null? aux)
+			       '()
+			       (cons lambda-tag:aux aux))
+			   (if (null? aux)
+			       rest
+			       (cons* lambda-tag:rest rest
+				      lambda-tag:aux aux)))))
+    (append required
+	    (if (null? optional)
+		rest-aux-tail
+		(cons lambda-tag:optional
+		      (append optional rest-aux-tail))))))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 205e98aec..b02226455 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2645,6 +2645,7 @@ USA.
 	  lambda-tag:optional
 	  lambda-tag:rest
 	  lambda-tag?
+	  make-lambda-list
 	  map-mit-lambda-list
 	  map-r4rs-lambda-list
 	  mit-lambda-list?
diff --git a/src/runtime/unsyn.scm b/src/runtime/unsyn.scm
index 5dfa1c85e..cfe678b85 100644
--- a/src/runtime/unsyn.scm
+++ b/src/runtime/unsyn.scm
@@ -170,7 +170,7 @@ USA.
 	 (lambda-components** value
 	   (lambda (lambda-name required optional rest body)
 	     (if (eq? lambda-name name)
-		 `(DEFINE (,name . ,(lambda-list required optional rest '()))
+		 `(DEFINE (,name . ,(make-lambda-list required optional rest '()))
 		    ,@(with-bindings required optional rest
 				     unsyntax-lambda-body body))
 		 `(DEFINE ,name ,@(unexpand-binding-value value))))))
@@ -320,13 +320,13 @@ USA.
       (lambda-components** expression
 	(lambda (name required optional rest body)
 	  (collect-lambda name
-			  (lambda-list required optional rest '())
+			  (make-lambda-list required optional rest '())
 			  (with-bindings required optional rest
 					 unsyntax-lambda-body body))))
       (lambda-components expression
 	(lambda (name required optional rest auxiliary declarations body)
 	  (collect-lambda name
-			  (lambda-list required optional rest auxiliary)
+			  (make-lambda-list required optional rest auxiliary)
 			  (let ((body (unsyntax-sequence body)))
 			    (if (null? declarations)
 				body
@@ -345,18 +345,7 @@ USA.
   (lambda-components** expression
     (lambda (name required optional rest body)
       name body
-      (lambda-list required optional rest '()))))
-
-(define (lambda-list required optional rest auxiliary)
-  (let ((optional (if (null? optional)
-		      '()
-		      (cons lambda-tag:optional optional)))
-	(rest (cond ((not rest) '())
-		    ((null? auxiliary) rest)
-		    (else (list lambda-tag:rest rest)))))
-    (if (null? auxiliary)
-	`(,@required ,@optional . ,rest)
-	`(,@required ,@optional ,@rest ,lambda-tag:aux ,@auxiliary))))
+      (make-lambda-list required optional rest '()))))
 
 (define (lambda-components** expression receiver)
   (lambda-components expression