From 12c497b3479a5ea5bd908e565e18f2a9dfe9df15 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 7 Feb 2010 20:42:29 +0100 Subject: [PATCH] Implemented SBCL's extension EXT:*INVOKE-DEBUGGER-HOOK* --- src/CHANGELOG | 2 ++ src/c/symbols_list.h | 2 ++ src/c/symbols_list2.h | 2 ++ src/clos/conditions.lsp | 2 -- src/doc/help.lsp | 19 +++++++++++++++++++ src/lsp/top.lsp | 16 ++++++++++++---- 6 files changed, 37 insertions(+), 6 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index f256150c6..6ae3d7028 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -78,6 +78,8 @@ ECL 10.2.1: ;;; (DEFMACRO WITH-COMPILATION-UNIT (OPTIONS &REST BODY) ...) ;;; The variable OPTIONS is not used. + - ECL now implements EXT:*INVOKE-DEBUGGER-HOOK*, which works like *DEBUGGER-HOOK* + but is also observed by BREAK. (SBCL extension adopted by ECL) ;;; Local Variables: *** ;;; mode:text *** diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 3c82fe9e9..5e5b29e8d 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1866,5 +1866,7 @@ cl_symbols[] = { {SYS_ "CLOSE-WINDOWS-HANDLE", SI_ORDINARY, si_close_windows_handle, 1, OBJNULL}, #endif +{EXT_ "*INVOKE-DEBUGGER-HOOK*", EXT_SPECIAL, NULL, -1, Cnil}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 6395c1676..3f78f40d5 100755 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1866,5 +1866,7 @@ cl_symbols[] = { {SYS_ "CLOSE-WINDOWS-HANDLE","si_close_windows_handle"}, #endif +{EXT_ "*INVOKE-DEBUGGER-HOOK*",NULL}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 8c4d337d4..2de9b69d0 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -894,8 +894,6 @@ strings." (format T "~A" (car p)) (format T "~%")))) -(defvar *debugger-hook* NIL) - (defun invoke-debugger (&optional (datum "Debug") &rest arguments) (let ((condition (coerce-to-condition datum arguments 'simple-condition 'debug))) diff --git a/src/doc/help.lsp b/src/doc/help.lsp index 8c64621d8..b7504faae 100644 --- a/src/doc/help.lsp +++ b/src/doc/help.lsp @@ -137,6 +137,13 @@ The value of the last top-level form.") (docfun * function (&rest numbers) " Returns the product of the args. With no args, returns 1.") +(docvar *debugger-hook* variable " +This is either NIL or a function of two arguments, a condition and the value +of *DEBUGGER-HOOK*. This function can either handle the condition or return +which causes the standard debugger to execute. The system passes the value +of this variable to the function because it binds *DEBUGGER-HOOK* to NIL +around the invocation.") + (docvar *debug-io* variable " The stream used by the ECL debugger. The initial value is a synonym stream to *TERMINAL-IO*.") @@ -206,6 +213,18 @@ If the value of SI::*INTERRUPT-ENABLE* is non-NIL, ECL signals an error on the terminal interrupt (this is the default case). If it is NIL, ECL ignores the interrupt and assigns T to SI::*INTERRUPT-ENABLE*.") +(docvar ext::*invoke-debugger-hook* variable " +ECL specific. +This is either NIL or a designator for a function of two arguments, +to be run when the debugger is about to be entered. The function is +run with *INVOKE-DEBUGGER-HOOK* bound to NIL to minimize recursive +errors, and receives as arguments the condition that triggered +debugger entry and the previous value of *INVOKE-DEBUGGER-HOOK* + +This mechanism is an extension similar to the standard *DEBUGGER-HOOK*. +In contrast to *DEBUGGER-HOOK*, it is observed by INVOKE-DEBUGGER even when +called by BREAK.") + #-boehm-gc (docvar si::*lisp-maxpages* variable " ECL specific. diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 7e456d696..b05549cc7 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -1379,10 +1379,17 @@ package." (tpl :commands debug-commands))))) (defun invoke-debugger (condition) - (when *debugger-hook* - (let* ((old-hook *debugger-hook*) - (*debugger-hook* nil)) - (funcall old-hook condition old-hook))) + ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not + ;; called when the debugger is disabled. We adopt this mechanism + ;; from SBCL. + (let ((old-hook *invoke-debugger-hook*)) + (when old-hook + (let ((*invoke-debugger-hook* nil)) + (funcall old-hook condition old-hook)))) + (let* ((old-hook *debugger-hook*)) + (when old-hook + (let ((*debugger-hook* nil)) + (funcall old-hook condition old-hook)))) (locally (declare (notinline default-debugger)) (if (<= 0 *tpl-level*) ;; Do we have a top-level REPL above us? @@ -1390,6 +1397,7 @@ package." (let* (;; We do not have a si::top-level invocation above us ;; so we have to provide the environment for interactive use. (*break-enable* *break-enable*) + (*invoke-debugger-hook* *invoke-debugger-hook*) (*debugger-hook* *debugger-hook*) (*quit-tags* (cons *quit-tag* *quit-tags*)) (*quit-tag* *quit-tags*) ; any unique new value