From 3c10840175a87d2d7e04ea6a7d0ba22f4cef9f56 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 16 May 2018 22:16:19 -0700
Subject: [PATCH] Implement fold-r4rs-lambda-list and r4rs-lambda-list-arity.

---
 src/runtime/lambda-list.scm | 39 ++++++++++++++++++++++++++-----------
 src/runtime/runtime.pkg     |  2 ++
 2 files changed, 30 insertions(+), 11 deletions(-)

diff --git a/src/runtime/lambda-list.scm b/src/runtime/lambda-list.scm
index d74c53f60..0e7509238 100644
--- 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 b1361360a..714b5d52e 100644
--- 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)
-- 
2.25.1