Add MAKE-LAMBDA-LIST.

diff --git a/src/runtime/lambda-list.scm b/src/runtime/lambda-list.scm
index 44936b94c48642246a9c085b4e6b8a9e6cd328cd..b65b7f801cb9344c5122180014db9ece723e6a9a 100644 (file)
--- 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 205e98aec5bdd06d97b1e7536012e6a8fc7a0e3d..b02226455bd98c3b5d4a856aa5f05b70edc36f39 100644 (file)
--- 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 5dfa1c85e6b3d0b4096ddeba48c21b8fd17daa5a..cfe678b85c430db1c7b0d7a1720d75690a296f78 100644 (file)
--- 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