Skip to content
Snippets Groups Projects
Commit 108fab48 authored by ram's avatar ram
Browse files

When computing interpreted debug blocks, ignore successors to the component

tail or other functions.
Compute the correct result for DEBUG-FUNCTION-START-LOCATION with interpreted
debug functions.
parent b2c88ea9
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.34 1992/01/14 14:52:04 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.35 1992/01/14 15:07:31 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -553,14 +553,20 @@ ...@@ -553,14 +553,20 @@
(%make-interpreted-debug-block block)) (%make-interpreted-debug-block block))
res))) res)))
(dolist (block res) (dolist (block res)
(let ((successors nil)) (let* ((successors nil)
(dolist (succ (c::block-succ (cblock (interpreted-debug-block-ir1-block block))
(interpreted-debug-block-ir1-block block))) (succ (c::block-succ cblock))
(let ((dblock (gethash succ *ir1-block-debug-block*))) (valid-succ
(unless dblock (if (and succ
(error "Block ~S has successor ~S in different lambda." (eq (car succ)
(interpreted-debug-block-ir1-block block) succ)) (c::component-tail
(push dblock successors))) (c::block-component cblock))))
()
succ)))
(dolist (sblock valid-succ)
(let ((dblock (gethash sblock *ir1-block-debug-block*)))
(when dblock
(push dblock successors))))
(setf (debug-block-successors block) (nreverse successors)))) (setf (debug-block-successors block) (nreverse successors))))
(gethash ir1-block *ir1-block-debug-block*))))) (gethash ir1-block *ir1-block-debug-block*)))))
...@@ -3890,7 +3896,7 @@ ...@@ -3890,7 +3896,7 @@
;; Return the first location if there are any, otherwise nil. ;; Return the first location if there are any, otherwise nil.
(handler-case (do-debug-function-blocks (block debug-fun nil) (handler-case (do-debug-function-blocks (block debug-fun nil)
(do-debug-block-locations (loc block nil) (do-debug-block-locations (loc block nil)
(return loc))) (return-from debug-function-start-location loc)))
(no-debug-blocks (condx) (no-debug-blocks (condx)
(declare (ignore condx)) (declare (ignore condx))
nil))))) nil)))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment