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   (/noshow0 "entering SIGNAL")
  26   (let ((condition (coerce-to-condition datum
  27                                         arguments
  28                                         'simple-condition
  29                                         'signal))
  30         (*handler-clusters* *handler-clusters*))
  31     (let ((old-bos *break-on-signals*)
  32           (*break-on-signals* nil))
  33       (when (typep condition old-bos)
  34         (/noshow0 "doing BREAK in because of *BREAK-ON-SIGNALS*")
  35         (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* (now rebound to NIL)."
  36                condition)))
  37     (loop
  38       (unless *handler-clusters*
  39         (/noshow0 "leaving LOOP because of unbound *HANDLER-CLUSTERS*")
  40         (return))
  41       (let ((cluster (pop *handler-clusters*)))
  42         (/noshow0 "got CLUSTER=..")
  43         (/nohexstr cluster)
  44         (dolist (handler cluster)
  45           (/noshow0 "looking at HANDLER=..")
  46           (/nohexstr handler)
  47           (when (typep condition (car handler))
  48             (funcall (cdr handler) condition)))))
  49
  50     (/noshow0 "returning from SIGNAL")
  51     nil))
  52
  53 ;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably
  54 ;;; doesn't want to hear that the error "occurred in" one of these
  55 ;;; functions, so we try to point the top of the stack to our caller
  56 ;;; instead.
  57 (eval-when (:compile-toplevel :execute)
  58   (defmacro-mundanely maybe-find-stack-top-hint ()
  59     `(or sb!debug:*stack-top-hint*
  60          (nth-value 1 (find-caller-name-and-frame)))))
  61
  62 (defun error (datum &rest arguments)
  63   #!+sb-doc
  64   "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
  65   If the condition is not handled, the debugger is invoked."
  66   (/show0 "entering ERROR, argument list=..")
  67   (/hexstr arguments)
  68
  69   (/show0 "cold-printing ERROR arguments one by one..")
  70   #!+sb-show (dolist (argument arguments)
  71                (sb!impl::cold-print argument))
  72   (/show0 "done cold-printing ERROR arguments")
  73
  74   (infinite-error-protect
  75     (let ((condition (coerce-to-condition datum arguments
  76                                           'simple-error 'error))
  77           (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
  78       (/show0 "done coercing DATUM to CONDITION")
  79       (let ((sb!debug:*stack-top-hint* nil))
  80         (/show0 "signalling CONDITION from within ERROR")
  81         (signal condition))
  82       (/show0 "done signalling CONDITION within ERROR")
  83       (invoke-debugger condition))))
  84
  85 (defun cerror (continue-string datum &rest arguments)
  86   (infinite-error-protect
  87     (with-simple-restart
  88         (continue "~A" (apply #'format nil continue-string arguments))
  89       (let ((condition (coerce-to-condition datum
  90                                             arguments
  91                                             'simple-error
  92                                             'error))
  93             (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
  94         (with-condition-restarts condition (list (find-restart 'continue))
  95           (let ((sb!debug:*stack-top-hint* nil))
  96             (signal condition))
  97           (invoke-debugger condition)))))
  98   nil)
  99
 100 ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
 101 ;;; we can use it in system code (e.g. in SIGINT handling) without
 102 ;;; messing up --disable-debugger mode (which works by setting
 103 ;;; *DEBUGGER-HOOK*); or for that matter, without messing up ordinary
 104 ;;; applications which try to do similar things with *DEBUGGER-HOOK*
 105 (defun %break (what &optional (datum "break") &rest arguments)
 106   (infinite-error-protect
 107     (with-simple-restart (continue "Return from ~S." what)
 108       (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
 109         (invoke-debugger
 110          (coerce-to-condition datum arguments 'simple-condition what)))))
 111   nil)
 112
 113 (defun break (&optional (datum "break") &rest arguments)
 114   #!+sb-doc
 115   "Print a message and invoke the debugger without allowing any possibility
 116    of condition handling occurring."
 117   (let ((*debugger-hook* nil)) ; as specifically required by ANSI
 118     (apply #'%break 'break datum arguments)))
 119
 120 (defun warn (datum &rest arguments)
 121   #!+sb-doc
 122   "Warn about a situation by signalling a condition formed by DATUM and
 123    ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
 124    exists that causes WARN to immediately return NIL."
 125   (/show0 "entering WARN")
 126   ;; KLUDGE: The current cold load initialization logic causes several calls
 127   ;; to WARN, so we need to be able to handle them without dying. (And calling
 128   ;; FORMAT or even PRINC in cold load is a good way to die.) Of course, the
 129   ;; ideal would be to clean up cold load so that it doesn't call WARN..
 130   ;; -- WHN 19991009
 131   (if (not *cold-init-complete-p*)
 132       (progn
 133         (/show0 "ignoring WARN in cold init, arguments=..")
 134         #!+sb-show (dolist (argument arguments)
 135                      (sb!impl::cold-print argument)))
 136       (infinite-error-protect
 137        (/show0 "doing COERCE-TO-CONDITION")
 138        (let ((condition (coerce-to-condition datum arguments
 139                                              'simple-warning 'warn)))
 140          (/show0 "back from COERCE-TO-CONDITION, doing ENFORCE-TYPE")
 141          (enforce-type condition warning)
 142          (/show0 "back from ENFORCE-TYPE, doing RESTART-CASE MUFFLE-WARNING")
 143          (restart-case (signal condition)
 144            (muffle-warning ()
 145              :report "Skip warning."
 146              (return-from warn nil)))
 147          (/show0 "back from RESTART-CASE MUFFLE-WARNING (i.e. normal return)")
 148
 149          (let ((badness (etypecase condition
 150                           (style-warning 'style-warning)
 151                           (warning 'warning))))
 152            (/show0 "got BADNESS, calling FORMAT")
 153            (format *error-output*
 154                    "~&~@<~S: ~3i~:_~A~:>~%"
 155                    badness
 156                    condition)
 157            (/show0 "back from FORMAT, voila!")))))
 158   nil)