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