X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/2352f5e953db530b1dd2dc7da5cef489ccd08e6f..d5fdd49e70b734b791eb907706f92da5775e2a8b:/src/class-finalize-impl.lisp diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index 4696a0a..895b3c9 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -123,7 +123,7 @@ direct subclass then that subclass's direct superclasses list must order them relative to each other." - (dolist (class so-far) + (dolist (class (reverse so-far)) (dolist (candidate candidates) (when (member candidate (sod-class-direct-superclasses class)) (return-from clos-tiebreaker candidate)))) @@ -341,164 +341,205 @@ ;;;-------------------------------------------------------------------------- ;;; Sanity checking. +(defmethod check-class-initializer ((slot effective-slot) (class sod-class)) + (finalization-error (:missing-class-initializer) + (unless (find-class-initializer slot class) + (let ((dslot (effective-slot-direct-slot slot))) + (cerror* "Missing initializer for class slot `~A', ~ + defined by meta-superclass `~A' of `~A'" + dslot (sod-slot-class dslot) class))))) + +(defmethod check-class-initializer + ((slot sod-class-effective-slot) (class sod-class)) + ;; The programmer shouldn't set an explicit initializer here. + (finalization-error (:invalid-class-initializer) + (let ((init (find-class-initializer slot class)) + (dslot (effective-slot-direct-slot slot))) + (when init + (cerror* "Initializers not permitted for class slot `~A', ~ + defined by meta-superclass `~A' of `~A'" + dslot (sod-slot-class dslot) class) + (info-with-location init "Offending initializer defined here"))))) + (defmethod check-sod-class ((class sod-class)) - (with-default-error-location (class) - ;; Check the names of things are valid. - (flet ((check-list (list what namefunc) - (dolist (item list) - (let ((name (funcall namefunc item))) - (unless (valid-name-p name) - (cerror*-with-location item - "Invalid ~A name `~A' ~ - in class `~A'" - what name class)))))) - (unless (valid-name-p (sod-class-name class)) - (cerror* "Invalid class name `~A'" class)) - (unless (valid-name-p (sod-class-nickname class)) - (cerror* "Invalid class nickname `~A' for class `~A'" - (sod-class-nickname class) class)) - (check-list (sod-class-messages class) "message" #'sod-message-name) - (check-list (sod-class-slots class) "slot" #'sod-slot-name)) - - ;; Check that the class doesn't define conflicting things. - (labels ((check-list (list keyfunc complain) - (let ((seen (make-hash-table :test #'equal))) - (dolist (item list) - (let* ((key (funcall keyfunc item)) - (found (gethash key seen))) - (if found (funcall complain item found) - (setf (gethash key seen) item)))))) - (simple-previous (previous) - (info-with-location previous "Previous definition was here")) - (simple-complain (what namefunc) - (lambda (item previous) + ;; Check the names of things are valid. + (flet ((check-list (list what namefunc) + (dolist (item list) + (let ((name (funcall namefunc item))) + (unless (valid-name-p name) (cerror*-with-location item - "Duplicate ~A `~A' in class `~A'" - what (funcall namefunc item) class) - (simple-previous previous)))) - - ;; Make sure direct slots have distinct names. - (check-list (sod-class-slots class) #'sod-slot-name - (simple-complain "slot name" #'sod-slot-name)) - - ;; Make sure there's at most one initializer for each slot. - (flet ((check-initializer-list (list kind) - (check-list list #'sod-initializer-slot - (lambda (initializer previous) - (let ((slot - (sod-initializer-slot initializer))) - (cerror*-with-location initializer - "Duplicate ~ - initializer for ~ - ~A slot `~A' ~ - in class `~A'" - kind slot class) - (simple-previous previous)))))) - (check-initializer-list (sod-class-instance-initializers class) - "instance") - (check-initializer-list (sod-class-class-initializers class) - "class")) - - ;; Make sure messages have distinct names. - (check-list (sod-class-messages class) #'sod-message-name - (simple-complain "message name" #'sod-message-name)) - - ;; Make sure methods are sufficiently distinct. - (check-list (sod-class-methods class) #'sod-method-function-name - (lambda (method previous) - (cerror*-with-location method - "Duplicate ~A direct method ~ - for message `~A' ~ - in classs `~A'" - (sod-method-description method) - (sod-method-message method) - class) - (simple-previous previous))) - - ;; Make sure superclasses have distinct nicknames. - (let ((state (make-inheritance-path-reporter-state class))) - (check-list (sod-class-precedence-list class) #'sod-class-nickname - (lambda (super previous) - (cerror*-with-location class - "Duplicate nickname `~A' ~ - in superclasses of `~A': ~ - used by `~A' and `~A'" - (sod-class-nickname super) - class super previous) - (report-inheritance-path state super) - (report-inheritance-path state previous))))) - - ;; Check that the CHAIN-TO class is actually a proper superclass. (This - ;; eliminates hairy things like a class being its own link.) - (let ((link (sod-class-chain-link class))) - (unless (or (not link) - (member link (cdr (sod-class-precedence-list class)))) - (cerror* "In `~A~, chain-to class `~A' is not a proper superclass" - class link))) - - ;; Check that the initargs declare compatible types. Duplicate entries, - ;; even within a class, are harmless, but at most one initarg in any - ;; class should declare a default value. - (let ((seen (make-hash-table :test #'equal)) - (state (make-inheritance-path-reporter-state class))) - (dolist (super (sod-class-precedence-list class)) - (dolist (initarg (reverse (sod-class-initargs super))) - (let* ((initarg-name (sod-initarg-name initarg)) - (initarg-type (sod-initarg-type initarg)) - (initarg-default (sod-initarg-default initarg)) - (found (gethash initarg-name seen)) - (found-type (and found (sod-initarg-type found))) - (found-default (and found (sod-initarg-default found))) - (found-class (and found (sod-initarg-class found))) - (found-location (and found (file-location found)))) - (with-default-error-location (initarg) - (cond ((not found) - (setf (gethash initarg-name seen) initarg)) - ((not (c-type-equal-p initarg-type found-type)) - (cerror* "Inititalization argument `~A' defined ~ - with incompatible types: ~ - ~A in class `~A', but ~A in class `~A'" - initarg-name initarg-type super - found-type found-class found-location) - (report-inheritance-path state super)) - ((and initarg-default found-default - (eql super found-class)) - (cerror* "Initialization argument `~A' redefined ~ - with default value" - initarg-name) - (info-with-location found-location - "Previous definition is here")) - (initarg-default - (setf (gethash initarg-name seen) initarg)))))))) - - ;; Check for circularity in the superclass graph. Since the superclasses - ;; should already be acyclic, it suffices to check that our class is not - ;; a superclass of any of its own direct superclasses. - (let ((circle (find-if (lambda (super) - (sod-subclass-p super class)) - (sod-class-direct-superclasses class)))) - (when circle - (cerror* "`~A' is already a superclass of `~A'" class circle) - (report-inheritance-path (make-inheritance-path-reporter-state class) - circle))) - - ;; Check that the class has a unique root superclass. - (find-root-superclass class) - - ;; Check that the metaclass is a subclass of each direct superclass's - ;; metaclass. - (finalization-error (:bad-metaclass) - (let ((meta (sod-class-metaclass class))) - (dolist (super (sod-class-direct-superclasses class)) - (let ((supermeta (sod-class-metaclass super))) - (unless (sod-subclass-p meta supermeta) - (cerror* "Metaclass `~A' of `~A' isn't a subclass of `~A'" - meta class supermeta) - (info-with-location super - "Direct superclass `~A' defined here ~ - has metaclass `~A'" - super supermeta)))))))) + "Invalid ~A name `~A' in class `~A'" + what name class)))))) + (unless (valid-name-p (sod-class-name class)) + (cerror* "Invalid class name `~A'" class)) + (unless (valid-name-p (sod-class-nickname class)) + (cerror* "Invalid class nickname `~A' for class `~A'" + (sod-class-nickname class) class)) + (check-list (sod-class-messages class) "message" #'sod-message-name) + (check-list (sod-class-slots class) "slot" #'sod-slot-name)) + + ;; Check that the class doesn't define conflicting things. + (labels ((simple-previous (previous) + (info-with-location previous "Previous definition was here")) + (simple-complain (what namefunc) + (lambda (item previous) + (cerror*-with-location item + "Duplicate ~A `~A' in class `~A'" + what (funcall namefunc item) class) + (simple-previous previous)))) + + ;; Make sure direct slots have distinct names. + (find-duplicates (simple-complain "slot name" #'sod-slot-name) + (sod-class-slots class) + :key #'sod-slot-name + :test #'equal) + + ;; Make sure there's at most one initializer for each slot. + (flet ((check-initializer-list (list kind) + (find-duplicates (lambda (initializer previous) + (let ((slot + (sod-initializer-slot initializer))) + (cerror*-with-location initializer + "Duplicate ~ + initializer ~ + for ~A slot `~A' ~ + in class `~A'" + kind slot class) + (simple-previous previous))) + list + :key #'sod-initializer-slot))) + (check-initializer-list (sod-class-instance-initializers class) + "instance") + (check-initializer-list (sod-class-class-initializers class) + "class")) + + ;; Make sure messages have distinct names. + (find-duplicates (simple-complain "message name" #'sod-message-name) + (sod-class-messages class) + :key #'sod-message-name + :test #'equal) + + ;; Make sure methods are sufficiently distinct. + (find-duplicates (lambda (method previous) + (cerror*-with-location method + "Duplicate ~A direct method ~ + for message `~A' ~ + in classs `~A'" + (sod-method-description method) + (sod-method-message method) + class) + (simple-previous previous)) + (sod-class-methods class) + :key #'sod-method-function-name + :test #'equal) + + ;; Make sure superclasses have distinct nicknames. + (let ((state (make-inheritance-path-reporter-state class))) + (find-duplicates (lambda (super previous) + (cerror*-with-location class + "Duplicate nickname `~A' ~ + in superclasses of `~A': ~ + used by `~A' and `~A'" + (sod-class-nickname super) + class super previous) + (report-inheritance-path state super) + (report-inheritance-path state previous)) + (sod-class-precedence-list class) + :key #'sod-class-nickname :test #'equal))) + + ;; Check that the CHAIN-TO class is actually a proper superclass. (This + ;; eliminates hairy things like a class being its own link.) + (let ((link (sod-class-chain-link class))) + (unless (or (not link) + (member link (cdr (sod-class-precedence-list class)))) + (cerror* "In `~A', chain-to class `~A' is not a proper superclass" + class link))) + + ;; Check that the initargs declare compatible types. Duplicate entries, + ;; even within a class, are harmless, but at most one initarg in any + ;; class should declare a default value. + (let ((seen (make-hash-table :test #'equal)) + (state (make-inheritance-path-reporter-state class))) + (dolist (super (sod-class-precedence-list class)) + (dolist (initarg (reverse (sod-class-initargs super))) + (let* ((initarg-name (sod-initarg-name initarg)) + (initarg-type (sod-initarg-type initarg)) + (initarg-default (sod-initarg-default initarg)) + (found (gethash initarg-name seen)) + (found-type (and found (sod-initarg-type found))) + (found-default (and found (sod-initarg-default found))) + (found-class (and found (sod-initarg-class found))) + (found-location (and found (file-location found)))) + (with-default-error-location (initarg) + (cond ((not found) + (setf (gethash initarg-name seen) initarg)) + ((not (c-type-equal-p initarg-type found-type)) + (cerror* "Inititalization argument `~A' defined ~ + with incompatible types: ~ + ~A in class `~A', but ~A in class `~A'" + initarg-name initarg-type super + found-type found-class found-location) + (report-inheritance-path state super)) + ((and initarg-default found-default + (eql super found-class)) + (cerror* "Initialization argument `~A' redefined ~ + with default value" + initarg-name) + (info-with-location found-location + "Previous definition is here")) + (initarg-default + (setf (gethash initarg-name seen) initarg)))))))) + + ;; Check for circularity in the superclass graph. Since the superclasses + ;; should already be acyclic, it suffices to check that our class is not + ;; a superclass of any of its own direct superclasses. + (let ((circle (find-if (lambda (super) + (sod-subclass-p super class)) + (sod-class-direct-superclasses class)))) + (when circle + (cerror* "`~A' is already a superclass of `~A'" class circle) + (report-inheritance-path (make-inheritance-path-reporter-state class) + circle))) + + ;; Check that the class has a unique root superclass. + (find-root-superclass class) + + ;; Check that the metaclass is a subclass of each direct superclass's + ;; metaclass. + (finalization-error (:bad-metaclass) + (let ((meta (sod-class-metaclass class))) + (dolist (super (sod-class-direct-superclasses class)) + (let ((supermeta (sod-class-metaclass super))) + (unless (sod-subclass-p meta supermeta) + (cerror* "Metaclass `~A' of `~A' isn't a subclass of `~A'" + meta class supermeta) + (info-with-location super + "Direct superclass `~A' defined here ~ + has metaclass `~A'" + super supermeta)))))) + + ;; Check that all of the messages we can be sent have coherent collections + ;; of applicable methods. This can go wrong, for example, if we inherit + ;; methods with differently typed keyword arguments. + (finalization-error (:mismatched-applicable-methods) + (dolist (super (sod-class-precedence-list class)) + (dolist (message (sod-class-messages super)) + (let ((methods (sod-message-applicable-methods message class))) + (sod-message-check-methods message class methods))))) + + ;; Check that an initializer is available for every slot in the class's + ;; metaclass. Skip this and trust the caller if the metaclass isn't + ;; finalized yet: in that case, we must be bootstrapping, and we must hope + ;; that the caller knows what they're doing. + (let* ((meta (sod-class-metaclass class)) + (ilayout (and (eq (sod-class-state meta) :finalized) + (sod-class-ilayout meta)))) + (dolist (ichain (and ilayout (ilayout-ichains ilayout))) + (dolist (item (cdr (ichain-body ichain))) + (when (typep item 'islots) + (dolist (slot (islots-slots item)) + (check-class-initializer slot class))))))) ;;;-------------------------------------------------------------------------- ;;; Finalization.