Implement unary-procedure? and binary-procedure?.

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index b68a421d4f8f25d88f8b2bb3a34ebea1cd4bccb7..c540ad064af78dbc753355c3c7bd7d531b89b99d 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -104,7 +104,7 @@ USA.
          (not (tag-extra tag)))))
 \f
 (define (make-tag predicate name #!optional extra description)
-  (guarantee-procedure-of-arity predicate 1 'make-tag)
+  (guarantee unary-procedure? predicate 'make-tag)
   (guarantee tag-name? name 'make-tag)
   (if (predicate? predicate)
       (error "Predicate is already registered:" predicate))
@@ -270,12 +270,14 @@ USA.
 
    ;; MIT/GNU Scheme: procedures
    (register-predicate! apply-hook? 'apply-hook '<= procedure?)
+   (register-predicate! binary-procedure? 'binary-procedure '<= procedure?)
    (register-predicate! compiled-procedure? 'compiled-procedure '<= procedure?)
    (register-predicate! entity? 'entity '<= procedure?)
    (register-predicate! generic-procedure? 'generic-procedure '<= procedure?)
    (register-predicate! primitive-procedure? 'primitive-procedure
                        '<= procedure?)
    (register-predicate! thunk? 'thunk '<= procedure?)
+   (register-predicate! unary-procedure? 'unary-procedure '<= procedure?)
    (register-predicate! unparser-method? 'unparser-method '<= procedure?)
 
    ;; MIT/GNU Scheme: URIs

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index cd23dfe0cdc9b27b472690f271b9713d644aeea6..bc9fa89f6e88037e92752e06975dec300158dd53 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1693,6 +1693,7 @@ USA.
          apply-hook-procedure
          apply-hook?
          arity-dispatched-procedure?
+         binary-procedure?
          compiled-closure->entry
          compiled-closure/ref
          compiled-closure/set!
@@ -1737,7 +1738,8 @@ USA.
          set-apply-hook-procedure!
          set-entity-extra!
          set-entity-procedure!
-         thunk?)
+         thunk?
+         unary-procedure?)
   (export (runtime continuation-parser)
          compiled-procedure-frame-size))
 

diff --git a/src/runtime/uproc.scm b/src/runtime/uproc.scm
index 07c0cc85f225b1e631c1fc213c71bea1c7dc74d0..271284d810eaa61004ead39e6e11611e6eaeacdb 100644 (file)
--- a/src/runtime/uproc.scm
+++ b/src/runtime/uproc.scm
@@ -146,6 +146,14 @@ USA.
 
 (define-guarantee thunk "thunk")
 
+(define (unary-procedure? object)
+  (and (procedure? object)
+       (procedure-arity-valid? object 1)))
+
+(define (binary-procedure? object)
+  (and (procedure? object)
+       (procedure-arity-valid? object 2)))
+
 (define-integrable (procedure-of-arity? object arity)
   (and (procedure? object)
        (procedure-arity-valid? object arity)))