Implemented and used in the core: VALIDATE-SUPERCLASSES

src/CHANGELOG

@@ -31,6 +31,8 @@ ECL 12.2.2:
  - COMPUTE-APPLICABLE-METHODS and CLOS:COMPUTE-EFFECTIVE-METHOD are now
    generic functions.
 
+ - Implemented and used in the core: VALIDATE-SUPERCLASSES
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***

src/clos/fixup.lsp

@@ -326,7 +326,7 @@ their lambda lists ~A and ~A are not congruent."
   (declare (ignore dep initargs object))
   (recursively-update-classes +the-class+))
 
-(setf *clos-booted* t)
+(setf *clos-booted* 'built-in-class)
 
 (let ((x (make-instance 'initargs-updater)))
   (add-dependent #'shared-initialize x)

src/clos/standard.lsp

@@ -210,14 +210,20 @@
   (setf (class-direct-subclasses parent)
 	(remove child (class-direct-subclasses parent))))
 
-(defmethod check-direct-superclasses (class supplied-superclasses)
-  (unless supplied-superclasses
-    (setf supplied-superclasses
-	  (list (find-class (typecase class
-			      (STANDARD-CLASS 'STANDARD-OBJECT)
-			      (STRUCTURE-CLASS 'STRUCTURE-OBJECT)
-			      (FUNCALLABLE-STANDARD-CLASS 'FUNCALLABLE-STANDARD-OBJECT)
-			      (otherwise (error "No :DIRECT-SUPERCLASS ~
+(defun check-direct-superclasses (class supplied-superclasses)
+  (if supplied-superclasses
+      (loop for superclass in supplied-superclasses
+	 ;; Until we process streams.lsp there are some invalid combinations
+	 ;; using built-in-class, which here we simply ignore.
+	 unless (or (validate-superclass class superclass)
+		    (not (eq *clos-booted* T)))
+	 do (error "Class ~A is not a valid superclass for ~A" superclass class))
+      (setf supplied-superclasses
+	    (list (find-class (typecase class
+				(STANDARD-CLASS 'STANDARD-OBJECT)
+				(STRUCTURE-CLASS 'STRUCTURE-OBJECT)
+				(FUNCALLABLE-STANDARD-CLASS 'FUNCALLABLE-STANDARD-OBJECT)
+				(otherwise (error "No :DIRECT-SUPERCLASS ~
 argument was supplied for metaclass ~S." (class-of class))))))))
   ;; FIXME!!! Here should come the invocation of VALIDATE-SUPERCLASS!
   ;; FIXME!!! We should check that structures and standard objects are
@@ -225,6 +231,17 @@ argument was supplied for metaclass ~S." (class-of class))))))))
   ;; etc, are the first classes.
   supplied-superclasses)
 
+(defmethod validate-superclass ((class class) (superclass class))
+  (or (eq superclass +the-t-class+)
+      (let ((c1 (class-of class))
+	    (c2 (class-of superclass)))
+	(or (eq c1 c2)
+	    (and (eq c1 +the-standard-class+) (eq c2 +the-funcallable-standard-class+))
+	    (and (eq c2 +the-standard-class+) (eq c1 +the-funcallable-standard-class+))
+	    ))
+      (forward-referenced-class-p superclass)
+      ))
+
 ;;; ----------------------------------------------------------------------
 ;;; FINALIZATION OF CLASS INHERITANCE
 ;;;

src/clos/streams.lsp

@@ -711,3 +711,6 @@
 	      (export cl-symbol gray-package))))
     (si::package-lock "COMMON-LISP" x)
     nil))
+
+(setf *clos-booted* t)
+