0.8.12.18: Rearranging COMPILER-ERROR protocol
[sbcl.git] / 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 (encapsulated-condition program-error)
74   ((source :initarg :source :reader program-error-source))
75   (:report (lambda (condition stream)
76              (let ((source (program-error-source condition)))
77                ;; Source may be either a list or string, and
78                ;; string needs to be printed without escapes.
79                (format stream "Execution of a form compiled with errors.~%~
80                                Form:~%  ~
81                                ~:[~S~;~A~]~%~
82                                Compile-time-error:~%  "
83                        (stringp source) source)
84                (print-object (encapsulated-condition condition) stream)))))
85
86 (def!method make-load-form ((condition compiled-program-error) &optional env)
87   (let ((source (program-error-source condition)))
88     ;; Safe since the encapsulated condition shouldn't contain
89     ;; references back up to the main condition. The source needs to
90     ;; be converted to a string, since it may contain arbitrary
91     ;; unexternalizable objects.
92     `(make-condition 'compiled-program-error
93                      :condition ,(make-condition-load-form
94                                   (encapsulated-condition condition) env)
95                      :source ,(if (stringp source)
96                                   source
97                                   (write-to-string
98                                    source :pretty t :circle t :escape t :readably nil)))))
99
100 (define-condition make-load-form-error (encapsulated-condition error)
101   ((object :initarg :object :reader make-load-form-error-object))
102   (:report (lambda (condition stream)
103              (let ((object (make-load-form-error-object condition)))
104                ;; If the MAKE-LOAD-FORM-ERROR itself has been
105                ;; externalized, the object will only have it's string
106                ;; representation.
107                (format stream "~@<Unable to externalize ~:[~S~;~A~], ~
108                               error from ~S:~:@>~%  "
109                        (stringp object)
110                        object
111                        'make-load-form)
112                (print-object (encapsulated-condition condition) stream)))))
113
114 (def!method make-load-form ((condition make-load-form-error) &optional env)
115   (let ((object (make-load-form-error-object condition)))
116     ;; Safe, because neither the object nor the encapsulated condition
117     ;; should contain any references to the error itself. However, the
118     ;; object will need to be converted to its string representation,
119     ;; since the chances are that it's not externalizable.
120     `(make-condition 'make-load-form-error
121                      :condition ,(make-condition-load-form
122                                   (encapsulated-condition condition) env)
123                      :object ,(if (stringp object)
124                                   object
125                                   (write-to-string
126                                    object :pretty t :circle t :escape t :readably nil)))))
127
128 (define-condition simple-control-error (simple-condition control-error) ())
129 (define-condition simple-file-error    (simple-condition file-error)    ())
130 (define-condition simple-program-error (simple-condition program-error) ())
131 (define-condition simple-stream-error  (simple-condition stream-error)  ())
132 (define-condition simple-parse-error   (simple-condition parse-error)   ())
133
134 (define-condition control-stack-exhausted (storage-condition)
135   ()
136   (:report
137     (lambda (condition stream)
138       (declare (ignore condition))
139       (format stream
140              "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."))))
141