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 maybe-break-on-signal (condition)
  20   (let ((old-bos *break-on-signals*)
  21         (bos-actually-breaking nil))
  22     (restart-case
  23         (let ((break-on-signals *break-on-signals*)
  24               (*break-on-signals* nil))
  25           ;; The rebinding encloses the TYPEP so that a bogus
  26           ;; type specifier will not lead to infinite recursion when
  27           ;; TYPEP fails.
  28           (when (typep condition break-on-signals)
  29             (setf bos-actually-breaking t)
  30             (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~
  31                     (now rebound to NIL)."
  32                    condition)))
  33       ;; Give the user a chance to unset *BREAK-ON-SIGNALS* on the
  34       ;; way out.
  35       ;;
  36       ;; (e.g.: Consider a long compilation. After a failed compile
  37       ;; the user sets *BREAK-ON-SIGNALS* to T, and select the
  38       ;; RECOMPILE restart. Once the user diagnoses and fixes the
  39       ;; problem, he selects RECOMPILE again... and discovers that
  40       ;; he's entered the *BREAK-ON-SIGNALS* hell with no escape,
  41       ;; unless we provide this restart.)
  42       (reassign (new-value)
  43         :report
  44         (lambda (stream)
  45           (format stream
  46                   (if bos-actually-breaking
  47                       "Return from BREAK and assign a new value to ~
  48                        *BREAK-ON-SIGNALS*."
  49                       "Assign a new value to *BREAK-ON-SIGNALS* and ~
  50                        continue with signal handling.")))
  51         :interactive
  52         (lambda ()
  53           (let (new-value)
  54             (loop
  55               (format *query-io*
  56                       "Enter new value for *BREAK-ON-SIGNALS*. ~
  57                        Current value is ~S.~%~
  58                        > "
  59                       old-bos)
  60               (force-output *query-io*)
  61               (let ((*break-on-signals* nil))
  62                 (setf new-value (eval (read *query-io*)))
  63                 (if (typep new-value 'type-specifier)
  64                     (return)
  65                     (format *query-io*
  66                             "~S is not a valid value for *BREAK-ON-SIGNALS* ~
  67                              (must be a type-specifier).~%"
  68                             new-value))))
  69             (list new-value)))
  70         (setf *break-on-signals* new-value)))))
  71
  72 (defun signal (datum &rest arguments)
  73   #!+sb-doc
  74   "Invokes the signal facility on a condition formed from DATUM and
  75    ARGUMENTS. If the condition is not handled, NIL is returned. If
  76    (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
  77    before any signalling is done."
  78   (let ((condition (coerce-to-condition datum
  79                                         arguments
  80                                         'simple-condition
  81                                         'signal))
  82         (handler-clusters *handler-clusters*)
  83         (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'signal)))
  84     (when *break-on-signals*
  85       (maybe-break-on-signal condition))
  86     (do ((cluster (pop handler-clusters) (pop handler-clusters)))
  87         ((null cluster)
  88          nil)
  89       ;; Remove CLUSTER from *HANDLER-CLUSTERS*: if a condition is
  90       ;; signaled in either the type test, i.e. (the function (car
  91       ;; handler)), or the handler, (the function (cdr handler)), the
  92       ;; recursive SIGNAL call should not consider CLUSTER as doing
  93       ;; would lead to infinite recursive SIGNAL calls.
  94       (let ((*handler-clusters* handler-clusters))
  95         (dolist (handler cluster)
  96           (when (funcall (truly-the function (car handler)) condition)
  97             (funcall (cdr handler) condition)))))))
  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* (or sb!debug:*stack-top-hint* 'error)))
 115       (/show0 "done coercing DATUM to CONDITION")
 116       (/show0 "signalling CONDITION from within ERROR")
 117       (signal condition)
 118       (/show0 "done signalling CONDITION within ERROR")
 119       (invoke-debugger condition))))
 120
 121 (defun cerror (continue-string datum &rest arguments)
 122   (infinite-error-protect
 123     (with-simple-restart
 124         (continue "~A" (apply #'format nil continue-string arguments))
 125       (let ((condition (coerce-to-condition datum
 126                                             arguments
 127                                             'simple-error
 128                                             'cerror)))
 129         (with-condition-restarts condition (list (find-restart 'continue))
 130           (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'cerror)))
 131             (signal condition)
 132             (invoke-debugger condition))))))
 133   nil)
 134
 135 ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
 136 ;;; we can use it in system code (e.g. in SIGINT handling) without
 137 ;;; messing up --disable-debugger mode (which works by setting
 138 ;;; *DEBUGGER-HOOK*); or for that matter, without messing up ordinary
 139 ;;; applications which try to do similar things with *DEBUGGER-HOOK*
 140 (defun %break (what &optional (datum "break") &rest arguments)
 141   (infinite-error-protect
 142     (with-simple-restart (continue "Return from ~S." what)
 143       (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* '%break)))
 144         (invoke-debugger
 145          (coerce-to-condition datum arguments 'simple-condition what)))))
 146   nil)
 147
 148 (defun break (&optional (datum "break") &rest arguments)
 149   #!+sb-doc
 150   "Print a message and invoke the debugger without allowing any possibility
 151 of condition handling occurring."
 152   (let ((*debugger-hook* nil) ; as specifically required by ANSI
 153         (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'break)))
 154     (apply #'%break 'break datum arguments)))
 155
 156 (defun warn (datum &rest arguments)
 157   #!+sb-doc
 158   "Warn about a situation by signalling a condition formed by DATUM and
 159    ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
 160    exists that causes WARN to immediately return NIL."
 161   (/show0 "entering WARN")
 162   (infinite-error-protect
 163        (/show0 "doing COERCE-TO-CONDITION")
 164        (let ((condition (coerce-to-condition datum arguments
 165                                              'simple-warning 'warn)))
 166          (/show0 "back from COERCE-TO-CONDITION, doing ENFORCE-TYPE")
 167          (enforce-type condition warning)
 168          (/show0 "back from ENFORCE-TYPE, doing RESTART-CASE MUFFLE-WARNING")
 169          (restart-case (signal condition)
 170            (muffle-warning ()
 171              :report "Skip warning."
 172              (return-from warn nil)))
 173          (/show0 "back from RESTART-CASE MUFFLE-WARNING (i.e. normal return)")
 174
 175          (let ((badness (etypecase condition
 176                           (style-warning 'style-warning)
 177                           (warning 'warning))))
 178            (/show0 "got BADNESS, calling FORMAT")
 179            (format *error-output*
 180                    "~&~@<~S: ~3i~:_~A~:>~%"
 181                    badness
 182                    condition)
 183            (/show0 "back from FORMAT, voila!"))))
 184   nil)