563
|
1
|
;;; condition.lisp --- Conditions and other exception handlers |
|
2
|
|
|
3
|
;;; Code: |
|
4
|
(in-package :std/condition) |
|
5
|
|
|
6
|
(defvar *std-error-message* "An error occured") |
|
7
|
|
|
8
|
(define-condition std-error (error) |
|
9
|
((message :initarg :message |
|
10
|
:initform *std-error-message* |
|
11
|
:reader std-error-message)) |
645
|
12
|
(:documentation "Standard Error") |
563
|
13
|
(:report (lambda (condition stream) |
|
14
|
(format stream "~X" (std-error-message condition))))) |
|
15
|
|
|
16
|
(defun std-error (&rest args) |
|
17
|
(cerror |
|
18
|
"Ignore and continue" |
|
19
|
'std-error |
|
20
|
:message (format nil "~A: ~A" *std-error-message* args))) |
|
21
|
|
645
|
22
|
(define-condition std-warning (warning) |
|
23
|
((message :initarg :message |
|
24
|
:initform nil |
|
25
|
:reader std-warning-message)) |
|
26
|
(:documentation "Standard Warning") |
|
27
|
(:report |
|
28
|
(lambda (condition stream) |
|
29
|
(when (std-warning-message condition) |
|
30
|
(format stream "~X" (std-warning-message condition)))))) |
|
31
|
|
|
32
|
(defun std-warning (&optional message) |
|
33
|
(warn 'std-warning :message message)) |
|
34
|
|
563
|
35
|
(defun car-eql (a cons) |
|
36
|
(eql a (car cons))) |
|
37
|
|
|
38
|
(defmacro deferror (name (&rest parent-types) (&rest slot-specs) &rest options) |
|
39
|
"Define an error condition." |
|
40
|
(let ((fun (member :auto options :test #'car-eql))) |
|
41
|
(when fun (setq options (remove (car fun) options))) |
|
42
|
`(prog1 |
|
43
|
(define-condition ,name ,(or parent-types '(std-error)) ,slot-specs ,@options) |
645
|
44
|
(when ',fun |
|
45
|
(if (member 'simple-error ',parent-types) |
|
46
|
(def-simple-error-reporter ,name) |
|
47
|
(def-error-reporter ,name)))))) |
563
|
48
|
|
|
49
|
(defmacro def-error-reporter (err) |
|
50
|
`(defun ,err (&rest args) |
|
51
|
,(format nil "Signal an error of type ~A with ARGS." err) |
|
52
|
(cerror |
|
53
|
"Ignore and continue" |
|
54
|
',err |
645
|
55
|
:message (format nil "~A: ~A" ,*std-error-message* args)))) |
|
56
|
|
|
57
|
(defmacro def-simple-error-reporter (name) |
|
58
|
`(progn |
|
59
|
(defun ,name (fmt &rest args) |
|
60
|
,(format nil "Signal an error of type ~A with FMT string and ARGS." name) |
|
61
|
(cerror |
|
62
|
"Ignore and continue" |
|
63
|
',name |
|
64
|
:format-control fmt |
|
65
|
:format-arguments args)))) |
|
66
|
|
|
67
|
(defmacro defwarning (name (&rest parent-types) (&rest slot-specs) &rest options) |
|
68
|
"Define an warning condition." |
|
69
|
(let ((fun (member :auto options :test #'car-eql))) |
|
70
|
(when fun (setq options (remove (car fun) options))) |
|
71
|
`(prog1 |
|
72
|
(eval-when (:compile-toplevel :load-toplevel :execute) |
|
73
|
(define-condition ,name ,(or parent-types '(std-warning)) ,slot-specs ,@options)) |
|
74
|
(when ',fun |
|
75
|
(if (member 'simple-warning ',parent-types) |
|
76
|
(def-simple-warning-reporter ,name) |
|
77
|
(def-warning-reporter ,name)))))) |
|
78
|
|
|
79
|
(defmacro def-warning-reporter (name) |
|
80
|
`(defun ,name (&optional message) |
|
81
|
,(format nil "Signal a warning of type ~A with optional MESSAGE." name) |
|
82
|
(warn |
|
83
|
',name |
|
84
|
:message message))) |
|
85
|
|
|
86
|
(defmacro def-simple-warning-reporter (name) |
|
87
|
`(defun ,name (fmt &rest args) |
|
88
|
,(format nil "Signal an error of type ~A with FMT string and ARGS." name) |
|
89
|
(warn |
|
90
|
',name |
|
91
|
:format-control fmt |
|
92
|
:format-arguments args))) |
563
|
93
|
|
|
94
|
(defmacro nyi! (&optional comment) |
|
95
|
`(prog1 |
|
96
|
(error "Not Yet Implemented!") |
|
97
|
(when ',comment (print ',comment)))) |
|
98
|
|
|
99
|
(defun required-argument (&optional name) |
|
100
|
"Signals an error for a missing argument of NAME. Intended for |
|
101
|
use as an initialization form for structure and class-slots, and |
|
102
|
a default value for required keyword arguments." |
|
103
|
(error "Required argument ~@[~S ~]missing." name)) |
|
104
|
|
|
105
|
(define-condition simple-style-warning (simple-warning style-warning) |
|
106
|
()) |
|
107
|
|
|
108
|
(defun simple-style-warning (message &rest args) |
|
109
|
(warn 'simple-style-warning :format-control message :format-arguments args)) |
|
110
|
|
|
111
|
;; We don't specify a :report for simple-reader-error to let the |
|
112
|
;; underlying implementation report the line and column position for |
|
113
|
;; us. Unfortunately this way the message from simple-error is not |
|
114
|
;; displayed, unless there's special support for that in the |
|
115
|
;; implementation. But even then it's still inspectable from the |
|
116
|
;; debugger... |
|
117
|
(define-condition simple-reader-error |
|
118
|
(sb-int:simple-reader-error) |
|
119
|
()) |
|
120
|
|
|
121
|
(defun simple-reader-error (stream message &rest args) |
|
122
|
(error 'simple-reader-error |
|
123
|
:stream stream |
|
124
|
:format-control message |
|
125
|
:format-arguments args)) |
|
126
|
|
|
127
|
(define-condition simple-parse-error (simple-error parse-error) |
|
128
|
()) |
|
129
|
|
|
130
|
(defun simple-parse-error (message &rest args) |
|
131
|
(error 'simple-parse-error |
|
132
|
:format-control message |
|
133
|
:format-arguments args)) |
|
134
|
|
|
135
|
(define-condition simple-program-error (simple-error program-error) |
|
136
|
()) |
|
137
|
|
|
138
|
(defun simple-program-error (message &rest args) |
|
139
|
(error 'simple-program-error |
|
140
|
:format-control message |
|
141
|
:format-arguments args)) |
|
142
|
|
|
143
|
(define-condition circular-dependency (simple-error) |
|
144
|
((items |
|
145
|
:initarg :items |
|
146
|
:initform (error "Must specify items") |
|
147
|
:reader circular-dependency-items)) |
|
148
|
(:report (lambda (condition stream) |
|
149
|
(declare (ignore condition)) |
|
150
|
(format stream "Circular dependency detected"))) |
|
151
|
(:documentation "A condition which is signalled when a circular dependency is encountered.")) |
|
152
|
|
|
153
|
(define-condition unknown-argument (error) |
|
154
|
((name |
|
155
|
:initarg :name |
|
156
|
:initform (error "Must specify argument name") |
|
157
|
:reader unknown-argument-name) |
|
158
|
(kind |
|
159
|
:initarg :kind |
|
160
|
:initform (error "Must specify argument kind") |
|
161
|
:reader unknown-argument-kind)) |
|
162
|
(:report (lambda (condition stream) |
|
163
|
(format stream "Unknown argument ~A of kind ~A" |
|
164
|
(unknown-argument-name condition) |
|
165
|
(unknown-argument-kind condition)))) |
|
166
|
(:documentation "A condition which is signalled when an unknown argument is encountered.")) |
|
167
|
|
|
168
|
(defun unknown-argument-p (value) |
|
169
|
(typep value 'unknown-argument)) |
|
170
|
|
|
171
|
(define-condition missing-argument (simple-error) |
|
172
|
((item |
|
173
|
:initarg :item |
|
174
|
:initform (error "Must specify argument item") |
|
175
|
:reader missing-argument-item) |
|
176
|
(command |
|
177
|
:initarg :command |
|
178
|
:initform (error "Must specify command") |
|
179
|
:reader missing-argument-command)) |
|
180
|
(:report (lambda (condition stream) |
|
181
|
(declare (ignore condition)) |
|
182
|
(format stream "Missing argument"))) |
|
183
|
(:documentation "A condition which is signalled when an option expects an argument, but none was provided")) |
|
184
|
|
|
185
|
(defun missing-argument-p (value) |
|
186
|
(typep value 'missing-argument)) |
|
187
|
|
|
188
|
(define-condition invalid-argument (simple-error) |
|
189
|
((item |
|
190
|
:initarg :item |
|
191
|
:initform (error "Must specify argument item") |
|
192
|
:reader invalid-argument-item |
|
193
|
:documentation "The argument which is identified as invalid") |
|
194
|
(reason |
|
195
|
:initarg :reason |
|
196
|
:initform (error "Must specify reason") |
|
197
|
:reader invalid-argument-reason |
|
198
|
:documentation "The reason why this argument is invalid")) |
|
199
|
(:report (lambda (condition stream) |
|
200
|
(format stream "Invalid argument: ~A~%Reason: ~A" (invalid-argument-item condition) (invalid-argument-reason condition)))) |
|
201
|
(:documentation "A condition which is signalled when an argument is identified as invalid.")) |
|
202
|
|
|
203
|
(defmacro ignore-some-conditions ((&rest conditions) &body body) |
|
204
|
"Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS |
|
205
|
list determines which specific conditions are to be ignored." |
|
206
|
`(handler-case |
|
207
|
(progn ,@body) |
|
208
|
,@(loop for condition in conditions collect |
|
209
|
`(,condition (c) (values nil c))))) |
|
210
|
|
|
211
|
(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses) |
|
212
|
"Like CL:UNWIND-PROTECT, but you can specify the circumstances that |
|
213
|
the cleanup CLAUSES are run. |
|
214
|
|
|
215
|
clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)* |
|
216
|
|
|
217
|
Clauses can be given in any order, and more than one clause can be |
|
218
|
given for each circumstance. The clauses whose denoted circumstance |
|
219
|
occured, are executed in the order the clauses appear. |
|
220
|
|
|
221
|
ABORT-FLAG is the name of a variable that will be bound to T in |
|
222
|
CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL |
|
223
|
otherwise. |
|
224
|
|
|
225
|
Examples: |
|
226
|
|
|
227
|
(unwind-protect-case () |
|
228
|
(protected-form) |
|
229
|
(:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\")) |
|
230
|
(:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\")) |
|
231
|
(:always (format t \"This is evaluated in either case.~%\"))) |
|
232
|
|
|
233
|
(unwind-protect-case (aborted-p) |
|
234
|
(protected-form) |
|
235
|
(:always (perform-cleanup-if aborted-p))) |
|
236
|
" |
|
237
|
(check-type abort-flag (or null symbol)) |
|
238
|
(let ((gflag (gensym "FLAG+"))) |
|
239
|
`(let ((,gflag t)) |
|
240
|
(unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil)) |
|
241
|
(let ,(and abort-flag `((,abort-flag ,gflag))) |
|
242
|
,@(loop for (cleanup-kind . forms) in clauses |
|
243
|
collect (ecase cleanup-kind |
|
244
|
(:normal `(when (not ,gflag) ,@forms)) |
|
245
|
(:abort `(when ,gflag ,@forms)) |
|
246
|
(:always `(progn ,@forms))))))))) |