From 73eceea64f35d47eeecb808cb7bfecb6bac4299b Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Fri, 6 Jul 2018 23:18:01 +0100 Subject: [PATCH] src/: Guess the metaclass early, unless we're explicitly bootstrapping. Otherwise we hit unbound-slot errors if we try to resolve class initializers. Introduce an internal property `%bootstrapping' to tell the class initialization machinery to leave the metaclass slot alone, and use this in `bootstrap-classes'. Otherwise, have the `sod-class' `shared-initialize' method go off and call `guess-metaclass' immediately. Move `guess-metaclass' back into `class-make-impl.lisp' and fix up the documentation stubs. This partially reverts 981b6fb624186a54320cea34e53e16276aee2bdb. --- doc/SYMBOLS | 2 +- doc/meta.tex | 6 +++--- src/builtin.lisp | 6 ++++-- src/class-finalize-impl.lisp | 26 -------------------------- src/class-finalize-proto.lisp | 8 -------- src/class-make-impl.lisp | 32 ++++++++++++++++++++++++++------ src/class-make-proto.lisp | 8 ++++++++ 7 files changed, 42 insertions(+), 46 deletions(-) diff --git a/doc/SYMBOLS b/doc/SYMBOLS index 54a38ff..4edbdd2 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -207,7 +207,6 @@ class-finalize-proto.lisp finalization-error macro finalization-failed function finalize-sod-class generic - guess-metaclass generic class-layout-impl.lisp sod-class-effective-slot class @@ -280,6 +279,7 @@ class-make-impl.lisp class-make-proto.lisp check-message-type generic check-method-type generic + guess-metaclass generic make-sod-class function make-sod-class-initfrag generic make-sod-class-initializer generic diff --git a/doc/meta.tex b/doc/meta.tex index 24a7af8..44d8afd 100644 --- a/doc/meta.tex +++ b/doc/meta.tex @@ -99,6 +99,9 @@ \nlret @} \end{describe} +\begin{describe}{gf}{guess-metaclass @ @> @} +\end{describe} + \begin{describe}{fun} {sod-subclass-p @ @ @> @} \end{describe} @@ -340,9 +343,6 @@ \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/builtin.lisp b/src/builtin.lisp index 7357752..5897da0 100644 --- a/src/builtin.lisp +++ b/src/builtin.lisp @@ -517,9 +517,11 @@ static const SodClass *const ~A__cpl[] = { instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and an instance of itself)." (let* ((sod-object (make-sod-class "SodObject" nil - (make-property-set :nick 'obj))) + (make-property-set :nick 'obj + :%bootstrapping t))) (sod-class (make-sod-class "SodClass" (list sod-object) - (make-property-set :nick 'cls))) + (make-property-set :nick 'cls + :%bootstrapping t))) (classes (list sod-object sod-class))) ;; Attach the built-in messages. diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index 772ad6f..e7fc45a 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -339,27 +339,6 @@ (cdr class-precedence-list))))))))) ;;;-------------------------------------------------------------------------- -;;; Metaclasses. - -(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). - (finalization-error (:bad-metaclass) - (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. (defmethod check-sod-class ((class sod-class)) @@ -579,11 +558,6 @@ ;; clone of the CPL and chain establishment code. If the interface changes ;; then `bootstrap-classes' will need to be changed too. - ;; 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 in that case the diff --git a/src/class-finalize-proto.lisp b/src/class-finalize-proto.lisp index 2f589b8..edd1bad 100644 --- a/src/class-finalize-proto.lisp +++ b/src/class-finalize-proto.lisp @@ -92,14 +92,6 @@ 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 d719cc6..5a897d4 100644 --- a/src/class-make-impl.lisp +++ b/src/class-make-impl.lisp @@ -28,6 +28,16 @@ ;;;-------------------------------------------------------------------------- ;;; Classes. +(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." + + (select-minimal-class-property (sod-class-direct-superclasses class) + #'sod-class-metaclass + #'sod-subclass-p class "metaclass")) + (defmethod shared-initialize :after ((class sod-class) slot-names &key pset) "Specific behaviour for SOD class initialization. @@ -42,18 +52,28 @@ `finalize-sod-class'. * `:link' names the chained superclass. If unspecified, this class will - be left at the head of its chain." + be left at the head of its chain. + + Usually, the class's metaclass is determined here, either direcly from the + `:metaclass' property or by calling `guess-metaclass'. Guessing is + inhibited if the `:%bootstrapping' property is non-nil." ;; If no nickname, copy the class name. It won't be pretty, though. (default-slot-from-property (class 'nickname slot-names) (pset :nick :id) (string-downcase (slot-value class 'name))) - ;; 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))) + ;; Set the metaclass if the appropriate property has been provided or we're + ;; not bootstreapping; otherwise leave it unbound for now, and trust the + ;; caller to sort out the mess. + (multiple-value-bind (meta floc) (get-property pset :metaclass :id) + (cond (floc + (setf (slot-value class 'metaclass) + (with-default-error-location (floc) + (find-sod-class meta)))) + ((not (get-property pset :%bootstrapping :boolean)) + (default-slot (class 'metaclass slot-names) + (guess-metaclass class))))) ;; 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 0e3c5d7..2e1fe7c 100644 --- a/src/class-make-proto.lisp +++ b/src/class-make-proto.lisp @@ -28,6 +28,14 @@ ;;;-------------------------------------------------------------------------- ;;; Classes. +(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 'make-sod-class) (defun make-sod-class (name superclasses pset &optional location) "Construct and return a new SOD class with the given NAME and SUPERCLASSES. -- 2.11.0