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 f9d5734..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)
@@ -172,7 +177,7 @@
 (defmethod shared-initialize :after
     ((message sod-message) slot-names &key pset)
   (declare (ignore slot-names pset))
-  (with-slots (type) message
+  (with-slots ((type %type)) message
     (check-message-type message type)))
 
 (defmethod check-message-type ((message sod-message) (type c-function-type))
@@ -216,7 +221,7 @@
   (declare (ignore slot-names pset))
 
   ;; Check that the arguments are named if we have a method body.
-  (with-slots (body type) method
+  (with-slots (body (type %type)) method
     (unless (or (not body)
                (every (lambda (arg)
                         (or (eq arg :ellipsis)
@@ -226,7 +231,7 @@
       (error "Abstract declarators not permitted in method definitions")))
 
   ;; Check the method type.
-  (with-slots (message type) method
+  (with-slots (message (type %type)) method
     (check-method-type method message type)))
 
 (defmethod check-method-type
@@ -235,7 +240,7 @@
 
 (defmethod check-method-type
     ((method sod-method) (message sod-message) (type c-function-type))
-  (with-slots ((msgtype type)) message
+  (with-slots ((msgtype %type)) message
     (unless (c-type-equal-p (c-type-subtype msgtype)
                            (c-type-subtype type))
       (error "Method return type ~A doesn't match message ~A"