From a66b74c8e7bb15fac63ceb65734e73cbbb482b76 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Tue, 3 Aug 1993 10:57:06 +0000 Subject: [PATCH] If file-info-untruename is already absolute, then dump it instead of the truename. This allows search-lists or logical pathnames to be preserved in the defined-from info. --- compiler/debug-dump.lisp | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp index c55df2fe8..671bb37db 100644 --- a/compiler/debug-dump.lisp +++ b/compiler/debug-dump.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.33 1993/05/17 10:07:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.34 1993/08/03 10:57:06 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -292,8 +292,7 @@ (declare (type source-info info)) (assert (not (source-info-current-file info))) (mapcar #'(lambda (x) - (let ((name (file-info-name x)) - (res (make-debug-source + (let ((res (make-debug-source :from :file :comment (file-info-comment x) :created (file-info-write-date x) @@ -301,13 +300,21 @@ :source-root (file-info-source-root x) :start-positions (coerce-to-smallest-eltype - (file-info-positions x))))) - (cond ((simple-string-p name) - (setf (debug-source-name res) name)) - (t - (setf (debug-source-from res) name) - (setf (debug-source-name res) - (coerce (file-info-forms x) 'simple-vector)))) + (file-info-positions x)))) + (name (file-info-name info))) + (etypecase name + ((member :stream) + (setf (debug-source-from res) name) + (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)))))) res)) (source-info-files info))) -- GitLab