src/code/cold-error.lisp

   1 ;;;; miscellaneous stuff that needs to be in the cold load which would
   2 ;;;; otherwise be byte-compiled
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!CONDITIONS")
  14
  15 (sb!int:file-comment
  16   "$Header$")
  17
  18 (defvar *break-on-signals* nil
  19   #!+sb-doc
  20   "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will
  21    enter the debugger prior to signalling that condition.")
  22
  23 (defun signal (datum &rest arguments)
  24   #!+sb-doc
  25   "Invokes the signal facility on a condition formed from DATUM and
  26    ARGUMENTS. If the condition is not handled, NIL is returned. If
  27    (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
  28    before any signalling is done."
  29   (let ((condition (coerce-to-condition datum
  30                                         arguments
  31                                         'simple-condition
  32                                         'signal))
  33         (*handler-clusters* *handler-clusters*))
  34     (let ((old-bos *break-on-signals*)
  35           (*break-on-signals* nil))
  36       (when (typep condition old-bos)
  37         (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* (now NIL)."
  38                condition)))
  39     (loop
  40       (unless *handler-clusters* (return))
  41       (let ((cluster (pop *handler-clusters*)))
  42         (dolist (handler cluster)
  43           (when (typep condition (car handler))
  44             (funcall (cdr handler) condition)))))
  45     nil))
  46
  47 ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
  48 ;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
  49 ;;; argument that's directly usable by all the other routines.
  50 (defun coerce-to-condition (datum arguments default-type function-name)
  51   (cond ((typep datum 'condition)
  52          (if arguments
  53              (cerror "Ignore the additional arguments."
  54                      'simple-type-error
  55                      :datum arguments
  56                      :expected-type 'null
  57                      :format-control "You may not supply additional arguments ~
  58                                      when giving ~S to ~S."
  59                      :format-arguments (list datum function-name)))
  60          datum)
  61         ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
  62          (apply #'make-condition datum arguments))
  63         ((or (stringp datum) (functionp datum))
  64          (make-condition default-type
  65                          :format-control datum
  66                          :format-arguments arguments))
  67         (t
  68          (error 'simple-type-error
  69                 :datum datum
  70                 :expected-type '(or symbol string)
  71                 :format-control "bad argument to ~S: ~S"
  72                 :format-arguments (list function-name datum)))))
  73
  74 (defun error (datum &rest arguments)
  75   #!+sb-doc
  76   "Invoke the signal facility on a condition formed from datum and arguments.
  77    If the condition is not handled, the debugger is invoked."
  78   (/show0 "entering ERROR")
  79   #!+sb-show
  80   (unless *cold-init-complete-p*
  81     (/show0 "ERROR in cold init, arguments=..")
  82     #!+sb-show (dolist (argument arguments)
  83                  (sb!impl::cold-print argument)))
  84   (sb!kernel:infinite-error-protect
  85     (let ((condition (coerce-to-condition datum arguments
  86                                           'simple-error 'error))
  87           ;; FIXME: Why is *STACK-TOP-HINT* in SB-DEBUG instead of SB-DI?
  88           ;; SB-DEBUG should probably be only for true interface stuff.
  89           (sb!debug:*stack-top-hint* sb!debug:*stack-top-hint*))
  90       (unless (and (condition-function-name condition)
  91                    sb!debug:*stack-top-hint*)
  92         (multiple-value-bind (name frame) (sb!kernel:find-caller-name)
  93           (unless (condition-function-name condition)
  94             (setf (condition-function-name condition) name))
  95           (unless sb!debug:*stack-top-hint*
  96             (setf sb!debug:*stack-top-hint* frame))))
  97       (let ((sb!debug:*stack-top-hint* nil))
  98         (signal condition))
  99       (invoke-debugger condition))))
 100
 101 (defun cerror (continue-string datum &rest arguments)
 102   (sb!kernel:infinite-error-protect
 103     (with-simple-restart
 104         (continue "~A" (apply #'format nil continue-string arguments))
 105       (let ((condition (if (typep datum 'condition)
 106                            datum
 107                            (coerce-to-condition datum
 108                                                 arguments
 109                                                 'simple-error
 110                                                 'error)))
 111             (sb!debug:*stack-top-hint* sb!debug:*stack-top-hint*))
 112         (unless (and (condition-function-name condition)
 113                      sb!debug:*stack-top-hint*)
 114           (multiple-value-bind (name frame) (sb!kernel:find-caller-name)
 115             (unless (condition-function-name condition)
 116               (setf (condition-function-name condition) name))
 117             (unless sb!debug:*stack-top-hint*
 118               (setf sb!debug:*stack-top-hint* frame))))
 119         (with-condition-restarts condition (list (find-restart 'continue))
 120           (let ((sb!debug:*stack-top-hint* nil))
 121             (signal condition))
 122           (invoke-debugger condition)))))
 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   (sb!kernel:infinite-error-protect
 130     (with-simple-restart (continue "Return from BREAK.")
 131       (let ((sb!debug:*stack-top-hint*
 132              (or sb!debug:*stack-top-hint*
 133                  (nth-value 1 (sb!kernel:find-caller-name)))))
 134         (invoke-debugger
 135          (coerce-to-condition datum arguments 'simple-condition 'break)))))
 136   nil)
 137
 138 (defun warn (datum &rest arguments)
 139   #!+sb-doc
 140   "Warn about a situation by signalling a condition formed by DATUM and
 141    ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
 142    exists that causes WARN to immediately return NIL."
 143   (/noshow0 "entering WARN")
 144   ;; KLUDGE: The current cold load initialization logic causes several calls
 145   ;; to WARN, so we need to be able to handle them without dying. (And calling
 146   ;; FORMAT or even PRINC in cold load is a good way to die.) Of course, the
 147   ;; ideal would be to clean up cold load so that it doesn't call WARN..
 148   ;; -- WHN 19991009
 149   (if (not *cold-init-complete-p*)
 150       (progn
 151         (/show0 "ignoring WARN in cold init, arguments=..")
 152         #!+sb-show (dolist (argument arguments)
 153                      (sb!impl::cold-print argument)))
 154       (sb!kernel:infinite-error-protect
 155        (let ((condition (coerce-to-condition datum arguments
 156                                              'simple-warning 'warn)))
 157          (check-type condition warning "a warning condition")
 158          (restart-case (signal condition)
 159            (muffle-warning ()
 160              :report "Skip warning."
 161              (return-from warn nil)))
 162          (let ((badness (etypecase condition
 163                           (style-warning 'style-warning)
 164                           (warning 'warning))))
 165            (format *error-output*
 166                    "~&~@<~S: ~3i~:_~A~:>~%"
 167                    badness
 168                    condition)))))
 169   nil)