;;; Utilities.
+(export 'report-class-list-merge-error)
+(defun report-class-list-merge-error (class lists error)
+ "Report a failure to merge superclasseses.
+
+ Here, CLASS is the class whose class precedence list we're trying to
+ compute; the LISTS are the individual superclass orderings being merged;
+ and ERROR is an `inconsistent-merge-error' describing the problem that was
+ encountered.
+
+ Each of the LISTS is assumed to begin with the class from which the
+ corresponding constraint originates; see `merge-class-lists'."
+
+ (let* ((state (make-inheritance-path-reporter-state class))
+ (candidates (merge-error-candidates error))
+ (focus (remove-duplicates
+ (remove nil
+ (mapcar (lambda (list)
+ (cons (car list)
+ (remove-if-not
+ (lambda (item)
+ (member item candidates))
+ list)))
+ lists)
+ :key #'cddr)
+ :test #'equal :key #'cdr)))
+
+ (cerror*-with-location class "Ill-formed superclass graph: ~
+ can't construct class precedence list ~
+ for `~A'"
+ class)
+ (dolist (offenders focus)
+ (let ((super (car offenders)))
+ (info-with-location super
+ "~{Class `~A' orders `~A' before ~
+ ~#[<BUG>~;`~A'~;`~A' and `~A'~:;~
+ ~@{`~A', ~#[~;and `~A'~]~}~]~}"
+ offenders)
+ (report-inheritance-path state super)))))
+
(export 'merge-class-lists)
(defun merge-class-lists (class lists pick)
- "Merge the LISTS of subclasses of CLASS, using PICK to break ties.
+ "Merge the LISTS of superclasses of CLASS, using PICK to break ties.
This is a convenience wrapper around the main `merge-lists' function.
Given that class linearizations (almost?) always specify a custom
- tiebreaker function, this isn't a keyword argument."
+ tiebreaker function, this isn't a keyword argument.
+
+ If a merge error occurs, this function translates it into a rather more
+ useful form, and tries to provide helpful notes.
+
+ For error reporting purposes, it's assumed that each of the LISTS begins
+ with the class from which the corresponding constraint originates. This
+ initial class does double-duty: it is also considered to be part of the
+ list for the purpose of the merge."
+
(handler-case (merge-lists lists :pick pick)
- (inconsistent-merge-error ()
- (error "Failed to compute class precedence list for `~A'"
- (sod-class-name class)))))
+ (inconsistent-merge-error (error)
+ (report-class-list-merge-error class lists error)
+ (continue error))))
;;; Tiebreaker functions.
(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
~mdw / sod / blobdiff