X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/8e36de0e30786727d872f21bf10eb7a579f15dd6..f95caf08eea8939e1cadee0cbd8fd7daa1039124:/src/class-make-impl.lisp

diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp
index 878f813..29a30c1 100644
--- a/src/class-make-impl.lisp
+++ b/src/class-make-impl.lisp
@@ -28,19 +28,23 @@
 ;;;--------------------------------------------------------------------------
 ;;; Classes.
 
+(defun maximum (items order what)
+  "Return a maximum item according to the non-strict partial ORDER."
+  (reduce (lambda (best this)
+	    (cond ((funcall order best this) best)
+		  ((funcall order this best) this)
+		  (t (error "Unable to choose best ~A." what))))
+	  items))
+
 (defmethod guess-metaclass ((class sod-class))
   "Default metaclass-guessing function for classes.
 
    Return the most specific metaclass of any of the CLASS's direct
    superclasses."
-  (do ((supers (sod-class-direct-superclasses class) (cdr supers))
-       (meta nil (let ((candidate (sod-class-metaclass (car supers))))
-		   (cond ((null meta) candidate)
-			 ((sod-subclass-p meta candidate) meta)
-			 ((sod-subclass-p candidate meta) candidate)
-			 (t (error "Unable to choose metaclass for `~A'"
-				   class))))))
-      ((endp supers) meta)))
+  (maximum (mapcar #'sod-class-metaclass
+		   (sod-class-direct-superclasses class))
+	   #'sod-subclass-p
+	   (format nil "metaclass for `~A'" class)))
 
 (defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
   "Specific behaviour for SOD class initialization.
@@ -66,7 +70,8 @@
   ;; If no metaclass, guess one in a (Lisp) class-specific way.
   (default-slot-from-property (class 'metaclass slot-names)
       (pset :metaclass :id meta (find-sod-class meta))
-    (guess-metaclass class))
+    (and (sod-class-direct-superclasses class)
+	 (guess-metaclass class)))
 
   ;; If no chain-link, then start a new chain here.
   (default-slot-from-property (class 'chain-link slot-names)