Skip to content
Snippets Groups Projects
Commit 92dc7a2d authored by pmai's avatar pmai
Browse files

o Remove unnecessary code duplication for INVOKE-DEBUGGER

o Make condition printing safe, so that errors in condition printing
  don't confuse the user.  Inspired by a patch from Martin Cracauer.
parent f3e66be8
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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. ...@@ -623,6 +623,20 @@ See the CMU Common Lisp User's Manual for more information.
(di:debug-condition (ignore) ignore) (di:debug-condition (ignore) ignore)
(error (cond) (format t "Error finding source: ~A" cond)))))) (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. ;;;; Invoke-debugger.
...@@ -638,6 +652,29 @@ See the CMU Common Lisp User's Manual for more information. ...@@ -638,6 +652,29 @@ See the CMU Common Lisp User's Manual for more information.
(defvar *debug-restarts*) (defvar *debug-restarts*)
(defvar *debug-condition*) (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. ;;; INVOKE-DEBUGGER -- Public.
;;; ;;;
(defun invoke-debugger (condition) (defun invoke-debugger (condition)
...@@ -656,10 +693,7 @@ See the CMU Common Lisp User's Manual for more information. ...@@ -656,10 +693,7 @@ See the CMU Common Lisp User's Manual for more information.
(kernel:*current-level* 0) (kernel:*current-level* 0)
(*print-readably* nil) (*print-readably* nil)
(*read-eval* t)) (*read-eval* t))
(format *error-output* "~2&~A~2&" *debug-condition*) (real-invoke-debugger condition)))
(unless (typep condition 'step-condition)
(show-restarts *debug-restarts* *error-output*))
(internal-debug)))
;;; SHOW-RESTARTS -- Internal. ;;; SHOW-RESTARTS -- Internal.
;;; ;;;
...@@ -1223,7 +1257,7 @@ See the CMU Common Lisp User's Manual for more information. ...@@ -1223,7 +1257,7 @@ See the CMU Common Lisp User's Manual for more information.
(def-debug-command-alias "?" "HELP") (def-debug-command-alias "?" "HELP")
(def-debug-command "ERROR" () (def-debug-command "ERROR" ()
(format t "~A~%" *debug-condition*) (format t "~A~%" (safe-condition-message *debug-condition*))
(show-restarts *debug-restarts*)) (show-restarts *debug-restarts*))
(def-debug-command "BACKTRACE" () (def-debug-command "BACKTRACE" ()
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -98,7 +98,7 @@
(let ((*current-frame* frame)) (let ((*current-frame* frame))
(funcall (debug-command-p :edit-source))) (funcall (debug-command-p :edit-source)))
(error (cond) (error (cond)
(interface-error (format nil "~A" cond))))) (interface-error (safe-condition-message cond)))))
(defun frame-eval-callback (widget call-data frame output) (defun frame-eval-callback (widget call-data frame output)
(declare (ignore call-data)) (declare (ignore call-data))
...@@ -115,8 +115,8 @@ ...@@ -115,8 +115,8 @@
(di:eval-in-frame frame (read-from-string input)))) (di:eval-in-frame frame (read-from-string input))))
(format nil "~a~s~%" out val)) (format nil "~a~s~%" out val))
(error (cond) (error (cond)
(format nil "~2&~A~2&" cond))))) (safe-condition-message cond)))))
(length (length response))) (length (length response)))
(declare (simple-string response)) (declare (simple-string response))
(text-set-string widget "") (text-set-string widget "")
...@@ -299,7 +299,7 @@ ...@@ -299,7 +299,7 @@
;;; condition. ;;; condition.
;;; ;;;
(defun debug-display-error (errmsg 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 ;;; DEBUG-DISPLAY-RESTARTS -- Internal
;;; ;;;
...@@ -543,7 +543,8 @@ ...@@ -543,7 +543,8 @@
(system:serve-event)) (system:serve-event))
(error (err) (error (err)
(if *flush-debug-errors* (if *flush-debug-errors*
(interface-error (format nil "~a" err) pane) (interface-error (safe-condition-message err)
pane)
(interface-error (interface-error
"Do not yet support recursive debugging" "Do not yet support recursive debugging"
pane)))) pane))))
...@@ -559,42 +560,16 @@ ...@@ -559,42 +560,16 @@
(defvar *in-windowing-debugger* nil) (defvar *in-windowing-debugger* nil)
;;; INVOKE-TTY-DEBUGGER -- Internal ;;; REAL-INVOKE-DEBUGGER -- Internal
;;; ;;;
;;; Print condition and invoke the TTY debugger. ;;; Invokes the Lisp debugger. It decides whether to invoke the TTY
;;; ;;; debugger or the Motif debugger.
(defun invoke-tty-debugger (condition) ;;;
(format *error-output* "~2&~A~2&" *debug-condition*) (defun real-invoke-debugger (condition)
(unless (typep condition 'step-condition) (if (or (not (use-graphics-interface))
(show-restarts *debug-restarts* *error-output*)) *in-windowing-debugger*
(internal-debug)) (typep condition 'xti:toolkit-error))
(invoke-tty-debugger condition)
;;; INVOKE-DEBUGGER -- Public (let ((*in-windowing-debugger* t))
;;; (write-line "Invoking debugger...")
;;; Invokes the Lisp debugger. It executes some common debugger setup code (invoke-motif-debugger condition))))
;;; 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)))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment