;;; 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 (lists pick)
- "Merge the LISTS of classes, using PICK to break ties.
+(defun merge-class-lists (class lists pick)
+ "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."
- (merge-lists lists :pick pick))
+ 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)
+ (report-class-list-merge-error class lists error)
+ (continue error))))
;;; Tiebreaker functions.
direct subclass then that subclass's direct superclasses list must order
them relative to each other."
- (let (winner)
- (dolist (class so-far)
- (dolist (candidate candidates)
- (when (member candidate (sod-class-direct-superclasses class))
- (setf winner candidate))))
- (unless winner
- (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))
- winner))
+ (dolist (class so-far)
+ (dolist (candidate candidates)
+ (when (member candidate (sod-class-direct-superclasses class))
+ (return-from clos-tiebreaker candidate))))
+ (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))
(defun c3-tiebreaker (candidates cpls)
"The C3 linearization tiebreaker function.
(remove-duplicates (cons class
(mappend #'superclasses
direct-supers))))))
- (merge-class-lists
- (mapcar (lambda (class)
- (cons class (sod-class-direct-superclasses class)))
- (superclasses class))
- #'clos-tiebreaker)))
+ (merge-class-lists class
+ (mapcar (lambda (c)
+ (cons c (sod-class-direct-superclasses c)))
+ (superclasses class))
+ #'clos-tiebreaker)))
(export 'dylan-cpl)
(defun dylan-cpl (class)
assuming that the superclass CPLs are already monotonic. If they aren't,
you're going to lose anyway."
- (let ((direct-supers (sod-class-direct-superclasses class)))
- (merge-class-lists
- (cons (cons class direct-supers)
- (mapcar #'sod-class-precedence-list direct-supers))
- #'clos-tiebreaker)))
+ (let* ((direct-supers (sod-class-direct-superclasses class))
+ (cpls (mapcar #'sod-class-precedence-list direct-supers)))
+ (merge-class-lists class
+ (cons (cons class direct-supers) cpls)
+ #'clos-tiebreaker)))
(export 'c3-cpl)
(defun c3-cpl (class)
(let* ((direct-supers (sod-class-direct-superclasses class))
(cpls (mapcar #'sod-class-precedence-list direct-supers)))
- (merge-class-lists (cons (cons class direct-supers) cpls)
+ (merge-class-lists class
+ (cons (cons class direct-supers) cpls)
(lambda (candidates so-far)
(declare (ignore so-far))
(c3-tiebreaker candidates cpls)))))
(let ((dfs (flavors-cpl class)))
(cons class
- (merge-class-lists (mapcar #'sod-class-precedence-list
+ (merge-class-lists class
+ (mapcar #'sod-class-precedence-list
(sod-class-direct-superclasses class))
(lambda (candidates so-far)
(declare (ignore so-far))
;;; Default function.
(defmethod compute-cpl ((class sod-class))
- (handler-case (c3-cpl class)
- (inconsistent-merge-error ()
- (error "Failed to compute class precedence list for `~A'"
- (sod-class-name class)))))
+ (c3-cpl class))
;;;--------------------------------------------------------------------------
;;; Chains.
~mdw / sod / blobdiff