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
  16 ;;; ERROR-ERROR can be called when the error system is in trouble and needs to
  17 ;;; punt fast. It prints a message without using FORMAT. If we get into this
  18 ;;; recursively, then we halt.
  19 (defun error-error (&rest messages)
  20   (let ((*error-error-depth* (1+ *error-error-depth*)))
  21     (case *error-error-depth*
  22       (1)
  23       (2
  24        (stream-cold-init-or-reset))
  25       (3
  26        (/show0 "*ERROR-ERROR-DEPTH* too big, trying THROW")
  27        (throw 'toplevel-catcher nil))
  28       (t
  29        (/show0 "*ERROR-ERROR-DEPTH* too big, trying HALT")
  30        (%primitive sb!c:halt)
  31        (/show0 "*ERROR-ERROR-DEPTH* too big, trying THROW")
  32        (throw 'toplevel-catcher nil)))
  33
  34     (with-standard-io-syntax
  35       (let ((*print-readably* nil))
  36         (dolist (item messages)
  37           (princ item *terminal-io*))
  38         (terpri *terminal-io*)
  39         (sb!debug:backtrace most-positive-fixnum *terminal-io*)
  40         (force-output *terminal-io*)
  41         (invoke-debugger
  42          (coerce-to-condition "Maximum error nesting depth exceeded" nil
  43                               'simple-error
  44                               'error))))))