From: Mark Wooding <mdw@distorted.org.uk>
Date: Sun, 30 Aug 2015 09:58:38 +0000 (+0100)
Subject: src/class-make-impl.lisp: Abstract out the guts of `guess-metaclass'.
X-Git-Url: https://git.distorted.org.uk/~mdw/sod/commitdiff_plain/f95caf08eea8939e1cadee0cbd8fd7daa1039124

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 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)