src/{class-,}utilities.lisp: Add machinery for showing inheritance paths.

[sod] / src / class-utilities.lisp

diff --git a/src/class-utilities.lisp b/src/class-utilities.lisp
index 573c677..35c6d17 100644 (file)
--- a/src/class-utilities.lisp
+++ b/src/class-utilities.lisp
@@ -66,6 +66,46 @@
                          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.
 
 (export 'sod-subclass-p)