From 7ef21c401ac607271450172f97487f69d2135d44 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 6 Apr 2004 20:44:01 +0000
Subject: [PATCH]  debug-dump.lisp  revision 1.10.1.3  date: 90/04/13 12:11:22;
  author: ram;  state: Exp;  lines added/del: 8/3  Changed block dumping to
 notice when the successor is in a different  environment (due to a TR call). 
 ----------------------------  revision 1.10.1.2  date: 90/04/08 17:54:38; 
 author: ram;  state: Exp;  lines added/del: 2/2  old-cont => old-fp 
 ----------------------------  revision 1.10.1.1  date: 90/03/27 12:12:06; 
 author: ram;  state: Exp;  lines added/del: 1/0  Added support for file
 comments.

---
 compiler/debug-dump.lisp | 21 +++++++++++++--------
 1 file changed, 13 insertions(+), 8 deletions(-)

diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp
index b665eed2f..97bf78d92 100644
--- a/compiler/debug-dump.lisp
+++ b/compiler/debug-dump.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.46 2003/10/17 10:06:30 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.47 2004/04/06 20:44:01 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -280,6 +280,16 @@
     (values (copy-seq *byte-buffer*) tlf-num)))
 
 
+(defun namestring-for-debug-source (file-info)
+  "Extract the namestring from FILE-INFO for the DEBUG-SOURCE.  
+Return FILE-INFO's untruename (e.g., target:foo) if it is absolute;
+otherwise the truename."
+  (let* ((untruename (file-info-untruename file-info))
+	 (dir (pathname-directory untruename)))
+    (namestring (if (and dir (eq (first dir) :absolute))
+		    untruename
+		    (file-info-name file-info)))))
+
 ;;; DEBUG-SOURCE-FOR-INFO  --  Interface
 ;;;
 ;;;    Return a list of DEBUG-SOURCE structures containing information derived
@@ -308,13 +318,8 @@
 		   (setf (debug-source-name res)
 			 (coerce (file-info-forms x) 'simple-vector)))
 		  (pathname
-		   (let* ((untruename (file-info-untruename x))
-			  (dir (pathname-directory untruename)))
-		     (setf (debug-source-name res)
-			   (namestring
-			    (if (and dir (eq (first dir) :absolute))
-				untruename
-				name))))))
+		   (setf (debug-source-name res)
+			 (namestring-for-debug-source x))))
 		res))
 	  (source-info-files info)))
 
-- 
GitLab