src/code/error.lisp

   1 ;;;; SBCL-specific parts of the condition system, i.e. parts which
   2 ;;;; don't duplicate/clobber functionality already provided by the
   3 ;;;; cross-compilation host Common Lisp
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; This software is derived from the CMU CL system, which was
   9 ;;;; written at Carnegie Mellon University and released into the
  10 ;;;; public domain. The software is in the public domain and is
  11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  12 ;;;; files for more information.
  13
  14 (in-package "SB!KERNEL")
  15
  16 ;;; a utility for SIGNAL, ERROR, CERROR, WARN, COMPILER-NOTIFY and
  17 ;;; INVOKE-DEBUGGER: Parse the hairy argument conventions into a
  18 ;;; single argument that's directly usable by all the other routines.
  19 (defun coerce-to-condition (datum default-type fun-name &rest arguments)
  20   (declare (explicit-check)
  21            (dynamic-extent arguments))
  22   (cond ((and (%instancep datum)
  23               (let ((layout (%instance-layout datum)))
  24                 (logtest +condition-layout-flag+ (layout-%flags layout))
  25                 ;; An invalid layout will drop into the (MAKE-CONDITION) branch
  26                 ;; which rightly fails because ALLOCATE-CONDITION asserts that
  27                 ;; the first argument is a condition-designator, which it won't be.
  28                 (not (layout-invalid layout))))
  29          (when (and arguments (not (eq fun-name 'cerror)))
  30            (cerror "Ignore the additional arguments."
  31                    'simple-type-error
  32                    :datum (copy-list arguments)
  33                    :expected-type 'null
  34                    :format-control "You may not supply additional arguments ~
  35                                     when giving ~S to ~S."
  36                    :format-arguments (list datum fun-name)))
  37          datum)
  38         ((or (stringp datum) (functionp datum))
  39          (make-condition default-type
  40                          :format-control datum
  41                          :format-arguments (copy-list arguments)))
  42         (t
  43          (apply #'make-condition datum arguments))))
  44
  45 ;;; This condition inherits from the hosts's classes when compiling
  46 ;;; the cross-compiler and the target's when cross-compiling.
  47 (define-condition simple-program-error (simple-condition program-error) ())
  48 (defun %program-error (&optional datum &rest arguments)
  49   (error (apply #'coerce-to-condition datum
  50                 'simple-program-error '%program-error arguments)))