From 17c7c784e0632dff2f93a69a837585fd6f31f4a1 Mon Sep 17 00:00:00 2001 Message-Id: <17c7c784e0632dff2f93a69a837585fd6f31f4a1.1715359655.git.mdw@distorted.org.uk> From: Mark Wooding Date: Sat, 25 Mar 2017 20:59:40 +0000 Subject: [PATCH] src/{class-,}utilities.lisp: Add machinery for showing inheritance paths. Organization: Straylight/Edgeware From: Mark Wooding To the general utilities collection, we add an implementation of Dijkstra's distinguished-point shortest-path algorithm. To the class utilities, we add a new type and function for reporting inheritance paths, with the notion that this will be useful when debugging problems where classes turn out to be incompatible with each other for various reasons. --- doc/SYMBOLS | 5 +++ doc/meta.tex | 9 +++++ doc/misc.tex | 5 +++ src/class-utilities.lisp | 40 ++++++++++++++++++ src/utilities.lisp | 87 ++++++++++++++++++++++++++++++++++++++++ 5 files changed, 146 insertions(+) diff --git a/doc/SYMBOLS b/doc/SYMBOLS index 4bbe9ac..5e076c5 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -307,8 +307,11 @@ class-utilities.lisp ichain-struct-tag function ichain-union-tag function ilayout-struct-tag function + inheritance-path-reporter-state class islots-struct-tag function + make-inheritance-path-reporter-state function message-macro-name function + report-inheritance-path function sod-subclass-p function valid-name-p function vtable-name function @@ -671,6 +674,7 @@ cl:t sod-class-effective-slot ichain ilayout + inheritance-path-reporter-state inst banner-inst block-inst @@ -2221,6 +2225,7 @@ utilities.lisp define-on-demand-slot macro defvar-unbound macro designated-condition function + distinguished-point-shortest-paths function dosequence macro sb-mop:eql-specializer class sb-mop:eql-specializer-object generic diff --git a/doc/meta.tex b/doc/meta.tex index 7de1fbe..25bed34 100644 --- a/doc/meta.tex +++ b/doc/meta.tex @@ -83,6 +83,15 @@ {find-superclass-by-nick @ @ @> @} \end{describe} +\begin{describe}{ty}{inheritance-path-reporter-state} +\end{describe} + +\begin{describe}{fun}{make-inheritance-path-reporter-state @> @} +\end{describe} + +\begin{describe}{fun}{report-inheritance-path @ @} +\end{describe} + \begin{describe}{fun} {sod-subclass-p @ @ @> @} \end{describe} diff --git a/doc/misc.tex b/doc/misc.tex index 5ef4d1f..5767c3e 100644 --- a/doc/misc.tex +++ b/doc/misc.tex @@ -129,6 +129,11 @@ These symbols are defined in the @|sod-utilities| package. {mappend @ @ \&rest @ @> @} \end{describe} +\begin{describe}{fun} + {distinguished-point-shortest-paths @ @ + @> @} +\end{describe} + \begin{describe}{cls}{inconsistent-merge-error (error) \&key :candidates} \end{describe} diff --git a/src/class-utilities.lisp b/src/class-utilities.lisp index 573c677..35c6d17 100644 --- a/src/class-utilities.lisp +++ b/src/class-utilities.lisp @@ -65,6 +65,46 @@ (defun find-message-by-name (class super-nick message-name) (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. diff --git a/src/utilities.lisp b/src/utilities.lisp index 38bb746..0415a90 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -439,6 +439,93 @@ (defun mappend (function list &rest more-lists) 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]