From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 19 Jun 1997 20:22:51 +0000 (+0000)
Subject: Add procedure SPECIALIZER-CLASSES.
X-Git-Tag: 20090517-FFI~5122
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=42b076b6b557cc170ea95cabac90e890856eaf99;p=mit-scheme.git

Add procedure SPECIALIZER-CLASSES.
---

diff --git a/v7/src/sos/class.scm b/v7/src/sos/class.scm
index bd5b4d9ab..b98e8cfd2 100644
--- 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 3ab7c41b9..78fa055f8 100644
--- 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))))
 
 (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 3e11dfe69..106ab6e69 100644
--- 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=?