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