doc/list-exports: Use `documentation' to find more categories.

[sod] / src / class-finalize-impl.lisp

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index 6401318..895b3c9 100644 (file)
--- 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."
 
    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))))
     (dolist (candidate candidates)
       (when (member candidate (sod-class-direct-superclasses class))
        (return-from clos-tiebreaker candidate))))


@@ -341,6 +341,26 @@
 ;;;--------------------------------------------------------------------------
 ;;; Sanity checking.
 
 ;;;--------------------------------------------------------------------------
 ;;; 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))
 
   ;; Check the names of things are valid.
 (defmethod check-sod-class ((class sod-class))
 
   ;; Check the names of things are valid.


@@ -360,14 +380,7 @@
     (check-list (sod-class-slots class) "slot" #'sod-slot-name))
 
   ;; Check that the class doesn't define conflicting things.
     (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)
+  (labels ((simple-previous (previous)

             (info-with-location previous "Previous definition was here"))
           (simple-complain (what namefunc)
             (lambda (item previous)
             (info-with-location previous "Previous definition was here"))
           (simple-complain (what namefunc)
             (lambda (item previous)


@@ -377,60 +390,70 @@
               (simple-previous previous))))
 
     ;; Make sure direct slots have distinct names.
               (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))
+    (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)
 
     ;; 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))))))
+            (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.
       (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))
+    (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.
 
     ;; 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)))
+    (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)))
 
     ;; 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)))))
+      (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))))
 
   ;; 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"
+      (cerror* "In `~A', chain-to class `~A' is not a proper superclass"

               class link)))
 
   ;; Check that the initargs declare compatible types.  Duplicate entries,
               class link)))
 
   ;; Check that the initargs declare compatible types.  Duplicate entries,


@@ -494,7 +517,29 @@
            (info-with-location super
                                "Direct superclass `~A' defined here ~
                                 has metaclass `~A'"
            (info-with-location super
                                "Direct superclass `~A' defined here ~
                                 has metaclass `~A'"

-                               super supermeta)))))))
+                               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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Finalization.