Implement fold-r4rs-lambda-list and r4rs-lambda-list-arity.

diff --git a/src/runtime/lambda-list.scm b/src/runtime/lambda-list.scm
index d74c53f60db772a8af1989a1e2784de3ecf8430d..0e75092381e566c4bf254a76e1868597d566a2e6 100644 (file)
--- a/src/runtime/lambda-list.scm
+++ b/src/runtime/lambda-list.scm
@@ -38,18 +38,35 @@ USA.
                 (not (memq (car object) seen))
                 (loop (cdr object) (cons (car object) seen)))))))
 
+(define (fold-r4rs-lambda-list procedure initial bvl)
+  (let loop ((bvl* bvl))
+    (cond ((and (pair? bvl*) (identifier? (car bvl*)))
+          (procedure (car bvl*) (loop (cdr bvl*))))
+         ((null? bvl*) (initial #f))
+         ((identifier? bvl*) (initial bvl*))
+         (else (error:not-a r4rs-lambda-list? bvl)))))
+
 (define (parse-r4rs-lambda-list bvl)
-  (let loop ((bvl* bvl) (required '()))
-    (cond ((and (pair? bvl*)
-               (identifier? (car bvl*)))
-          (loop (cdr bvl*)
-                (cons (car bvl*) required)))
-         ((null? bvl*)
-          (values (reverse! required) #f))
-         ((identifier? bvl*)
-          (values (reverse! required) bvl*))
-         (else
-          (error:not-a r4rs-lambda-list? bvl)))))
+  (let ((parsed
+        (fold-r4rs-lambda-list (lambda (var parsed)
+                                 (cons (cons var (car parsed))
+                                       (cdr parsed)))
+                               (lambda (var)
+                                 (cons '() var))
+                               bvl)))
+    (values (car parsed) (cdr parsed))))
+
+(define (r4rs-lambda-list-arity bvl)
+  (let ((arity
+        (fold-r4rs-lambda-list (lambda (var arity)
+                                 (declare (ignore var))
+                                 (cons (fix:+ 1 (car arity))
+                                       (and (cdr arity)
+                                            (fix:+ 1 (cdr arity)))))
+                               (lambda (var)
+                                 (cons 0 (if var #f 0)))
+                               bvl)))
+    (make-procedure-arity (car arity) (cdr arity))))
 
 (define (map-r4rs-lambda-list procedure bvl)
   (let loop ((bvl* bvl))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index b1361360a529fc6ca2baf834a6df6cb1eed84b05..714b5d52ee29e58cd345bf7e0ba38d1c6f3edb9c 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3055,6 +3055,7 @@ USA.
   (files "lambda-list")
   (parent (runtime))
   (export ()
+         fold-r4rs-lambda-list
          lambda-tag:aux
          lambda-tag:key
          lambda-tag:optional
@@ -3066,6 +3067,7 @@ USA.
          mit-lambda-list?
          parse-mit-lambda-list
          parse-r4rs-lambda-list
+         r4rs-lambda-list-arity
          r4rs-lambda-list?))
 
 (define-package (runtime srfi-1)