diff --git a/code/debug.lisp b/code/debug.lisp index 56ff1718b3e45f93d0b737580f7cb2f03bd7e62b..40608316638767bd65fbedcf97dbe14cc1a67745 100644 --- a/code/debug.lisp +++ b/code/debug.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.53 2001/07/12 20:10:52 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.54 2001/12/12 20:18:25 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -623,6 +623,20 @@ See the CMU Common Lisp User's Manual for more information. (di:debug-condition (ignore) ignore) (error (cond) (format t "Error finding source: ~A" cond)))))) +;;; SAFE-CONDITION-MESSAGE -- Internal +;;; +;;; Safely print condition to a string, handling any errors during +;;; printing. +;;; +(defun safe-condition-message (condition) + (handler-case + (princ-to-string condition) + (error (cond) + ;; Beware of recursive errors in printing, so only use the condition + ;; if it is printable itself: + (format nil "Unable to display error condition~@[: ~A~]" + (ignore-errors (princ-to-string cond)))))) + ;;;; Invoke-debugger. @@ -638,6 +652,29 @@ See the CMU Common Lisp User's Manual for more information. (defvar *debug-restarts*) (defvar *debug-condition*) +;;; INVOKE-TTY-DEBUGGER -- Internal +;;; +;;; Print condition and invoke the TTY debugger. +;;; +(defun invoke-tty-debugger (condition) + (format *error-output* "~2&~A~2&" + (safe-condition-message *debug-condition*)) + (unless (typep condition 'step-condition) + (show-restarts *debug-restarts* *error-output*)) + (internal-debug)) + +;;; REAL-INVOKE-DEBUGGER -- Internal +;;; +;;; This function really invokes the current standard debugger. +;;; This is overwritten by e.g. the Motif Interface code. It is a +;;; function and not a special variable hook, because users are +;;; supposed to use *debugger-hook*, and this is supposed to be the +;;; safe fall-back, which should be fairly secure against +;;; accidental mishaps. +;;; +(defun real-invoke-debugger (condition) + (invoke-tty-debugger condition)) + ;;; INVOKE-DEBUGGER -- Public. ;;; (defun invoke-debugger (condition) @@ -656,10 +693,7 @@ See the CMU Common Lisp User's Manual for more information. (kernel:*current-level* 0) (*print-readably* nil) (*read-eval* t)) - (format *error-output* "~2&~A~2&" *debug-condition*) - (unless (typep condition 'step-condition) - (show-restarts *debug-restarts* *error-output*)) - (internal-debug))) + (real-invoke-debugger condition))) ;;; SHOW-RESTARTS -- Internal. ;;; @@ -1223,7 +1257,7 @@ See the CMU Common Lisp User's Manual for more information. (def-debug-command-alias "?" "HELP") (def-debug-command "ERROR" () - (format t "~A~%" *debug-condition*) + (format t "~A~%" (safe-condition-message *debug-condition*)) (show-restarts *debug-restarts*)) (def-debug-command "BACKTRACE" () diff --git a/interface/debug.lisp b/interface/debug.lisp index 860a0aa8bcb0c036f1c321d95d26f6f2789f75e7..2f9d6fe97fc590723ec22cba68004a09b86e5986 100644 --- a/interface/debug.lisp +++ b/interface/debug.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/interface/debug.lisp,v 1.8 1994/10/31 04:53:18 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/interface/debug.lisp,v 1.9 2001/12/12 20:18:25 pmai Rel $") ;;; ;;; ********************************************************************** ;;; @@ -98,7 +98,7 @@ (let ((*current-frame* frame)) (funcall (debug-command-p :edit-source))) (error (cond) - (interface-error (format nil "~A" cond))))) + (interface-error (safe-condition-message cond))))) (defun frame-eval-callback (widget call-data frame output) (declare (ignore call-data)) @@ -115,8 +115,8 @@ (di:eval-in-frame frame (read-from-string input)))) (format nil "~a~s~%" out val)) (error (cond) - (format nil "~2&~A~2&" cond))))) - (length (length response))) + (safe-condition-message cond))))) + (length (length response))) (declare (simple-string response)) (text-set-string widget "") @@ -299,7 +299,7 @@ ;;; condition. ;;; (defun debug-display-error (errmsg condition) - (set-values errmsg :label-string (format nil "~A" condition))) + (set-values errmsg :label-string (safe-condition-message condition))) ;;; DEBUG-DISPLAY-RESTARTS -- Internal ;;; @@ -543,7 +543,8 @@ (system:serve-event)) (error (err) (if *flush-debug-errors* - (interface-error (format nil "~a" err) pane) + (interface-error (safe-condition-message err) + pane) (interface-error "Do not yet support recursive debugging" pane)))) @@ -559,42 +560,16 @@ (defvar *in-windowing-debugger* nil) -;;; INVOKE-TTY-DEBUGGER -- Internal -;;; -;;; Print condition and invoke the TTY debugger. -;;; -(defun invoke-tty-debugger (condition) - (format *error-output* "~2&~A~2&" *debug-condition*) - (unless (typep condition 'step-condition) - (show-restarts *debug-restarts* *error-output*)) - (internal-debug)) - -;;; INVOKE-DEBUGGER -- Public -;;; -;;; Invokes the Lisp debugger. It executes some common debugger setup code -;;; and then decides whether to invoke the TTY debugger or the Motif -;;; debugger. -;;; -(defun invoke-debugger (condition) - "The CMU Common Lisp debugger. Type h for help." - (when *debugger-hook* - (let ((hook *debugger-hook*) - (*debugger-hook* nil)) - (funcall hook condition hook))) - (unix:unix-sigsetmask 0) - (let* ((*debug-condition* condition) - (*debug-restarts* (compute-restarts condition)) - (*standard-input* *debug-io*) ;in case of setq - (*standard-output* *debug-io*) ;'' '' '' '' - (*error-output* *debug-io*) - ;; Rebind some printer control variables. - (kernel:*current-level* 0) - (*print-readably* nil) - (*read-eval* t)) - (if (or (not (use-graphics-interface)) - *in-windowing-debugger* - (typep condition 'xti:toolkit-error)) - (invoke-tty-debugger condition) - (let ((*in-windowing-debugger* t)) - (write-line "Invoking debugger...") - (invoke-motif-debugger condition))))) +;;; REAL-INVOKE-DEBUGGER -- Internal +;;; +;;; Invokes the Lisp debugger. It decides whether to invoke the TTY +;;; debugger or the Motif debugger. +;;; +(defun real-invoke-debugger (condition) + (if (or (not (use-graphics-interface)) + *in-windowing-debugger* + (typep condition 'xti:toolkit-error)) + (invoke-tty-debugger condition) + (let ((*in-windowing-debugger* t)) + (write-line "Invoking debugger...") + (invoke-motif-debugger condition))))