changeset 646: | 95fd920af398 |
parent: | 3e6a17fb5712 |
child: | 5e8b1855f866 |
author: | Richard Westhaver <ellis@rwest.io> |
date: | Wed, 11 Sep 2024 18:08:29 -0400 |
permissions: | -rw-r--r-- |
description: | error handling methods for clap |
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") |
|
646
95fd920af398
error handling methods for clap
Richard Westhaver <ellis@rwest.io>
parents:
645
diff
changeset
|
175 | :reader missing-argument-item)) |
95fd920af398
error handling methods for clap
Richard Westhaver <ellis@rwest.io>
parents:
645
diff
changeset
|
176 | (:report (lambda (condition stream) |
95fd920af398
error handling methods for clap
Richard Westhaver <ellis@rwest.io>
parents:
645
diff
changeset
|
177 | (declare (ignore condition)) |
95fd920af398
error handling methods for clap
Richard Westhaver <ellis@rwest.io>
parents:
645
diff
changeset
|
178 | (format stream "Missing argument"))) |
95fd920af398
error handling methods for clap
Richard Westhaver <ellis@rwest.io>
parents:
645
diff
changeset
|
179 | (:documentation "A condition which is signalled when an option expects an argument, but none was provided")) |
563 | 180 | |
181 | (defun missing-argument-p (value) |
|
182 | (typep value 'missing-argument)) |
|
183 | ||
184 | (define-condition invalid-argument (simple-error) |
|
185 | ((item |
|
186 | :initarg :item |
|
187 | :initform (error "Must specify argument item") |
|
188 | :reader invalid-argument-item |
|
189 | :documentation "The argument which is identified as invalid") |
|
190 | (reason |
|
191 | :initarg :reason |
|
192 | :initform (error "Must specify reason") |
|
193 | :reader invalid-argument-reason |
|
194 | :documentation "The reason why this argument is invalid")) |
|
195 | (:report (lambda (condition stream) |
|
196 | (format stream "Invalid argument: ~A~%Reason: ~A" (invalid-argument-item condition) (invalid-argument-reason condition)))) |
|
197 | (:documentation "A condition which is signalled when an argument is identified as invalid.")) |
|
198 | ||
199 | (defmacro ignore-some-conditions ((&rest conditions) &body body) |
|
200 | "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS |
|
201 | list determines which specific conditions are to be ignored." |
|
202 | `(handler-case |
|
203 | (progn ,@body) |
|
204 | ,@(loop for condition in conditions collect |
|
205 | `(,condition (c) (values nil c))))) |
|
206 | ||
207 | (defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses) |
|
208 | "Like CL:UNWIND-PROTECT, but you can specify the circumstances that |
|
209 | the cleanup CLAUSES are run. |
|
210 | ||
211 | clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)* |
|
212 | ||
213 | Clauses can be given in any order, and more than one clause can be |
|
214 | given for each circumstance. The clauses whose denoted circumstance |
|
215 | occured, are executed in the order the clauses appear. |
|
216 | ||
217 | ABORT-FLAG is the name of a variable that will be bound to T in |
|
218 | CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL |
|
219 | otherwise. |
|
220 | ||
221 | Examples: |
|
222 | ||
223 | (unwind-protect-case () |
|
224 | (protected-form) |
|
225 | (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\")) |
|
226 | (:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\")) |
|
227 | (:always (format t \"This is evaluated in either case.~%\"))) |
|
228 | ||
229 | (unwind-protect-case (aborted-p) |
|
230 | (protected-form) |
|
231 | (:always (perform-cleanup-if aborted-p))) |
|
232 | " |
|
233 | (check-type abort-flag (or null symbol)) |
|
234 | (let ((gflag (gensym "FLAG+"))) |
|
235 | `(let ((,gflag t)) |
|
236 | (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil)) |
|
237 | (let ,(and abort-flag `((,abort-flag ,gflag))) |
|
238 | ,@(loop for (cleanup-kind . forms) in clauses |
|
239 | collect (ecase cleanup-kind |
|
240 | (:normal `(when (not ,gflag) ,@forms)) |
|
241 | (:abort `(when ,gflag ,@forms)) |
|
242 | (:always `(progn ,@forms))))))))) |