Skip to content
Snippets Groups Projects
Commit 13a464eb authored by wlott's avatar wlott
Browse files

Extended find-caller-name and find-interrupted-name to also return the

frame for use with debug:*stack-top-hint*.  Changed internal-error to bind
debug:*stack-top-hint* before calling error.
parent 96f8b8fd
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/interr.lisp,v 1.22 1992/02/14 23:45:02 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.23 1992/03/10 18:35:38 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -651,19 +651,23 @@ ...@@ -651,19 +651,23 @@
;;; ;;;
(defun find-caller-name () (defun find-caller-name ()
(if *finding-name* (if *finding-name*
"<error finding name>" (values "<error finding name>" nil)
(handler-case (handler-case
(let ((*finding-name* t)) (let* ((*finding-name* t)
(di:debug-function-name (frame (di:frame-down (di:frame-down (di:top-frame))))
(di:frame-debug-function (name (di:debug-function-name
(di:frame-down (di:frame-down (di:top-frame)))))) (di:frame-debug-function frame))))
(error () "<error finding name>") (di:flush-frames-above frame)
(di:debug-condition () "<error finding name>")))) (values name frame))
(error ()
(values "<error finding name>" nil))
(di:debug-condition ()
(values "<error finding name>" nil)))))
(defun find-interrupted-name () (defun find-interrupted-name ()
(if *finding-name* (if *finding-name*
"<error finding name>" (values "<error finding name>" nil)
(handler-case (handler-case
(let ((*finding-name* t)) (let ((*finding-name* t))
(do ((frame (di:top-frame) (di:frame-down frame))) (do ((frame (di:top-frame) (di:frame-down frame)))
...@@ -671,11 +675,14 @@ ...@@ -671,11 +675,14 @@
(and (di::compiled-frame-p frame) (and (di::compiled-frame-p frame)
(di::compiled-frame-escaped frame))) (di::compiled-frame-escaped frame)))
(if (di::compiled-frame-p frame) (if (di::compiled-frame-p frame)
(di:debug-function-name (values (di:debug-function-name
(di:frame-debug-function frame)) (di:frame-debug-function frame))
"<error finding name>")))) frame)
(error () "<error finding name>") (values "<error finding name>" nil)))))
(di:debug-condition () "<error finding name>")))) (error ()
(values "<error finding name>" nil))
(di:debug-condition ()
(values "<error finding name>" nil)))))
;;;; internal-error signal handler. ;;;; internal-error signal handler.
...@@ -687,34 +694,36 @@ ...@@ -687,34 +694,36 @@
(multiple-value-bind (multiple-value-bind
(error-number arguments) (error-number arguments)
(vm:internal-error-arguments scp) (vm:internal-error-arguments scp)
(let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset))) (multiple-value-bind
(name (find-interrupted-name)) (name debug:*stack-top-hint*)
(info (and (< -1 error-number (length *internal-errors*)) (find-interrupted-name)
(svref *internal-errors* error-number)))) (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
(cond ((null info) (info (and (< -1 error-number (length *internal-errors*))
(error 'simple-error (svref *internal-errors* error-number))))
:function-name name (cond ((null info)
:format-string (error 'simple-error
"Unknown internal error, ~D? args=~S" :function-name name
:format-arguments :format-string
(list error-number "Unknown internal error, ~D? args=~S"
(mapcar #'(lambda (sc-offset) :format-arguments
(di::sub-access-debug-var-slot (list error-number
fp sc-offset scp)) (mapcar #'(lambda (sc-offset)
arguments)))) (di::sub-access-debug-var-slot
((null (error-info-function info)) fp sc-offset scp))
(error 'simple-error arguments))))
:function-name name ((null (error-info-function info))
:format-string (error 'simple-error
"Internal error ~D: ~A. args=~S" :function-name name
:format-arguments :format-string
(list error-number "Internal error ~D: ~A. args=~S"
(error-info-description info) :format-arguments
(mapcar #'(lambda (sc-offset) (list error-number
(di::sub-access-debug-var-slot (error-info-description info)
fp sc-offset scp)) (mapcar #'(lambda (sc-offset)
arguments)))) (di::sub-access-debug-var-slot
(t fp sc-offset scp))
(funcall (error-info-function info) name fp scp arguments))))
arguments)))))))) (t
(funcall (error-info-function info) name fp scp
arguments)))))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment