src/code/cold-error.lisp

   1 ;;;; miscellaneous error stuff that needs to be in the cold load
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!KERNEL")
  13
  14 (defvar *break-on-signals* nil
  15   #!+sb-doc
  16   "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will
  17    enter the debugger prior to signalling that condition.")
  18
  19 (defun signal (datum &rest arguments)
  20   #!+sb-doc
  21   "Invokes the signal facility on a condition formed from DATUM and
  22    ARGUMENTS. If the condition is not handled, NIL is returned. If
  23    (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
  24    before any signalling is done."
  25   (let ((condition (coerce-to-condition datum
  26                                         arguments
  27                                         'simple-condition
  28                                         'signal))
  29         (*handler-clusters* *handler-clusters*)
  30         (old-bos *break-on-signals*)
  31         (bos-actually-breaking nil))
  32     (restart-case
  33         (let ((break-on-signals *break-on-signals*)
  34               (*break-on-signals* nil))
  35           ;; The rebinding encloses the TYPEP so that a bogus
  36           ;; type specifier will not lead to infinite recursion when
  37           ;; TYPEP fails.
  38           (when (typep condition break-on-signals)
  39             (setf bos-actually-breaking t)
  40             (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~
  41                     (now rebound to NIL)."
  42                    condition)))
  43       ;; Give the user a chance to unset *BREAK-ON-SIGNALS* on the
  44       ;; way out.
  45       ;;
  46       ;; (e.g.: Consider a long compilation. After a failed compile
  47       ;; the user sets *BREAK-ON-SIGNALS* to T, and select the
  48       ;; RECOMPILE restart. Once the user diagnoses and fixes the
  49       ;; problem, he selects RECOMPILE again... and discovers that
  50       ;; he's entered the *BREAK-ON-SIGNALS* hell with no escape,
  51       ;; unless we provide this restart.)
  52       (reassign (new-value)
  53         :report
  54         (lambda (stream)
  55           (format stream
  56                   (if bos-actually-breaking
  57                     "Return from BREAK and assign a new value to ~
  58                      *BREAK-ON-SIGNALS*."
  59                     "Assign a new value to *BREAK-ON-SIGNALS* and ~
  60                      continue with signal handling.")))
  61         :interactive
  62         (lambda ()
  63           (let (new-value)
  64             (loop
  65              (format *query-io*
  66                      "Enter new value for *BREAK-ON-SIGNALS*. ~
  67                       Current value is ~S.~%~
  68                       > "
  69                      old-bos)
  70              (force-output *query-io*)
  71              (let ((*break-on-signals* nil))
  72                (setf new-value (eval (read *query-io*)))
  73                (if (typep new-value 'type-specifier)
  74                    (return)
  75                    (format *query-io*
  76                            "~S is not a valid value for *BREAK-ON-SIGNALS* ~
  77                             (must be a type-specifier).~%"
  78                            new-value))))
  79             (list new-value)))
  80         (setf *break-on-signals* new-value)))
  81     (loop
  82       (unless *handler-clusters*
  83         (return))
  84       (let ((cluster (pop *handler-clusters*)))
  85         (dolist (handler cluster)
  86           (when (typep condition (car handler))
  87             (funcall (cdr handler) condition)))))
  88     nil))
  89
  90 ;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably
  91 ;;; doesn't want to hear that the error "occurred in" one of these
  92 ;;; functions, so we try to point the top of the stack to our caller
  93 ;;; instead.
  94 (eval-when (:compile-toplevel :execute)
  95   (defmacro-mundanely maybe-find-stack-top-hint ()
  96     `(or sb!debug:*stack-top-hint*
  97          (nth-value 1 (find-caller-name-and-frame)))))
  98
  99 (defun error (datum &rest arguments)
 100   #!+sb-doc
 101   "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
 102   If the condition is not handled, the debugger is invoked."
 103   (/show0 "entering ERROR, argument list=..")
 104   (/hexstr arguments)
 105
 106   (/show0 "cold-printing ERROR arguments one by one..")
 107   #!+sb-show (dolist (argument arguments)
 108                (sb!impl::cold-print argument))
 109   (/show0 "done cold-printing ERROR arguments")
 110
 111   (infinite-error-protect
 112     (let ((condition (coerce-to-condition datum arguments
 113                                           'simple-error 'error))
 114           (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
 115       (/show0 "done coercing DATUM to CONDITION")
 116       (let ((sb!debug:*stack-top-hint* nil))
 117         (/show0 "signalling CONDITION from within ERROR")
 118         (signal condition))
 119       (/show0 "done signalling CONDITION within ERROR")
 120       (invoke-debugger condition))))
 121
 122 (defun cerror (continue-string datum &rest arguments)
 123   (infinite-error-protect
 124     (with-simple-restart
 125         (continue "~A" (apply #'format nil continue-string arguments))
 126       (let ((condition (coerce-to-condition datum
 127                                             arguments
 128                                             'simple-error
 129                                             'cerror))
 130             (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
 131         (with-condition-restarts condition (list (find-restart 'continue))
 132           (let ((sb!debug:*stack-top-hint* nil))
 133             (signal condition))
 134           (invoke-debugger condition)))))
 135   nil)
 136
 137 ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
 138 ;;; we can use it in system code (e.g. in SIGINT handling) without
 139 ;;; messing up --disable-debugger mode (which works by setting
 140 ;;; *DEBUGGER-HOOK*); or for that matter, without messing up ordinary
 141 ;;; applications which try to do similar things with *DEBUGGER-HOOK*
 142 (defun %break (what &optional (datum "break") &rest arguments)
 143   (infinite-error-protect
 144     (with-simple-restart (continue "Return from ~S." what)
 145       (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
 146         (invoke-debugger
 147          (coerce-to-condition datum arguments 'simple-condition what)))))
 148   nil)
 149
 150 (defun break (&optional (datum "break") &rest arguments)
 151   #!+sb-doc
 152   "Print a message and invoke the debugger without allowing any possibility
 153    of condition handling occurring."
 154   (let ((*debugger-hook* nil)) ; as specifically required by ANSI
 155     (apply #'%break 'break datum arguments)))
 156
 157 (defun warn (datum &rest arguments)
 158   #!+sb-doc
 159   "Warn about a situation by signalling a condition formed by DATUM and
 160    ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
 161    exists that causes WARN to immediately return NIL."
 162   (/show0 "entering WARN")
 163   ;; KLUDGE: The current cold load initialization logic causes several calls
 164   ;; to WARN, so we need to be able to handle them without dying. (And calling
 165   ;; FORMAT or even PRINC in cold load is a good way to die.) Of course, the
 166   ;; ideal would be to clean up cold load so that it doesn't call WARN..
 167   ;; -- WHN 19991009
 168   (if (not *cold-init-complete-p*)
 169       (progn
 170         (/show0 "ignoring WARN in cold init, arguments=..")
 171         #!+sb-show (dolist (argument arguments)
 172                      (sb!impl::cold-print argument)))
 173       (infinite-error-protect
 174        (/show0 "doing COERCE-TO-CONDITION")
 175        (let ((condition (coerce-to-condition datum arguments
 176                                              'simple-warning 'warn)))
 177          (/show0 "back from COERCE-TO-CONDITION, doing ENFORCE-TYPE")
 178          (enforce-type condition warning)
 179          (/show0 "back from ENFORCE-TYPE, doing RESTART-CASE MUFFLE-WARNING")
 180          (restart-case (signal condition)
 181            (muffle-warning ()
 182              :report "Skip warning."
 183              (return-from warn nil)))
 184          (/show0 "back from RESTART-CASE MUFFLE-WARNING (i.e. normal return)")
 185
 186          (let ((badness (etypecase condition
 187                           (style-warning 'style-warning)
 188                           (warning 'warning))))
 189            (/show0 "got BADNESS, calling FORMAT")
 190            (format *error-output*
 191                    "~&~@<~S: ~3i~:_~A~:>~%"
 192                    badness
 193                    condition)
 194            (/show0 "back from FORMAT, voila!")))))
 195   nil)