diff --git a/code/interr.lisp b/code/interr.lisp index 4c356fc6f7da636961d2647a8cb882ea24c1eac6..1c00d07573e972b5f564110fb071e99b15fb4c5e 100644 --- a/code/interr.lisp +++ b/code/interr.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.5 1990/06/06 20:56:52 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.6 1990/06/09 00:55:37 wlott Exp $ ;;; ;;; Functions and macros to define and deal with internal errors (i.e. ;;; problems that can be signaled from assembler code). @@ -381,6 +381,26 @@ +#+new-compiler +(defvar *finding-name* nil) + +#+new-compiler +(defun find-interrupted-name () + (if *finding-name* + "<error finding name>" + (handler-case + (let ((*finding-name* t)) + (do ((frame (di:top-frame) (di:frame-down frame))) + ((or (null frame) + (di::frame-escaped frame)) + (if frame + (di:debug-function-name + (di:frame-debug-function frame)) + "<error finding name>")))) + (error () "<error finding name>") + (di:debug-condition () "<error finding name>")))) + + #+new-compiler (defun internal-error (signal code scp) (declare (ignore signal code)) @@ -390,16 +410,16 @@ mach:sigcontext t) (regs (mach:sigcontext-regs (alien-value sc)) mach:int-array t)) - (let* ((pc (int-sap (+ (alien-access - (mach:sigcontext-pc - (alien-value sc))) - (if (logbitp 31 - (alien-access - (mach:sigcontext-cause - (alien-value sc)))) - 4 - 0)))) - (bad-inst (sap-ref-32 pc 0)) + (let* ((pc (sap+ (alien-access + (mach:sigcontext-pc + (alien-value sc))) + (if (logbitp 31 + (alien-access + (mach:sigcontext-cause + (alien-value sc)))) + 4 + 0))) + #+nil (bad-inst (sap-ref-32 pc 0)) (number (sap-ref-8 pc 4)) (info (svref *internal-errors* number)) (args nil)) @@ -410,7 +430,11 @@ (alien-access (mach:int-array-ref (alien-value regs) (sap-ref-8 ptr 0)))) args))) - (error "~A [~D]:~{ ~S~}" - (if info (error-info-description info) "Unknown error") - number - (nreverse args))))) + (error 'simple-error + :format-string "~A [~D]:~{ ~S~}" + :format-arguments (list (if info + (error-info-description info) + "Unknown error") + number + (nreverse args)) + :function-name (find-interrupted-name)))))