From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 4 Jun 1997 22:29:00 +0000 (+0000)
Subject: Reimplement INSTANCE-PREDICATE to return a generic procedure.  Move
X-Git-Tag: 20090517-FFI~5160
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fdab7540ef16968277dfccb3e3631e90bc09f244;p=mit-scheme.git

Reimplement INSTANCE-PREDICATE to return a generic procedure.  Move
INSTANCE-PREDICATE and INSTANCE-OF? to "instance.scm".
---

diff --git a/v7/src/sos/class.scm b/v7/src/sos/class.scm
index 2cf422524..b0ce8712f 100644
--- a/v7/src/sos/class.scm
+++ b/v7/src/sos/class.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: class.scm,v 1.1 1997/06/04 06:08:13 cph Exp $
+;;; $Id: class.scm,v 1.2 1997/06/04 22:29:00 cph Exp $
 ;;;
-;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;; Copyright (c) 1995-97 Massachusetts Institute of Technology
 ;;;
 ;;; This material was developed by the Scheme project at the
 ;;; Massachusetts Institute of Technology, Department of Electrical
@@ -400,12 +400,4 @@
 		 standard-generic-procedure-tag
 		 <generic-procedure>)
 
-(define <class> (object-class <object>))
-
-(define (instance-predicate class)
-  (guarantee-class class 'INSTANCE-PREDICATE)
-  (lambda (object) (instance-of? object class)))
-
-(define (instance-of? object class)
-  (and (subclass? (object-class object) class)
-       #t))
\ No newline at end of file
+(define <class> (object-class <object>))
\ No newline at end of file
diff --git a/v7/src/sos/instance.scm b/v7/src/sos/instance.scm
index 2cba70f43..976c78a6c 100644
--- a/v7/src/sos/instance.scm
+++ b/v7/src/sos/instance.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: instance.scm,v 1.1 1997/06/04 06:08:35 cph Exp $
+;;; $Id: instance.scm,v 1.2 1997/06/04 22:28:54 cph Exp $
 ;;;
-;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;; Copyright (c) 1995-97 Massachusetts Institute of Technology
 ;;;
 ;;; This material was developed by the Scheme project at the
 ;;; Massachusetts Institute of Technology, Department of Electrical
@@ -155,4 +155,19 @@
        (class? (dispatch-tag-contents (tagged-vector-tag object)))))
 
 (define (instance-class instance)
-  (dispatch-tag-contents (tagged-vector-tag instance)))
\ No newline at end of file
+  (dispatch-tag-contents (tagged-vector-tag instance)))
+
+(define (instance-predicate class)
+  (guarantee-class class 'INSTANCE-PREDICATE)
+  (let ((predicate (make-generic-procedure 1)))
+    (let ((add
+	   (lambda (c v)
+	     (add-method predicate
+			 (make-method (list c) (lambda (object) object v))))))
+      (add <object> #f)
+      (add class #t))
+    predicate))
+
+(define (instance-of? object class)
+  (and (subclass? (object-class object) class)
+       #t))
\ No newline at end of file
diff --git a/v7/src/sos/sos.pkg b/v7/src/sos/sos.pkg
index 9b2751207..bdba13e61 100644
--- a/v7/src/sos/sos.pkg
+++ b/v7/src/sos/sos.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sos.pkg,v 1.1 1997/06/04 06:09:57 cph Exp $
+$Id: sos.pkg,v 1.2 1997/06/04 22:28:49 cph Exp $
 
 Copyright (c) 1995-97 Massachusetts Institute of Technology
 
@@ -116,8 +116,6 @@ MIT in each case. |#
 	  class-slots
 	  class?
 	  dispatch-tag->class
-	  instance-of?
-	  instance-predicate
 	  make-class
 	  make-trivial-subclass
 	  object-class
@@ -131,6 +129,8 @@ MIT in each case. |#
   (export ()
 	  instance-class
 	  instance-constructor
+	  instance-of?
+	  instance-predicate
 	  instance?))
 
 (define-package (sos method)