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 (file-comment
  13   "$Header$")
  14
  15 ;;; These specials are used by ERROR-ERROR to track the success of recovery
  16 ;;; attempts.
  17 (defvar *error-error-depth* 0)
  18 (defvar *error-throw-up-count* 0)
  19
  20 ;;; ERROR-ERROR can be called when the error system is in trouble and needs to
  21 ;;; punt fast. It prints a message without using FORMAT. If we get into this
  22 ;;; recursively, then we halt.
  23 (defun error-error (&rest messages)
  24   (let ((*error-error-depth* (1+ *error-error-depth*)))
  25     (when (> *error-throw-up-count* 50)
  26       (%primitive sb!c:halt)
  27       (throw 'sb!impl::top-level-catcher nil))
  28     (case *error-error-depth*
  29       (1)
  30       (2
  31        (stream-cold-init-or-reset))
  32       (3
  33        (incf *error-throw-up-count*)
  34        (throw 'sb!impl::top-level-catcher nil))
  35       (t
  36        (%primitive sb!c:halt)
  37        (throw 'sb!impl::top-level-catcher nil)))
  38
  39     (with-standard-io-syntax
  40       (let ((*print-readably* nil))
  41         (dolist (item messages)
  42           (princ item *terminal-io*))
  43         (sb!debug:internal-debug)))))