src/class-make-impl.lisp: Abstract out the guts of `guess-metaclass'.

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

diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp
index 878f813..29a30c1 100644 (file)
--- 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)