From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 6 Jan 2017 21:16:06 +0000 (-0800)
Subject: Generalize procedure-arity-valid? to take an arbitrary arity.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~204
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2d8cff3b15668bea34d42e1fc4761a4ce4effb77;p=mit-scheme.git

Generalize procedure-arity-valid? to take an arbitrary arity.

Also provide procedure-arity<=.
---

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index c540ad064..346e61008 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -276,6 +276,7 @@ USA.
    (register-predicate! generic-procedure? 'generic-procedure '<= procedure?)
    (register-predicate! primitive-procedure? 'primitive-procedure
 			'<= procedure?)
+   (register-predicate! procedure-arity? 'procedure-arity)
    (register-predicate! thunk? 'thunk '<= procedure?)
    (register-predicate! unary-procedure? 'unary-procedure '<= procedure?)
    (register-predicate! unparser-method? 'unparser-method '<= procedure?)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 5feda6910..0d0fb5cd0 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1728,6 +1728,7 @@ USA.
 	  procedure-arity-max
 	  procedure-arity-min
 	  procedure-arity-valid?
+	  procedure-arity<=
 	  procedure-arity?
 	  procedure-components
 	  procedure-environment
diff --git a/src/runtime/uproc.scm b/src/runtime/uproc.scm
index 271284d81..9c3f126d3 100644
--- a/src/runtime/uproc.scm
+++ b/src/runtime/uproc.scm
@@ -133,12 +133,8 @@ USA.
 	   (error:wrong-type-argument procedure "procedure"
 				      'PROCEDURE-ARITY)))))
 
-(define (procedure-arity-valid? procedure n-arguments)
-  (guarantee-index-fixnum n-arguments 'PROCEDURE-ARITY-VALID?)
-  (let ((arity (procedure-arity procedure)))
-    (and (<= (car arity) n-arguments)
-	 (or (not (cdr arity))
-	     (<= n-arguments (cdr arity))))))
+(define (procedure-arity-valid? procedure arity)
+  (procedure-arity<= arity (procedure-arity procedure)))
 
 (define (thunk? object)
   (and (procedure? object)
@@ -198,6 +194,14 @@ USA.
 	((general-arity? arity) (cdr arity))
 	(else (error:not-procedure-arity arity 'PROCEDURE-ARITY-MAX))))
 
+(define (procedure-arity<= arity1 arity2)
+  (and (fix:<= (procedure-arity-min arity2)
+	       (procedure-arity-min arity1))
+       (or (not (procedure-arity-max arity2))
+	   (and (procedure-arity-max arity1)
+		(fix:<= (procedure-arity-max arity1)
+			(procedure-arity-max arity2))))))
+
 (define-integrable (simple-arity? object)
   (index-fixnum? object))