Changeset 15062

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:

• trunk/source/level-1/l1-readloop-lds.lisp (modified) (10 diffs)

trunk/source/level-1/l1-readloop-lds.lisp

@@ -21 +21 @@
 
 
+(defvar *read-loop-function* 'read-loop)
+
+(defun run-read-loop (&rest args)
+  (declare (dynamic-extent args))
+  (apply *read-loop-function* args))
 
 (defun toplevel-loop ()
   (loop
     (if (eq (catch :toplevel 
-              (read-loop :break-level 0 )) $xstkover)
+              (run-read-loop :break-level 0 )) $xstkover)
       (format t "~&;[Stacks reset due to overflow.]")
       (when (eq *current-process* *initial-process*)
@@ -481 +486 @@
   (#__exit -1))
 
+;; Make these available to debugger hook
 (defvar *top-error-frame* nil)
+(defvar *break-loop-type* nil) ;; e.g. "Debug", "Signal", "Error".
 
 (defun break-loop-handle-error (condition *top-error-frame*)
@@ -487 +494 @@
     (dolist (x bogus-globals)
       (set x (funcall (pop newvals))))
-    (when (and *debugger-hook* *break-on-errors* (not *batch-flag*))
-      (let ((hook *debugger-hook*)
-            (*debugger-hook* nil))
-        (funcall hook condition hook)))
     (let ((msg (if *batch-flag* ;; Give a little more info if exiting
                  (format nil "Error of type ~s" (type-of condition))
                  "Error")))
+      (when (and *debugger-hook* *break-on-errors* (not *batch-flag*))
+        (let ((hook *debugger-hook*)
+              (*debugger-hook* nil)
+              (*break-loop-type* msg))
+          (funcall hook condition hook)))
       (%break-message msg condition))
     (let* ((s *error-output*))
@@ -539 +547 @@
 (defun invoke-debugger (condition &aux (*top-error-frame* (%get-frame-ptr)))
   "Enter the debugger."
-  (let ((c (require-type condition 'condition)))
+  (let ((c (require-type condition 'condition))
+        (msg "Debug"))
     (when *debugger-hook*
       (let ((hook *debugger-hook*)
-            (*debugger-hook* nil))
+            (*debugger-hook* nil)
+            (*break-loop-type* msg))
         (funcall hook c hook)))
-    (%break-message "Debug" c)
+    (%break-message msg c)
     (break-loop c)))
 
@@ -563 +573 @@
         (sub (make-string-output-stream))
         (indent 0))
-    (format s "~A ~A: " prefixchar msg)
+    (format s "~A~@[ ~A:~] " prefixchar msg)
     (setf (indenting-string-output-stream-indent s) (setq indent (column s)))
     (decf (stream-line-length sub) indent)
@@ -587 +597 @@
          (hook *break-hook*))
     (restart-case (progn
-                    (when hook
-                      (let ((*break-hook* nil))
-                        (funcall hook condition hook))
-                      (setq hook nil))
-                    (%break-message msg condition)
                     (when (and (eq (type-of condition) 'simple-condition)
                                (equal (simple-condition-format-control condition) ""))
@@ -597 +602 @@
                                         :format-control "~a"
                                         :format-arguments (list msg))))
+                    (when hook
+                      (let ((*break-hook* nil)
+                            (*break-loop-type* msg))
+                        (funcall hook condition hook))
+                      (setq hook nil))
+                    (%break-message msg condition)
                     (break-loop condition))
       (continue () :report (lambda (stream) (write-string cont-string stream))))
@@ -649 +660 @@
           ((eql count 1) (error "Error reporting error"))
           (t (bug "Error reporting error")))))
-
-
 
 
@@ -693 +702 @@
                  (*print-level* *error-print-level*)
                  (*print-length* *error-print-length*)
-                                        ;(*print-pretty* nil)
+                 ;(*print-pretty* nil)
                  (*print-array* nil))
             (format t (or (application-ui-operation *application* :break-options-string t)
@@ -711 +720 @@
                  (application-ui-operation *application*
                                            :enter-backtrace-context context)
-                 (read-loop :break-level (1+ *break-level*)
-                            :input-stream *debug-io*
-                            :output-stream *debug-io*))
+                 (run-read-loop :break-level (1+ *break-level*)
+                                :input-stream *debug-io*
+                                :output-stream *debug-io*))
             (application-ui-operation *application* :exit-backtrace-context
                                       context)))))))