From af74ab812b5280fdd0aa5a13537c7168bdfeb051 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 6 Jun 2019 22:25:29 -0700
Subject: [PATCH] Modify CREF to show references to inherited bindings.

This will help track down which parts of the string abstraction need to be
replaced.
---
 src/cref/forpkg.scm | 15 +++++++++++++++
 src/cref/object.scm |  6 ++++++
 2 files changed, 21 insertions(+)

diff --git a/src/cref/forpkg.scm b/src/cref/forpkg.scm
index 7f1b6c19c..865ff5228 100644
--- a/src/cref/forpkg.scm
+++ b/src/cref/forpkg.scm
@@ -106,6 +106,7 @@ USA.
     (let ((class (assq package classes)))
       (if class
 	  (format-package/bindings port indentation width package (cdr class)))
+      (format-package/inherited port indentation width package)
       (for-each (lambda (class)
 		  (if (not (eq? package (car class)))
 		      (format-package/imports port indentation width package
@@ -197,6 +198,20 @@ USA.
 			  ")")
 	   name)))))
 
+(define (format-package/inherited port indentation width package)
+  (let ((inherited
+         (filter (lambda (reference)
+                   (let ((binding (reference/binding reference)))
+                     (and binding
+                          (ancestor-package? (binding/package binding)
+                                             package))))
+                 (package/references package))))
+    (if (pair? inherited)
+        (begin
+          (newline port)
+          (format-references port indentation width "Inherited" package
+                             (sort inherited reference<?))))))
+
 (define (format-package/imports port indentation width local-package
 				remote-package bindings)
   (format-exports port indentation width local-package remote-package bindings
diff --git a/src/cref/object.scm b/src/cref/object.scm
index d37996f49..c2fed00d5 100644
--- a/src/cref/object.scm
+++ b/src/cref/object.scm
@@ -87,6 +87,12 @@ USA.
   (set-package/bindings! package
 			 (cons binding (package/bindings package))))
 
+(define (ancestor-package? p1 p2)
+  (let ((parent (package/parent p2)))
+    (and parent
+         (or (eq? p1 parent)
+             (ancestor-package? p1 parent)))))
+
 (define-integrable (file-case/type file-case)
   (car file-case))
 
-- 
2.25.1