From 086ec59ab81a50d5b522c82bf5660637fefdac77 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 31 Dec 2020 20:52:14 +0100 Subject: [PATCH] check-direct-superclasses: handle forward-referenced-class The forward-referenced-class metaclass has no superclasses. Moreover: - check superclasses after they are added (removes one fixme) - don't map validate-superclass during clos booting --- src/clos/standard.lsp | 41 +++++++++++++++++++++++------------------ 1 file changed, 23 insertions(+), 18 deletions(-) diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index 26d2ebae4..f39a55193 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -239,24 +239,29 @@ (remove child (class-direct-subclasses parent)))) (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 - ;; not mixed, and that STANDARD-CLASS, or STANDARD-GENERIC-FUNCTION, - ;; etc, are the first classes. + (unless supplied-superclasses + (setf supplied-superclasses + (typecase class + (standard-class + (list (find-class 'standard-object))) + (structure-class + (list (find-class 'structure-object))) + (funcallable-standard-class + (list (find-class 'funcallable-standard-object))) + (forward-referenced-class + nil) + (otherwise + (error "No :DIRECT-SUPERCLASS argument was supplied for the ~ + metaclass ~S." (class-of class)))))) + ;; Until we process streams.lsp there are some invalid combinations using + ;; built-in-class, which here we simply ignore. + (when (eq *clos-booted* T) + (loop for superclass in supplied-superclasses + unless (validate-superclass class superclass) + do (error "Class ~A is not a valid superclass for ~A" superclass class))) + ;; FIXME!!! We should check that structures and standard objects are not + ;; mixed, and that STANDARD-CLASS, or STANDARD-GENERIC-FUNCTION, etc, are + ;; the first classes. supplied-superclasses) (defmethod validate-superclass ((class class) (superclass class))