From e4864aab641e1b0fbd284aaac4187885f9e65109 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sun, 21 Jun 1998 10:16:56 +0000
Subject: [PATCH] Since funcallable-standard-objects are now disjoint from
 standard-objects, classes with meta-class standard-class are no longer valid
 super-classes of classes with meta-class funcallable-standard-class, so
 validate-superclass should now return NIL for this combination.

Further classes with meta-class std-class are now valid superclasses
of classes with meta-class of either standard-class or
funcallable-standard-class; add validate-superclass methods allowing
such super-classes which are handy for mixins of both standard-objects
and funcallable-standard-objects.
---
 pcl/fsc.lisp       | 10 +++++-----
 pcl/std-class.lisp |  6 +++++-
 2 files changed, 10 insertions(+), 6 deletions(-)

diff --git a/pcl/fsc.lisp b/pcl/fsc.lisp
index 6d7f28a5c..d0071f598 100644
--- a/pcl/fsc.lisp
+++ b/pcl/fsc.lisp
@@ -53,11 +53,11 @@
 ;;;
 ;;;
 
-(defmethod validate-superclass
-	   ((fsc funcallable-standard-class)
-	    (class standard-class))
-  t) ; was (null (wrapper-instance-slots-layout (class-wrapper class)))
-
+(defmethod validate-superclass ((fsc funcallable-standard-class)
+				(new-super std-class))
+  (let ((new-super-meta-class (class-of new-super)))
+    (or (eq new-super-meta-class *the-class-std-class*)
+	(eq (class-of fsc) new-super-meta-class))))
 
 (defmethod allocate-instance
 	   ((class funcallable-standard-class) &rest initargs)
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index 3eb085abe..c3cec2f87 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -1017,6 +1017,10 @@
   (or (eq new-super *the-class-t*)
       (eq (class-of class) (class-of new-super))))
 
+(defmethod validate-superclass ((class standard-class) (new-super std-class))
+  (let ((new-super-meta-class (class-of new-super)))
+    (or (eq new-super-meta-class *the-class-std-class*)
+	(eq (class-of class) new-super-meta-class))))
 
 
 ;;;
@@ -1301,7 +1305,7 @@
 ;;;
 
 (defmethod validate-superclass ((c slot-class)
-						(f forward-referenced-class))
+				(f forward-referenced-class))
   't)
 
 
-- 
GitLab