diff --git a/code/interr.lisp b/code/interr.lisp index a1fc24e0d3a450405f829e30ec45a754803a109c..3e751ee8446cc43d31e2c2e73363e0b1923e41a1 100644 --- a/code/interr.lisp +++ b/code/interr.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (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 @@ ;;; (defun find-caller-name () (if *finding-name* - "<error finding name>" + (values "<error finding name>" nil) (handler-case - (let ((*finding-name* t)) - (di:debug-function-name - (di:frame-debug-function - (di:frame-down (di:frame-down (di:top-frame)))))) - (error () "<error finding name>") - (di:debug-condition () "<error finding name>")))) + (let* ((*finding-name* t) + (frame (di:frame-down (di:frame-down (di:top-frame)))) + (name (di:debug-function-name + (di:frame-debug-function frame)))) + (di:flush-frames-above frame) + (values name frame)) + (error () + (values "<error finding name>" nil)) + (di:debug-condition () + (values "<error finding name>" nil))))) (defun find-interrupted-name () (if *finding-name* - "<error finding name>" + (values "<error finding name>" nil) (handler-case (let ((*finding-name* t)) (do ((frame (di:top-frame) (di:frame-down frame))) @@ -671,11 +675,14 @@ (and (di::compiled-frame-p frame) (di::compiled-frame-escaped frame))) (if (di::compiled-frame-p frame) - (di:debug-function-name - (di:frame-debug-function frame)) - "<error finding name>")))) - (error () "<error finding name>") - (di:debug-condition () "<error finding name>")))) + (values (di:debug-function-name + (di:frame-debug-function frame)) + frame) + (values "<error finding name>" nil))))) + (error () + (values "<error finding name>" nil)) + (di:debug-condition () + (values "<error finding name>" nil))))) ;;;; internal-error signal handler. @@ -687,34 +694,36 @@ (multiple-value-bind (error-number arguments) (vm:internal-error-arguments scp) - (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset))) - (name (find-interrupted-name)) - (info (and (< -1 error-number (length *internal-errors*)) - (svref *internal-errors* error-number)))) - (cond ((null info) - (error 'simple-error - :function-name name - :format-string - "Unknown internal error, ~D? args=~S" - :format-arguments - (list error-number - (mapcar #'(lambda (sc-offset) - (di::sub-access-debug-var-slot - fp sc-offset scp)) - arguments)))) - ((null (error-info-function info)) - (error 'simple-error - :function-name name - :format-string - "Internal error ~D: ~A. args=~S" - :format-arguments - (list error-number - (error-info-description info) - (mapcar #'(lambda (sc-offset) - (di::sub-access-debug-var-slot - fp sc-offset scp)) - arguments)))) - (t - (funcall (error-info-function info) name fp scp - arguments)))))))) + (multiple-value-bind + (name debug:*stack-top-hint*) + (find-interrupted-name) + (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset))) + (info (and (< -1 error-number (length *internal-errors*)) + (svref *internal-errors* error-number)))) + (cond ((null info) + (error 'simple-error + :function-name name + :format-string + "Unknown internal error, ~D? args=~S" + :format-arguments + (list error-number + (mapcar #'(lambda (sc-offset) + (di::sub-access-debug-var-slot + fp sc-offset scp)) + arguments)))) + ((null (error-info-function info)) + (error 'simple-error + :function-name name + :format-string + "Internal error ~D: ~A. args=~S" + :format-arguments + (list error-number + (error-info-description info) + (mapcar #'(lambda (sc-offset) + (di::sub-access-debug-var-slot + fp sc-offset scp)) + arguments)))) + (t + (funcall (error-info-function info) name fp scp + arguments)))))))))