From 96568a33890b9531b620dc7d12089a5087798294 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Tue, 24 Apr 1990 11:50:36 +0000 Subject: [PATCH] Added code that uses the DI interface to find the name of the function in which the error occurred. --- code/error.lisp | 34 ++++++++++++++++++++-------------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/code/error.lisp b/code/error.lisp index 910578246..b750072de 100644 --- a/code/error.lisp +++ b/code/error.lisp @@ -570,18 +570,24 @@ The previous version is uglier, but it sets up unique run-time tags. ;;;; Fetching errorful function name. +;;; Used to prevent infinite recursive lossage when we can't find the caller +;;; for some reason. +;;; +(defvar *finding-caller* nil) + #+new-compiler -;;; FIND-NAME returns the name of a function if it is a subr or named-lambda. -;;; If the function is a regular lambda, the whole list is returned, and if -;;; the function can't be recognized, () is returned. -(defun find-name (function) - (declare (ignore function)) - 'hunoz) - -;;; GET-CALLER returns a form that returns the function which called the -;;; currently active function. -(defmacro get-caller () - 'nil) +;;; FIND-CALLER-NAME -- Internal +;;; +(defun find-caller-name () + (if *finding-caller* + "<error finding name>" + (handler-case + (let ((*finding-caller* 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>")))) ;;;; ERROR, CERROR, BREAK, WARN. @@ -598,7 +604,7 @@ The previous version is uglier, but it sets up unique run-time tags. (infinite-error-protect (let ((condition (coerce-to-condition datum arguments 'simple-error 'error))) (unless (error-function-name condition) - (setf (error-function-name condition) (find-name (get-caller)))) + (setf (error-function-name condition) (find-caller-name))) (signal condition) (invoke-debugger condition)))) @@ -615,7 +621,7 @@ The previous version is uglier, but it sets up unique run-time tags. (coerce-to-condition datum arguments 'simple-error 'error)))) (unless (error-function-name condition) - (setf (error-function-name condition) (find-name (get-caller)))) + (setf (error-function-name condition) (find-caller-name))) (error condition))) nil) @@ -989,7 +995,7 @@ The previous version sets up unique run-time tags. (defun lisp::%sp-internal-error (err-code arg3 arg4) (infinite-error-protect (funcall (svref *internal-error-table* err-code) - (find-name (get-caller)) + (find-caller-name) 0 arg3 arg4))) -- GitLab