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