From: Mark Wooding Date: Thu, 26 May 2016 08:26:09 +0000 (+0100) Subject: src/class-make-impl.lisp: Don't store `nil' in the `metaclass' slot. X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/commitdiff_plain/981b6fb624186a54320cea34e53e16276aee2bdb?ds=inline;hp=--cc src/class-make-impl.lisp: Don't store `nil' in the `metaclass' slot. Normally we can fill `metaclass' in at construction time, but this is difficult while we're bootstrapping the class graph. Previously, we'd store `nil' in the slot, and expect `bootstrap-classes' to fix things up later; but actually, the `metaclass' slot is declared to hold only `sod-class' objects. Rather than expand the slot type, delay the `guess-metaclass' machinery until class finalization (moving the code across into the relevant source files). --- 981b6fb624186a54320cea34e53e16276aee2bdb diff --git a/doc/SYMBOLS b/doc/SYMBOLS index 6bc3b74..e99d6df 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -151,6 +151,7 @@ class-finalize-proto.lisp compute-chains generic compute-cpl generic finalize-sod-class generic + guess-metaclass generic class-layout-impl.lisp sod-class-effective-slot class @@ -218,7 +219,6 @@ class-make-proto.lisp check-message-type generic check-method-type generic define-sod-class macro - guess-metaclass generic make-sod-class function make-sod-class-initializer generic make-sod-initializer-using-slot generic diff --git a/doc/meta.tex b/doc/meta.tex index 52a89cf..f412e00 100644 --- a/doc/meta.tex +++ b/doc/meta.tex @@ -61,9 +61,6 @@ \dhead{gf}{sod-class-vtables @ @> @}} \end{describe*} -\begin{describe}{gf}{guess-metaclass @ @> @} -\end{describe} - \begin{describe}{fun} {make-sod-class @ @ @ \&optional @ @> @} @@ -256,6 +253,9 @@ \begin{describe}{gf}{compute-chains @ @> @} \end{describe} +\begin{describe}{gf}{guess-metaclass @ @> @} +\end{describe} + \begin{describe}{gf}{check-sod-class @} \end{describe} diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index 25ce1c2..23d7107 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -275,6 +275,35 @@ (defmethod compute-chains ((class sod-class)) (gethash super table)) (cdr class-precedence-list))))))))) +;;;-------------------------------------------------------------------------- +;;; 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. + + Return the most specific metaclass of any of the CLASS's direct + superclasses." + + ;; During bootstrapping, our superclasses might not have their own + ;; 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))) + ;;;-------------------------------------------------------------------------- ;;; Sanity checking. @@ -352,6 +381,11 @@ (defmethod finalize-sod-class ((class sod-class)) ;; If this fails, mark the class as a loss. (setf (slot-value class 'state) :broken) + ;; Set up the metaclass if it's not been set already. This is delayed + ;; to give bootstrapping a chance to set up metaclass and superclass + ;; circularities. + (default-slot (class 'metaclass) (guess-metaclass class)) + ;; Finalize all of the superclasses. There's some special pleading ;; here to make bootstrapping work: we don't try to finalize the ;; metaclass if we're a root class (no direct superclasses -- because diff --git a/src/class-finalize-proto.lisp b/src/class-finalize-proto.lisp index 5bbbd7a..fcb8686 100644 --- a/src/class-finalize-proto.lisp +++ b/src/class-finalize-proto.lisp @@ -52,6 +52,14 @@ (defgeneric compute-chains (class) If the chains are ill-formed (i.e., not distinct) then an error is signalled.")) +(export 'guess-metaclass) +(defgeneric guess-metaclass (class) + (:documentation + "Determine a suitable metaclass for the CLASS. + + The default behaviour is to choose the most specific metaclass of any of + the direct superclasses of CLASS, or to signal an error if that failed.")) + (export 'check-sod-class) (defgeneric check-sod-class (class) (:documentation diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp index 906519b..f7231ef 100644 --- a/src/class-make-impl.lisp +++ b/src/class-make-impl.lisp @@ -28,24 +28,6 @@ (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." - (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. @@ -67,11 +49,11 @@ (default-slot-from-property (class 'nickname slot-names) (pset :nick :id) (string-downcase (slot-value class 'name))) - ;; If no metaclass, guess one in a (Lisp) class-specific way. + ;; Set the metaclass if the appropriate property has been provided; + ;; otherwise leave it unbound for now, and we'll sort out the mess during + ;; finalization. (default-slot-from-property (class 'metaclass slot-names) - (pset :metaclass :id meta (find-sod-class meta)) - (and (sod-class-direct-superclasses class) - (guess-metaclass class))) + (pset :metaclass :id meta (find-sod-class meta))) ;; If no chain-link, then start a new chain here. (default-slot-from-property (class 'chain-link slot-names) diff --git a/src/class-make-proto.lisp b/src/class-make-proto.lisp index df4b4f0..cb12849 100644 --- a/src/class-make-proto.lisp +++ b/src/class-make-proto.lisp @@ -59,14 +59,6 @@ (defun make-sod-class (name superclasses pset &optional location) :pset pset))) class))) -(export 'guess-metaclass) -(defgeneric guess-metaclass (class) - (:documentation - "Determine a suitable metaclass for the CLASS. - - The default behaviour is to choose the most specific metaclass of any of - the direct superclasses of CLASS, or to signal an error if that failed.")) - ;;;-------------------------------------------------------------------------- ;;; Slots and slot initializers.