Add procedure SPECIALIZER-CLASSES.

diff --git a/v7/src/sos/class.scm b/v7/src/sos/class.scm
index bd5b4d9abdc69688579b2ab6035e47e11970cf60..b98e8cfd25e50e6b2ffb77946bf9fec8e8521b71 100644 (file)
--- a/v7/src/sos/class.scm
+++ b/v7/src/sos/class.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: class.scm,v 1.3 1997/06/19 20:12:30 cph Exp $
+;;; $Id: class.scm,v 1.4 1997/06/19 20:22:51 cph Exp $
 ;;;
 ;;; Copyright (c) 1995-97 Massachusetts Institute of Technology
 ;;;
@@ -111,18 +111,12 @@
   (guarantee-class class 'CLASS->DISPATCH-TAG)
   (class/dispatch-tag class))
 
-(define (subclass? c1 c2)
-  (guarantee-class c1 'SUBCLASS?)
-  (cond ((class? c2)
-        (memq c2 (class/precedence-list c1)))
-       ((record-type? c2)
-        (memq (record-type-class c2) (class/precedence-list c1)))
-       ((union-specializer? c2)
-        (there-exists? (union-specializer-classes c2)
-          (lambda (c2)
-            (memq c2 (class/precedence-list c1)))))
-       (else
-        (error:wrong-type-argument c2 "specializer" 'SUBCLASS?))))
+(define (subclass? c s)
+  (let ((pl (class-precedence-list c)))
+    (and (there-exists? (specializer-classes s)
+          (lambda (s)
+            (memq s pl)))
+        #t)))
 
 (define (guarantee-class class name)
   (if (not (class? class))

diff --git a/v7/src/sos/method.scm b/v7/src/sos/method.scm
index 3ab7c41b9b0213afa6fa2ca1b9960ee6344cc9fa..78fa055f8f2612c188dea7cdf4a206b13824983c 100644 (file)
--- a/v7/src/sos/method.scm
+++ b/v7/src/sos/method.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: method.scm,v 1.4 1997/06/16 09:00:48 cph Exp $
+;;; $Id: method.scm,v 1.5 1997/06/19 20:22:33 cph Exp $
 ;;;
 ;;; Copyright (c) 1995-97 Massachusetts Institute of Technology
 ;;;
@@ -292,6 +292,16 @@
       (and (union-specializer? s1)
           (union-specializer? s2)
           (union-specializer=? s1 s2))))
+
+(define (specializer-classes s)
+  (cond ((class? s)
+        (list s))
+       ((record-type? s)
+        (list (record-type-class s)))
+       ((union-specializer? s)
+        (union-specializer-classes s))
+       (else
+        (error:wrong-type-argument s "specializer" 'SPECIALIZER-CLASSES))))
 \f
 (define union-spec-rtd (make-record-type 'UNION-SPECIALIZER '(CLASSES)))
 (define make-union-specializer (record-constructor union-spec-rtd))

diff --git a/v7/src/sos/sos.pkg b/v7/src/sos/sos.pkg
index 3e11dfe696beaff77c03247cef4e0e3e590b391d..106ab6e69e52152bfd81b2ca8f280a97609ff4be 100644 (file)
--- a/v7/src/sos/sos.pkg
+++ b/v7/src/sos/sos.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sos.pkg,v 1.3 1997/06/15 06:41:44 cph Exp $
+$Id: sos.pkg,v 1.4 1997/06/19 20:22:40 cph Exp $
 
 Copyright (c) 1995-97 Massachusetts Institute of Technology
 
@@ -160,6 +160,7 @@ MIT in each case. |#
          method-procedure
          method-specializers
          method?
+         specializer-classes
          specializer=?
          specializer?
          specializers=?