(find-thing-by-name "message" super (sod-class-messages super)
message-name #'sod-message-name))))
+;;;--------------------------------------------------------------------------
+;;; Describing class inheritance paths in diagnostics.
+
+(export 'inheritance-path-reporter-state)
+(defclass inheritance-path-reporter-state ()
+ ((%class :type sod-class :initarg :class)
+ (paths :type list :initarg :paths)
+ (seen :type hash-table :initform (make-hash-table))))
+
+(export 'make-inheritance-path-reporter-state)
+(defun make-inheritance-path-reporter-state (class)
+ (make-instance 'inheritance-path-reporter-state :class class))
+
+(export 'report-inheritance-path)
+(defun report-inheritance-path (state super)
+ "Issue informational messages showing how CLASS inherits from SUPER."
+ (with-slots (paths (class %class) include-boundary seen) state
+ (unless (slot-boundp state 'paths)
+ (setf paths (distinguished-point-shortest-paths
+ class
+ (lambda (c)
+ (mapcar (lambda (super) (cons super 1))
+ (sod-class-direct-superclasses c))))))
+ (dolist (hop (mapcon (lambda (subpath)
+ (let ((super (car subpath))
+ (sub (and (cdr subpath)
+ (cadr subpath))))
+ (if (or (not sub) (gethash super seen))
+ nil
+ (progn
+ (setf (gethash super seen) t)
+ (list (cons super sub))))))
+ (cdr (find super paths :key #'cadr))))
+ (let ((super (car hop))
+ (sub (cdr hop)))
+ (info-with-location sub
+ "Class `~A' is a direct superclass ~
+ of `~A', defined here"
+ super sub)))))
+
;;;--------------------------------------------------------------------------
;;; Miscellaneous useful functions.
and return the result of appending all of the resulting lists."
(reduce #'append (apply #'mapcar function list more-lists) :from-end t))
+(export 'distinguished-point-shortest-paths)
+(defun distinguished-point-shortest-paths (root neighbours-func)
+ "Moderately efficient shortest-paths-from-root computation.
+
+ The ROOT is a distinguished vertex in a graph. The NEIGHBOURS-FUNC
+ accepts a VERTEX as its only argument, and returns a list of conses (V .
+ C) for each of the VERTEX's neighbours, indicating that there is an edge
+ from VERTEX to V, with cost C.
+
+ The return value is a list of entries (COST . REV-PATH) for each vertex
+ reachable from the ROOT; the COST is the total cost of the shortest path,
+ and REV-PATH is the path from the ROOT, in reverse order -- so the first
+ element is the vertex itself and the last element is the ROOT.
+
+ The NEIGHBOURS-FUNC is called at most N times, and may take O(N) time to
+ produce its output list. The computation as a whole takes O(N^2) time,
+ where N is the number of vertices in the graph, assuming there is at most
+ one edge between any pair of vertices."
+
+ ;; This is a listish version of Dijkstra's shortest-path algorithm. It
+ ;; could be made more efficient by using a fancy priority queue rather than
+ ;; a linear search for finding the nearest live element (see below), but it
+ ;; still runs pretty well.
+
+ (let ((map (make-hash-table))
+ (dead nil)
+ (live (list (list 0 root))))
+ (setf (gethash root map) (cons :live (car live)))
+ (loop
+ ;; The dead list contains a record, in output format (COST . PATH), for
+ ;; each vertex whose shortest path has been finally decided. The live
+ ;; list contains a record for the vertices of current interest, also in
+ ;; output format; the COST for a live record shows the best cost for a
+ ;; path using only dead vertices.
+ ;;
+ ;; Each time through here, we pull an item off the live list and
+ ;; push it onto the dead list, so we do at most N iterations total.
+
+ ;; If there are no more live items, then we're done; the remaining
+ ;; vertices, if any, are unreachable from the ROOT.
+ (when (null live) (return))
+
+ ;; Find the closest live vertex to the root. The linear scan through
+ ;; the live list costs at most N time.
+ (let* ((best (reduce (lambda (x y) (if (< (car x) (car y)) x y)) live))
+ (best-cost (car best))
+ (best-path (cdr best))
+ (best-vertex (car best-path)))
+
+ ;; Remove the chosen vertex from the LIVE list, and add the
+ ;; appropriate record to the dead list. We must have the shortest
+ ;; path to this vertex now: we have the shortest path using currently
+ ;; dead vertices; any other path must use at least one live vertex,
+ ;; and, by construction, the path through any such vertex must be
+ ;; further than the path we already have.
+ ;;
+ ;; Removal from the live list uses a linear scan which costs N time.
+ (setf live (delete best live))
+ (push best dead)
+ (setf (car (gethash best-vertex map)) :dead)
+
+ ;; Work through the chosen vertex's neighbours, adding each of them
+ ;; to the live list if they're not already there. If a neighbour is
+ ;; already live, and we find a shorter path to it through our chosen
+ ;; vertex, then update the neighbour's record.
+ ;;
+ ;; The chosen vertex obviously has at most N neighbours. There's no
+ ;; more looping in here, so performance is as claimed.
+ (dolist (neigh (funcall neighbours-func best-vertex))
+ (let* ((neigh-vertex (car neigh))
+ (neigh-cost (+ best-cost (cdr neigh)))
+ (neigh-record (gethash neigh-vertex map)))
+ (cond ((null neigh-record)
+ ;; If the neighbour isn't known, then now's the time to
+ ;; make a fresh live record for it.
+ (let ((new-record (list* :live neigh-cost
+ neigh-vertex best-path)))
+ (push (cdr new-record) live)
+ (setf (gethash neigh-vertex map) new-record)))
+ ((and (eq (car neigh-record) :live)
+ (< neigh-cost (cadr neigh-record)))
+ ;; If the neighbour is live, and we've found a better path
+ ;; to it, then update its record.
+ (setf (cadr neigh-record) neigh-cost
+ (cdddr neigh-record) best-path)))))))
+ dead))
+
(export '(inconsistent-merge-error merge-error-candidates))
(define-condition inconsistent-merge-error (error)
((candidates :initarg :candidates
~mdw / sod / commitdiff