diff --git a/src/CHANGELOG b/src/CHANGELOG index dc3286dd2..667d4b3b2 100755 --- a/src/CHANGELOG +++ b/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 *** diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 96186338c..ccef23788 100644 --- a/src/clos/fixup.lsp +++ b/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) diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index 2307b1d43..706c8eef1 100644 --- a/src/clos/standard.lsp +++ b/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 ;;; diff --git a/src/clos/streams.lsp b/src/clos/streams.lsp index d13ea18a4..ca36c6738 100644 --- a/src/clos/streams.lsp +++ b/src/clos/streams.lsp @@ -711,3 +711,6 @@ (export cl-symbol gray-package)))) (si::package-lock "COMMON-LISP" x) nil)) + +(setf *clos-booted* t) +