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 c540ad064af78dbc753355c3c7bd7d531b89b99d..346e610081cc9b2828b51e71015b10a55a06899f 100644 (file)
--- 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 5feda691008f2654dd5b6dd3f65f4aa722f4c940..0d0fb5cd09a6ccec14b492f130ac698aa1cb0e6c 100644 (file)
--- 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 271284d810eaa61004ead39e6e11611e6eaeacdb..9c3f126d3ad9ddb8980f571aae4184197ce230f2 100644 (file)
--- 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))