From ab7e7521a95d737ed6d1bf94964fc44d46ab077c Mon Sep 17 00:00:00 2001 Message-Id: From: Mark Wooding Date: Sun, 26 Mar 2017 14:48:23 +0100 Subject: [PATCH] src/class-finalize-impl.lisp: Overhaul `check-sod-class', `compute-chains'. Organization: Straylight/Edgeware From: Mark Wooding Signal continuable errors so that we can get more useful diagnostics. Use the `finalization-error' machinery to limit redundant error reporting. Report portions of inheritance structure where appropriate. Improve checking that the things defined by the class don't conflict with each other. --- src/class-finalize-impl.lisp | 215 +++++++++++++++++++++++------------ 1 file changed, 142 insertions(+), 73 deletions(-) diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index 320534b..f67c118 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -269,6 +269,7 @@ (defmethod compute-chains ((class sod-class)) class)) (chain (cons class (and chain-link (sod-class-chain chain-link)))) + (state (make-inheritance-path-reporter-state class)) (table (make-hash-table))) ;; Check the chains. We work through each superclass, maintaining a @@ -277,13 +278,15 @@ (defmethod compute-chains ((class sod-class)) ;; we've found an error. By the end of all of this, the classes ;; which don't have an entry are the chain tails. (dolist (super class-precedence-list) - (let ((link (sod-class-chain-link super))) - (when link - (when (gethash link table) - (error "Conflicting chains in class ~A: ~ - (~A and ~A both link to ~A)" - class super (gethash link table) link)) - (setf (gethash link table) super)))) + (let* ((link (sod-class-chain-link super)) + (found (and link (gethash link table)))) + (cond ((not found) (setf (gethash link table) super)) + (t + (cerror* "Conflicting chains in class `~A': ~ + (`~A' and `~A' both link to `~A')" + class super found link) + (report-inheritance-path state super) + (report-inheritance-path state found))))) ;; Done. (values head chain @@ -321,72 +324,132 @@ (defmethod check-sod-class ((class sod-class)) (with-default-error-location (class) ;; Check the names of things are valid. - (with-slots (name nickname messages) class - (unless (valid-name-p name) - (error "Invalid class name `~A'" class)) - (unless (valid-name-p nickname) - (error "Invalid class nickname `~A' on class `~A'" nickname class)) - (dolist (message messages) - (unless (valid-name-p (sod-message-name message)) - (error "Invalid message name `~A' on class `~A'" - (sod-message-name message) class)))) - - ;; Check that the slots and messages have distinct names. - (with-slots (slots messages class-precedence-list) class - (flet ((check-list (list what namefunc) - (let ((table (make-hash-table :test #'equal))) + (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 ((name (funcall namefunc item))) - (if (gethash name table) - (error "Duplicate ~A name `~A' on class `~A'" - what name class) - (setf (gethash name table) item))))))) - (check-list slots "slot" #'sod-slot-name) - (check-list messages "message" #'sod-message-name) - (check-list class-precedence-list "nickname" #'sod-class-name))) + (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) + (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.) - (with-slots (class-precedence-list chain-link) class - (unless (or (not chain-link) - (member chain-link (cdr class-precedence-list))) - (error "In `~A~, chain-to class `~A' is not a proper superclass" - class chain-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. - (with-slots (class-precedence-list) class - (let ((seen (make-hash-table :test #'equal))) - (dolist (super class-precedence-list) - (with-slots (initargs) super - (dolist (initarg (reverse initargs)) - (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, and ~ - ~A in class ~A (at ~A)" - initarg-name initarg-type super - found-type found-class found-location)) - ((and initarg-default found-default - (eql super found-class)) - (cerror* "Initialization argument `~A' redefined ~ - with default value ~ - (previous definition at ~A)" - initarg-name found-location)) - (initarg-default - (setf (gethash initarg-name seen) initarg)))))))))) + (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 @@ -395,20 +458,26 @@ (defmethod check-sod-class ((class sod-class)) (sod-subclass-p super class)) (sod-class-direct-superclasses class)))) (when circle - (error "Circularity: ~A is already a superclass of ~A" - class 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. - (with-slots (metaclass direct-superclasses) class - (dolist (super direct-superclasses) - (unless (sod-subclass-p metaclass (sod-class-metaclass super)) - (error "Incompatible metaclass for `~A': ~ - `~A' isn't a subclass of `~A' (of `~A')" - class metaclass (sod-class-metaclass super) super)))))) + (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)))))))) ;;;-------------------------------------------------------------------------- ;;; Finalization. -- [mdw]