From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 7 Jun 2019 05:25:29 +0000 (-0700)
Subject: Modify CREF to show references to inherited bindings.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=728c7cb9748130273725649752bc46899df780da;p=mit-scheme.git

Modify CREF to show references to inherited bindings.

This will help track down which parts of the string abstraction need to be
replaced.
---

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))