src/code/error-error.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!IMPL")
  11
  12 ;;; These specials are used by ERROR-ERROR to track the success of recovery
  13 ;;; attempts.
  14 (defvar *error-error-depth* 0)
  15 (defvar *error-throw-up-count* 0)
  16
  17 ;;; ERROR-ERROR can be called when the error system is in trouble and needs to
  18 ;;; punt fast. It prints a message without using FORMAT. If we get into this
  19 ;;; recursively, then we halt.
  20 (defun error-error (&rest messages)
  21   (let ((*error-error-depth* (1+ *error-error-depth*)))
  22     (when (> *error-throw-up-count* 50)
  23       (/show0 "*ERROR-THROW-UP-COUNT* too big, trying HALT")
  24       (%primitive sb!c:halt)
  25       (/show0 "*ERROR-THROW-UP-COUNT* too big, trying THROW")
  26       (throw 'sb!impl::toplevel-catcher nil))
  27     (case *error-error-depth*
  28       (1)
  29       (2
  30        (stream-cold-init-or-reset))
  31       (3
  32        (incf *error-throw-up-count*)
  33        (/show0 "*ERROR-ERROR-DEPTH* too big, trying THROW")
  34        (throw 'sb!impl::toplevel-catcher nil))
  35       (t
  36        (/show0 "*ERROR-ERROR-DEPTH* too big, trying HALT")
  37        (%primitive sb!c:halt)
  38        (/show0 "*ERROR-ERROR-DEPTH* too big, trying THROW")
  39        (throw 'sb!impl::toplevel-catcher nil)))
  40
  41     (with-standard-io-syntax
  42       (let ((*print-readably* nil))
  43         (dolist (item messages)
  44           (princ item *terminal-io*))
  45         (sb!debug:internal-debug)))))