finalization-error macro
finalization-failed function
finalize-sod-class generic
- guess-metaclass generic
class-layout-impl.lisp
sod-class-effective-slot class
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
\nlret @<object>}
\end{describe}
+\begin{describe}{gf}{guess-metaclass @<class> @> @<metaclass>}
+\end{describe}
+
\begin{describe}{fun}
{sod-subclass-p @<class-a> @<class-b> @> @<generalized-boolean>}
\end{describe}
\begin{describe}{gf}{compute-chains @<class> @> @<list>}
\end{describe}
-\begin{describe}{gf}{guess-metaclass @<class> @> @<metaclass>}
-\end{describe}
-
\begin{describe}{gf}{check-sod-class @<class>}
\end{describe}
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.
(gethash super table))
(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.
;; 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
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
;;;--------------------------------------------------------------------------
;;; 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.
`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)
;;;--------------------------------------------------------------------------
;;; 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.
~mdw / sod / commitdiff