From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 6 Jan 2017 19:57:18 +0000 (-0800)
Subject: Implement unary-procedure? and binary-procedure?.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~206
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8a670cdec565446454a9a3a7b76b73ceadc8fae0;p=mit-scheme.git

Implement unary-procedure? and binary-procedure?.
---

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index b68a421d4..c540ad064 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -104,7 +104,7 @@ USA.
          (not (tag-extra tag)))))
 
 (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 cd23dfe0c..bc9fa89f6 100644
--- 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 07c0cc85f..271284d81 100644
--- 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)))