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 2cf4225247b2ab85e7082f790b32d9c30902765f..b0ce8712fb0b1d03af774ea35f3b25a84ef00b9f 100644 (file)
--- 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 2cba70f4342476a1b5b590b4969ecfb6cba10a64..976c78a6cece989a8dc9fb7b222e9012891b03db 100644 (file)
--- 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 9b27512076d2c8cc6c5002174bb02e3bbeab40f1..bdba13e61b1fde91c29728a480e1923f2d77888b 100644 (file)
--- 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)