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 ;;; not sure this is the right place, but where else?
  17 (defun style-warn (format-control &rest format-arguments)
  18   (/show0 "entering STYLE-WARN")
  19   (/show format-control format-arguments)
  20   (warn 'simple-style-warning
  21         :format-control format-control
  22         :format-arguments format-arguments))
  23
  24 ;;; a utility for SIGNAL, ERROR, CERROR, WARN, COMPILER-NOTIFY and
  25 ;;; INVOKE-DEBUGGER: Parse the hairy argument conventions into a
  26 ;;; single argument that's directly usable by all the other routines.
  27 (defun coerce-to-condition (datum arguments default-type fun-name)
  28   (cond ((typep datum 'condition)
  29          (if arguments
  30              (cerror "Ignore the additional arguments."
  31                      'simple-type-error
  32                      :datum 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         ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
  39          (apply #'make-condition datum arguments))
  40         ((or (stringp datum) (functionp datum))
  41          (make-condition default-type
  42                          :format-control datum
  43                          :format-arguments arguments))
  44         (t
  45          (error 'simple-type-error
  46                 :datum datum
  47                 :expected-type '(or symbol string)
  48                 :format-control "bad argument to ~S: ~S"
  49                 :format-arguments (list fun-name datum)))))
  50
  51 (define-condition layout-invalid (type-error)
  52   ()
  53   (:report
  54    (lambda (condition stream)
  55      (format stream
  56              "~@<invalid structure layout: ~
  57               ~2I~_A test for class ~4I~_~S ~
  58               ~2I~_was passed the obsolete instance ~4I~_~S~:>"
  59              (classoid-proper-name (type-error-expected-type condition))
  60              (type-error-datum condition)))))
  61
  62 (define-condition case-failure (type-error)
  63   ((name :reader case-failure-name :initarg :name)
  64    (possibilities :reader case-failure-possibilities :initarg :possibilities))
  65   (:report
  66     (lambda (condition stream)
  67       (format stream "~@<~S fell through ~S expression. ~
  68                       ~:_Wanted one of ~:S.~:>"
  69               (type-error-datum condition)
  70               (case-failure-name condition)
  71               (case-failure-possibilities condition)))))
  72
  73 (define-condition compiled-program-error (program-error)
  74   ((message :initarg :message :reader program-error-message)
  75    (source :initarg :source :reader program-error-source))
  76   (:report (lambda (condition stream)
  77              (format stream "Execution of a form compiled with errors.~%~
  78                             Form:~%  ~A~%~
  79                             Compile-time-error:~%  ~A"
  80                        (program-error-source condition)
  81                        (program-error-message condition)))))
  82
  83 (define-condition simple-control-error (simple-condition control-error) ())
  84 (define-condition simple-file-error    (simple-condition file-error)    ())
  85 (define-condition simple-program-error (simple-condition program-error) ())
  86 (define-condition simple-stream-error  (simple-condition stream-error)  ())
  87 (define-condition simple-parse-error   (simple-condition parse-error)   ())
  88
  89 (define-condition control-stack-exhausted (storage-condition)
  90   ()
  91   (:report
  92     (lambda (condition stream)
  93       (declare (ignore condition))
  94       (format stream
  95              "Control stack exhausted (no more space for function call frames).  This is probably due to heavily nested or infinitely recursive function calls, or a tail call that SBCL cannot or has not optimized away."))))
  96