From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Thu, 12 Jan 1995 17:02:26 +0000 (+0000)
Subject: Added the predicate ARITY-DISPATCHED-PROCEDURE?, which is true for
X-Git-Tag: 20090517-FFI~6753
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=716f87dd9030926da24fadd27861161fb3f03d3d;p=mit-scheme.git

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 41372b210..4dd70c8f0 100644
--- 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))
+
+;;;; 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