Changeset 15062


Ignore:
Timestamp:
Nov 8, 2011, 7:11:31 PM (8 years ago)
Author:
gz
Message:

Indirect read loop through *read-loop-function*. Add *break-loop-type* to make the info available to debugger hooks. Move the fixup of the break condition to before invoking the hook.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-readloop-lds.lisp

    r14934 r15062  
    2121
    2222
     23(defvar *read-loop-function* 'read-loop)
     24
     25(defun run-read-loop (&rest args)
     26  (declare (dynamic-extent args))
     27  (apply *read-loop-function* args))
    2328
    2429(defun toplevel-loop ()
    2530  (loop
    2631    (if (eq (catch :toplevel
    27               (read-loop :break-level 0 )) $xstkover)
     32              (run-read-loop :break-level 0 )) $xstkover)
    2833      (format t "~&;[Stacks reset due to overflow.]")
    2934      (when (eq *current-process* *initial-process*)
     
    481486  (#__exit -1))
    482487
     488;; Make these available to debugger hook
    483489(defvar *top-error-frame* nil)
     490(defvar *break-loop-type* nil) ;; e.g. "Debug", "Signal", "Error".
    484491
    485492(defun break-loop-handle-error (condition *top-error-frame*)
     
    487494    (dolist (x bogus-globals)
    488495      (set x (funcall (pop newvals))))
    489     (when (and *debugger-hook* *break-on-errors* (not *batch-flag*))
    490       (let ((hook *debugger-hook*)
    491             (*debugger-hook* nil))
    492         (funcall hook condition hook)))
    493496    (let ((msg (if *batch-flag* ;; Give a little more info if exiting
    494497                 (format nil "Error of type ~s" (type-of condition))
    495498                 "Error")))
     499      (when (and *debugger-hook* *break-on-errors* (not *batch-flag*))
     500        (let ((hook *debugger-hook*)
     501              (*debugger-hook* nil)
     502              (*break-loop-type* msg))
     503          (funcall hook condition hook)))
    496504      (%break-message msg condition))
    497505    (let* ((s *error-output*))
     
    539547(defun invoke-debugger (condition &aux (*top-error-frame* (%get-frame-ptr)))
    540548  "Enter the debugger."
    541   (let ((c (require-type condition 'condition)))
     549  (let ((c (require-type condition 'condition))
     550        (msg "Debug"))
    542551    (when *debugger-hook*
    543552      (let ((hook *debugger-hook*)
    544             (*debugger-hook* nil))
     553            (*debugger-hook* nil)
     554            (*break-loop-type* msg))
    545555        (funcall hook c hook)))
    546     (%break-message "Debug" c)
     556    (%break-message msg c)
    547557    (break-loop c)))
    548558
     
    563573        (sub (make-string-output-stream))
    564574        (indent 0))
    565     (format s "~A ~A: " prefixchar msg)
     575    (format s "~A~@[ ~A:~] " prefixchar msg)
    566576    (setf (indenting-string-output-stream-indent s) (setq indent (column s)))
    567577    (decf (stream-line-length sub) indent)
     
    587597         (hook *break-hook*))
    588598    (restart-case (progn
    589                     (when hook
    590                       (let ((*break-hook* nil))
    591                         (funcall hook condition hook))
    592                       (setq hook nil))
    593                     (%break-message msg condition)
    594599                    (when (and (eq (type-of condition) 'simple-condition)
    595600                               (equal (simple-condition-format-control condition) ""))
     
    597602                                        :format-control "~a"
    598603                                        :format-arguments (list msg))))
     604                    (when hook
     605                      (let ((*break-hook* nil)
     606                            (*break-loop-type* msg))
     607                        (funcall hook condition hook))
     608                      (setq hook nil))
     609                    (%break-message msg condition)
    599610                    (break-loop condition))
    600611      (continue () :report (lambda (stream) (write-string cont-string stream))))
     
    649660          ((eql count 1) (error "Error reporting error"))
    650661          (t (bug "Error reporting error")))))
    651 
    652 
    653662
    654663
     
    693702                 (*print-level* *error-print-level*)
    694703                 (*print-length* *error-print-length*)
    695                                         ;(*print-pretty* nil)
     704                 ;(*print-pretty* nil)
    696705                 (*print-array* nil))
    697706            (format t (or (application-ui-operation *application* :break-options-string t)
     
    711720                 (application-ui-operation *application*
    712721                                           :enter-backtrace-context context)
    713                  (read-loop :break-level (1+ *break-level*)
    714                             :input-stream *debug-io*
    715                             :output-stream *debug-io*))
     722                 (run-read-loop :break-level (1+ *break-level*)
     723                                :input-stream *debug-io*
     724                                :output-stream *debug-io*))
    716725            (application-ui-operation *application* :exit-backtrace-context
    717726                                      context)))))))
Note: See TracChangeset for help on using the changeset viewer.