It lives!

[sod] / class-layout.lisp

diff --git a/class-layout.lisp b/class-layout.lisp
index a37852ed365a955a9bef5ee4fddbdce62264adc3..877073992c31175a344f14b1ebc782f64d846063 100644 (file)
--- a/class-layout.lisp
+++ b/class-layout.lisp
@@ -232,12 +232,11 @@ (defgeneric compute-sod-effective-method (message class)
 
 (defmethod compute-sod-effective-method
     ((message sod-message) (class sod-class))
 
 (defmethod compute-sod-effective-method
     ((message sod-message) (class sod-class))

-  (let ((direct-methods (mapcan (lambda (super)
-                                 (let ((method
-                                        (find message
-                                              (sod-class-methods super)
-                                              :key #'sod-method-message)))
-                                   (and method (list method))))
+  (let ((direct-methods (mappend (lambda (super)
+                                  (remove message
+                                          (sod-class-methods super)
+                                          :key #'sod-method-message
+                                          :test-not #'eql))

                                (sod-class-precedence-list class))))
     (make-instance (message-effective-method-class message)
                   :message message
                                (sod-class-precedence-list class))))
     (make-instance (message-effective-method-class message)
                   :message message


@@ -549,10 +548,14 @@ (defun find-root-superclass (class)
   ;; is harmless.
   (let* ((supers (sod-class-direct-superclasses class))
         (roots (if supers
   ;; is harmless.
   (let* ((supers (sod-class-direct-superclasses class))
         (roots (if supers

-                   (remove-if #'sod-class-direct-superclasses
-                              (mapcar (lambda (super)
-                                        (sod-class-chain-head super))
-                                      supers))
+                   (remove-duplicates
+                    (remove-if #'sod-class-direct-superclasses
+                               (mappend (lambda (super)
+                                          (mapcar (lambda (chain)
+                                                    (sod-class-chain-head
+                                                     (car chain)))
+                                                  (sod-class-chains super)))
+                                        supers)))

                    (list class))))
     (cond ((null roots) (error "Class ~A has no root class!" class))
          ((cdr roots) (error "Class ~A has multiple root classes ~
                    (list class))))
     (cond ((null roots) (error "Class ~A has no root class!" class))
          ((cdr roots) (error "Class ~A has multiple root classes ~