From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 8 Jul 2019 19:35:03 +0000 (-0400)
Subject: Add procedure-arity-intersection.
X-Git-Tag: mit-scheme-pucked-10.1.12~7^2~15
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7da75bdcdb935a4fb72a05482b4b54cebd750d84;p=mit-scheme.git

Add procedure-arity-intersection.
---

diff --git a/src/runtime/procedure.scm b/src/runtime/procedure.scm
index a4c59a1ff..9482fdbfd 100644
--- a/src/runtime/procedure.scm
+++ b/src/runtime/procedure.scm
@@ -220,6 +220,15 @@ USA.
 		(fix:<= (procedure-arity-max arity1)
 			(procedure-arity-max arity2))))))
 
+(define (procedure-arity-intersection a1 a2)
+  (make-procedure-arity (fix:max (procedure-arity-min a1)
+				 (procedure-arity-min a2))
+                        (let ((m1 (procedure-arity-max a1))
+                              (m2 (procedure-arity-max a2)))
+			  (if m1
+			      (if m2 (fix:min m1 m2) m1)
+			      m2))))
+
 (define-integrable (simple-arity? object)
   (index-fixnum? object))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index acb35ec28..714d247a5 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1932,6 +1932,7 @@ USA.
 	  primitive-procedure-name
 	  primitive-procedure?
 	  procedure-arity
+	  procedure-arity-intersection
 	  procedure-arity-max
 	  procedure-arity-min
 	  procedure-arity-valid?