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))))
;;;--------------------------------------------------------------------------
;;; 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.
~mdw / sod / blobdiff