From 6e92afa75860a55640efa6f3ba39f9624b41e8a8 Mon Sep 17 00:00:00 2001 Message-Id: <6e92afa75860a55640efa6f3ba39f9624b41e8a8.1715484716.git.mdw@distorted.org.uk> From: Mark Wooding Date: Sun, 26 Mar 2017 14:41:40 +0100 Subject: [PATCH] src/class-*.lisp: Improve metaclass selection. Organization: Straylight/Edgeware From: Mark Wooding Replace the slightly wobbly (and poorly named) `maximum' function (in `class-finalize-impl.lisp') with the much more capable `select-minimal-class-property' (in `class-utilities.lisp'). Use this new function as appropriate. --- doc/SYMBOLS | 1 + doc/meta.tex | 7 ++++++ src/class-finalize-impl.lisp | 21 +++++------------ src/class-make-proto.lisp | 13 ++++++----- src/class-utilities.lisp | 45 ++++++++++++++++++++++++++++++++++++ 5 files changed, 66 insertions(+), 21 deletions(-) diff --git a/doc/SYMBOLS b/doc/SYMBOLS index f78c310..17eb597 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -312,6 +312,7 @@ class-utilities.lisp make-inheritance-path-reporter-state function message-macro-name function report-inheritance-path function + select-minimal-class-property function sod-subclass-p function valid-name-p function vtable-name function diff --git a/doc/meta.tex b/doc/meta.tex index 92fac6d..2523642 100644 --- a/doc/meta.tex +++ b/doc/meta.tex @@ -92,6 +92,13 @@ \begin{describe}{fun}{report-inheritance-path @ @} \end{describe} +\begin{describe}{fun} + {select-minimal-class-property + \=@ @ @ @ @ \\ + \>\&key :present :allow-empty + \nlret @} +\end{describe} + \begin{describe}{fun} {sod-subclass-p @ @ @> @} \end{describe} diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index 32bc29b..d5dd60d 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -296,14 +296,6 @@ (defmethod compute-chains ((class sod-class)) ;;;-------------------------------------------------------------------------- ;;; Metaclasses. -(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. @@ -314,13 +306,12 @@ (defmethod guess-metaclass ((class sod-class)) ;; metaclasses resolved yet. If we find this, then throw `bootstrapping' ;; so that `shared-initialize' on `sod-class' can catch it (or as a shot ;; across the bows of anyone else who calls us). - (maximum (mapcar (lambda (super) - (if (slot-boundp super 'metaclass) - (slot-value super 'metaclass) - (throw 'bootstrapping nil))) - (sod-class-direct-superclasses class)) - #'sod-subclass-p - (format nil "metaclass for `~A'" class))) + (select-minimal-class-property (sod-class-direct-superclasses class) + (lambda (super) + (if (slot-boundp super 'metaclass) + (slot-value super 'metaclass) + (throw 'bootstrapping nil))) + #'sod-subclass-p class "metaclass")) ;;;-------------------------------------------------------------------------- ;;; Sanity checking. diff --git a/src/class-make-proto.lisp b/src/class-make-proto.lisp index d075304..0e3c5d7 100644 --- a/src/class-make-proto.lisp +++ b/src/class-make-proto.lisp @@ -46,12 +46,13 @@ (defun make-sod-class (name superclasses pset &optional location) (with-default-error-location (location) (let* ((pset (property-set pset)) (best-class (or (get-property pset :lisp-metaclass :symbol nil) - (if superclasses - (maximum (mapcar #'class-of superclasses) - #'subtypep - (format nil "Lisp metaclass for ~A" - name)) - 'sod-class))) + (select-minimal-class-property + superclasses #'class-of #'subtypep 'sod-class + "Lisp metaclass" + :present (lambda (class) + (format nil "`~S'" + (class-name class))) + :allow-empty t))) (class (make-instance best-class :name name :superclasses superclasses diff --git a/src/class-utilities.lisp b/src/class-utilities.lisp index 35c6d17..38cb75e 100644 --- a/src/class-utilities.lisp +++ b/src/class-utilities.lisp @@ -105,6 +105,51 @@ (defun report-inheritance-path (state super) of `~A', defined here" super sub))))) +;;;-------------------------------------------------------------------------- +;;; Metaclass inference. + +(export 'select-minimal-class-property) +(defun select-minimal-class-property (supers key order default what + &key (present (lambda (x) + (format nil "`~A'" x))) + allow-empty) + "Return the minimal partially-ordered key from the SUPERS. + + KEY is a function of one argument which returns some interesting property + of a class. The keys are assumed to be partially ordered by ORDER, a + function of two arguments which returns non-nil if its first argument + precedes its second. If there is a unique minimal key then return it; + otherwise report a useful error and pick some candidate in an arbitrary + way; the DEFAULT may be chosen if no better choices are available. If + ALLOW-EMPTY is non-nil, then no error is reported if there are no SUPERS, + and the DEFAULT choice is returned immediately. + + In an error message, the keys are described as WHAT, which should be a + noun phrase; keys are filtered through PRESENT, a function of one + argument, before presentation. + + The function returns two values: the chosen value, and a flag which is + non-nil if it was chosen without errors." + + (let ((candidates (partial-order-minima (mapcar key supers) order))) + (cond ((and (null candidates) allow-empty) + (values default t)) + ((and candidates (null (cdr candidates))) + (values (car candidates) t)) + (t + (cerror* "No obvious choice for implicit ~A: ~ + ~{~#[root classes must specify explicitly~:;~ + candidates are ~ + ~#[~;~A~;~A and ~A~:;~@{~A, ~#[~;and ~A~]~}~]~]~:}" + what (mapcar present candidates)) + (dolist (candidate candidates) + (let ((super (find candidate supers :key key))) + (info-with-location super + "Direct superclass `~A' defined here ~ + has ~A ~A" + super what (funcall present candidate)))) + (values (if candidates (car candidates) default) nil))))) + ;;;-------------------------------------------------------------------------- ;;; Miscellaneous useful functions. -- [mdw]