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       (%primitive sb!c:halt)
  24       (throw 'sb!impl::toplevel-catcher nil))
  25     (case *error-error-depth*
  26       (1)
  27       (2
  28        (stream-cold-init-or-reset))
  29       (3
  30        (incf *error-throw-up-count*)
  31        (throw 'sb!impl::toplevel-catcher nil))
  32       (t
  33        (%primitive sb!c:halt)
  34        (throw 'sb!impl::toplevel-catcher nil)))
  35
  36     (with-standard-io-syntax
  37       (let ((*print-readably* nil))
  38         (dolist (item messages)
  39           (princ item *terminal-io*))
  40         (sb!debug:internal-debug)))))