;;;--------------------------------------------------------------------------
;;; 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.
;; 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.
;;;--------------------------------------------------------------------------
;;; Finalization.
-(defmethod finalize-sod-class ((class sod-class))
+(defmethod finalize-sod-class :around ((class sod-class))
+ "Common functionality for `finalize-sod-class'.
- ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
- ;; clone of the CPL and chain establishment code. If the interface changes
- ;; then `bootstrap-classes' will need to be changed too.
+ * If an attempt to finalize the CLASS has been made before, then we
+ don't try again. Similarly, attempts to finalize a class recursively
+ will fail.
+ * A condition handler is established to keep track of whether any errors
+ are signalled during finalization. The CLASS is only marked as
+ successfully finalized if no (unhandled) errors are encountered."
(with-default-error-location (class)
(ecase (sod-class-state class)
((nil)
- ;; If this fails, mark the class as a loss.
+ ;; If this fails, leave the class marked 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
- ;; in that case the metaclass will have to be a subclass of us!), or
- ;; if it's equal to us. This is enough to tie the knot at the top of
- ;; the class graph.
- (with-slots (name direct-superclasses metaclass) class
- (dolist (super direct-superclasses)
- (finalize-sod-class super))
- (unless (or (null direct-superclasses)
- (eq class metaclass))
- (finalize-sod-class metaclass)))
-
- ;; Stash the class's type.
- (setf (slot-value class '%type)
- (make-class-type (sod-class-name class)))
-
- ;; Clobber the lists of items if they've not been set.
- (dolist (slot '(slots instance-initializers class-initializers
- messages methods))
- (unless (slot-boundp class slot)
- (setf (slot-value class slot) nil)))
-
- ;; If the CPL hasn't been done yet, compute it.
- (with-slots (class-precedence-list) class
- (unless (slot-boundp class 'class-precedence-list)
- (setf class-precedence-list (compute-cpl class))))
-
- ;; Check that the class is fairly sane.
- (check-sod-class class)
-
- ;; Determine the class's layout.
- (with-slots (chain-head chain chains) class
- (setf (values chain-head chain chains) (compute-chains class)))
-
- ;; Done.
+ ;; Invoke the finalization method proper.
+ (call-next-method)
(setf (slot-value class 'state) :finalized)
t)
+ ;; If the class is broken, we're not going to be able to fix it now.
(:broken
nil)
+ ;; If we already finalized it, there's no point doing it again.
(:finalized
t))))
-(flet ((check-class-is-finalized (class)
- (unless (eq (sod-class-state class) :finalized)
- (error "Class ~S is not finalized" class))))
- (macrolet ((define-layout-slot (slot (class) &body body)
- `(define-on-demand-slot sod-class ,slot (,class)
- (check-class-is-finalized ,class)
- ,@body)))
- (define-layout-slot %ilayout (class)
- (compute-ilayout class))
- (define-layout-slot effective-methods (class)
- (compute-effective-methods class))
- (define-layout-slot vtables (class)
- (compute-vtables class))))
+(defmethod finalize-sod-class ((class sod-class))
+
+ ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
+ ;; 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
+ ;; metaclass will have to be a subclass of us!), or if it's equal to us.
+ ;; This is enough to tie the knot at the top of the class graph.
+ (with-slots (name direct-superclasses metaclass) class
+ (dolist (super direct-superclasses)
+ (finalize-sod-class super))
+ (unless (or (null direct-superclasses)
+ (eq class metaclass))
+ (finalize-sod-class metaclass)))
+
+ ;; Stash the class's type.
+ (setf (slot-value class '%type)
+ (make-class-type (sod-class-name class)))
+
+ ;; Clobber the lists of items if they've not been set.
+ (dolist (slot '(slots instance-initializers class-initializers
+ messages methods))
+ (unless (slot-boundp class slot)
+ (setf (slot-value class slot) nil)))
+
+ ;; If the CPL hasn't been done yet, compute it.
+ (with-slots (class-precedence-list) class
+ (unless (slot-boundp class 'class-precedence-list)
+ (setf class-precedence-list (compute-cpl class))))
+
+ ;; Check that the class is fairly sane.
+ (check-sod-class class)
+
+ ;; Determine the class's layout.
+ (setf (values (slot-value class 'chain-head)
+ (slot-value class 'chain)
+ (slot-value class 'chains))
+ (compute-chains class)))
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff