fix rounding of floats big enough to be bignums
[sbcl.git] / 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))))))