From 47cdb91ecedc640b09db5f732182a1515d4c6a86 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 3 Feb 1999 06:10:02 +0000
Subject: [PATCH] Fix fencepost error when printing bindings.  Show complete
 environment chain; previously omitted global environment.  Eliminate
 gratuitous use of EVAL.

---
 v7/src/edwin/debug.scm | 95 +++++++++++++++++++++++-------------------
 1 file changed, 52 insertions(+), 43 deletions(-)

diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm
index 76de7bd8a..d21493da2 100644
--- a/v7/src/edwin/debug.scm
+++ b/v7/src/edwin/debug.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: debug.scm,v 1.44 1999/01/02 06:11:34 cph Exp $
+;;; $Id: debug.scm,v 1.45 1999/02/03 06:10:02 cph Exp $
 ;;;
 ;;; Copyright (c) 1992-1999 Massachusetts Institute of Technology
 ;;;
@@ -1674,25 +1674,26 @@ once it has been renamed, it will not be deleted automatically.")
 (define (myprint-binding name value environment port)
   (let ((x-size (output-port/x-size port)))
     (debugger-newline port)
-    (write-string
-     (let ((name1
-	    (output-to-string
-	     (quotient x-size 2)
+    (let ((name1
+	   (output-to-string (quotient x-size 2)
 	     (lambda ()
 	       (write-dbg-name name (current-output-port))))))
-       (if (unassigned-reference-trap? value)
-	   (string-append name1 " is unassigned")
-	   (let* ((s (string-append name1 " = "))
-		  (length (string-length s))
-		  (pret
-		   (with-output-to-string
-		     (lambda ()
-		       (eval `(pp ,name (current-output-port) #t ,length)
-			     environment)))))
-	     (string-append
-	      s
-	      (string-tail pret (+ length 1))))))
-     port)
+      (write-string name1 port)
+      (if (unassigned-reference-trap? value)
+	  (write-string " is unassigned" port)
+	  (let ((separator " = "))
+	    (write-string separator port)
+	    (let ((indentation 
+		   (+ (string-length name1)
+		      (string-length separator))))
+	      (write-string (string-tail (with-output-to-string
+					   (lambda ()
+					     (pp value
+						 (current-output-port)
+						 #t
+						 indentation)))
+					 indentation)
+			    port)))))
     (debugger-newline port)))
 
 (define bline-type:environment
@@ -1737,23 +1738,25 @@ once it has been renamed, it will not be deleted automatically.")
 (define (show-frames-and-bindings environment port)
 
   (define (envs environment)
-    (if (environment-has-parent? environment)
-	(cons environment  (envs (environment-parent environment)))
-	'()))
+    (cons environment
+	  (if (environment-has-parent? environment)
+	      (envs (environment-parent environment))
+	      '())))
 
   (define (show-frames envs indents)
     (for-each (lambda (env indent)
 		(debugger-newline port)
 		(if (eq? env environment)
-		    (begin
-		      (if (< 4 (string-length indent))
-			  (write-string (string-tail indent 4) port))
-		      (write-string "==> " port))
+		    (let* ((pointer "==> ")
+			   (pl (string-length pointer)))
+		      (if (> (string-length indent) pl)
+			  (write-string (string-tail indent pl) port))
+		      (write-string pointer port))
 		    (write-string indent port))
 		(show-environment-name env port)
 		(debugger-newline port)
 		(show-environment-bindings-with-ind env indent port))
-      envs indents))
+	      envs indents))
 
   (let ((env-list (envs environment)))
     (cond ((ref-variable debugger-show-inner-frame-topmost?)
@@ -1854,23 +1857,29 @@ once it has been renamed, it will not be deleted automatically.")
 	     (finish names))))))
 
 (define (print-binding-with-ind name value ind port)
-  (let ((x-size (- (output-port/x-size port) (string-length ind) 4)))
-    (write-string (string-append ind "    ")
-		  port)
-    (write-string
-     (let ((name
-	    (output-to-string (quotient x-size 2)
-	      (lambda ()
-		(write-dbg-name name (current-output-port))))))
-       (if (unassigned-reference-trap? value)
-	   (string-append name " is unassigned")
-	   (let ((s (string-append name " = ")))
-	     (string-append
-	      s
-	      (output-to-string (max (- x-size (string-length s)) 0)
-		(lambda ()
-		  (write value)))))))
-     port)
+  (let* ((extra "    ")
+	 (x-size
+	  (- (output-port/x-size port)
+	     (+ (string-length ind)
+		(string-length extra)))))
+    (write-string ind port)
+    (write-string extra port)
+    (let ((name
+	   (output-to-string (quotient x-size 2)
+	     (lambda ()
+	       (write-dbg-name name (current-output-port))))))
+      (write-string name port)
+      (if (unassigned-reference-trap? value)
+	  (write-string " is unassigned" port)
+	  (let ((separator " = "))
+	    (write-string separator port)
+	    (write-string
+	     (output-to-string (max 0
+				    (- (- x-size 1)
+				       (+ (string-length name)
+					  (string-length separator))))
+			       (lambda () (write value)))
+	     port))))
     (debugger-newline port)))
 
 ;;;; Interface Port
-- 
2.25.1