Added the predicate ARITY-DISPATCHED-PROCEDURE?, which is true for

certain kinds of ENTITY.

diff --git a/v7/src/runtime/uproc.scm b/v7/src/runtime/uproc.scm
index 41372b2107de1352f0c47288a8dc05d0b83c4a98..4dd70c8f0c5fc2d1c1c04709928a44605bcf4eb7 100644 (file)
--- a/v7/src/runtime/uproc.scm
+++ b/v7/src/runtime/uproc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uproc.scm,v 1.6 1992/12/10 01:34:17 cph Exp $
+$Id: uproc.scm,v 1.7 1995/01/12 17:02:26 adams Exp $
 
 Copyright (c) 1990-92 Massachusetts Institute of Technology
 
@@ -316,4 +316,22 @@ MIT in each case. |#
   (system-hunk3-set-cxr1! (entity-extra apply-hook) procedure))
 
 (define-integrable (set-apply-hook-extra! apply-hook procedure)
-  (system-hunk3-set-cxr2! (entity-extra apply-hook) procedure))
\ No newline at end of file
+  (system-hunk3-set-cxr2! (entity-extra apply-hook) procedure))
+\f
+;;;; Arity dispatched entities
+
+(define (make-arity-dispatched-procedure default . dispatched-cases)
+  ;; DISPATCHED-CASES are the procedures to invoke for 0, 1, 2 etc
+  ;; arguments, or #F if the DEFAULT is to be used.  The DEFAULT has a
+  ;; SELF argument.
+  (make-entity default
+              (list->vector
+               (cons (fixed-objects-item 'ARITY-DISPATCHER-TAG)
+                     dispatched-cases))))
+
+(define (arity-dispatched-procedure? object)
+  (and (%entity? object)
+       (vector? (entity-extra object))
+       (< 0 (vector-length (entity-extra object)))
+       (eq? (vector-ref (entity-extra object) 0)
+           (fixed-objects-item 'ARITY-DISPATCHER-TAG))))
\ No newline at end of file