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

It's mostly trying to pick out a maximum value from a partially ordered
set.  This is a useful primitive, so factor it out.

This also exposes a hack in the previous `guess-metaclass'
implementation.  It would, somewhat sneakily, manage to return nil if
given an empty superclass list, which is ideal for the builtin module,
which hasn't built the metaclass yet and must fill it in later.  Leave
this hack in, but make it more explicit.

diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp
index 878f813d32d0cc6bb74b2a13f083493e86d78153..29a30c1efbaad172ccd2892ca8ac76972951b822 100644 (file)
--- a/src/class-make-impl.lisp
+++ b/src/class-make-impl.lisp
@@ -28,19 +28,23 @@ (cl:in-package #:sod)
 ;;;--------------------------------------------------------------------------
 ;;; 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 @@   (default-slot-from-property (class 'nickname slot-names)
   ;; 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)