From f95caf08eea8939e1cadee0cbd8fd7daa1039124 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 30 Aug 2015 10:58:38 +0100 Subject: [PATCH] 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. --- src/class-make-impl.lisp | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) 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) -- 2.11.0