1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2009 Clozure Associates |
---|
4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
5 | ;;; This file is part of Clozure CL. |
---|
6 | ;;; |
---|
7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
11 | ;;; conflict, the preamble takes precedence. |
---|
12 | ;;; |
---|
13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
14 | ;;; |
---|
15 | ;;; The LLGPL is also available online at |
---|
16 | ;;; http://opensource.franz.com/preamble.html |
---|
17 | |
---|
18 | |
---|
19 | ;;; This file contains the error/condition system. Functions that |
---|
20 | ;;; signal/handle errors are defined later. |
---|
21 | |
---|
22 | (in-package "CCL") |
---|
23 | |
---|
24 | ;;;*********************************** |
---|
25 | ;;; Error System |
---|
26 | ;;;*********************************** |
---|
27 | |
---|
28 | (defclass condition () ()) |
---|
29 | (defclass warning (condition) ()) |
---|
30 | (defclass serious-condition (condition) ()) |
---|
31 | (defclass error (serious-condition) ()) |
---|
32 | |
---|
33 | (define-condition simple-condition (condition) |
---|
34 | ((format-control :initarg :format-control |
---|
35 | :reader simple-condition-format-control) |
---|
36 | (format-arguments :initarg :format-arguments |
---|
37 | :initform nil |
---|
38 | :reader simple-condition-format-arguments)) |
---|
39 | (:report (lambda (c stream) ;; If this were a method, slot value might be faster someday. Accessors always faster ? |
---|
40 | ;; And of course it's terribly important that this be as fast as humanly possible... |
---|
41 | ;Use accessors because they're documented and users can specialize them. |
---|
42 | (apply #'format stream (simple-condition-format-control c) |
---|
43 | (simple-condition-format-arguments c))))) |
---|
44 | |
---|
45 | |
---|
46 | (define-condition storage-condition (serious-condition) ()) |
---|
47 | |
---|
48 | (define-condition thread-condition (serious-condition) ()) |
---|
49 | |
---|
50 | (define-condition process-reset (thread-condition) |
---|
51 | ((kill :initarg :kill :initform nil :reader process-reset-kill))) |
---|
52 | |
---|
53 | |
---|
54 | (define-condition print-not-readable (error) |
---|
55 | ((object :initarg :object :reader print-not-readable-object) |
---|
56 | (stream :initarg :stream :reader print-not-readable-stream)) |
---|
57 | (:report (lambda (c stream) |
---|
58 | (let* ((*print-readably* nil)) |
---|
59 | (format stream "Attempt to print object ~S on stream ~S ." |
---|
60 | (print-not-readable-object c) |
---|
61 | (print-not-readable-stream c)))))) |
---|
62 | |
---|
63 | (define-condition simple-warning (simple-condition warning) ()) |
---|
64 | |
---|
65 | (define-condition compiler-warning (warning) |
---|
66 | ((function-name :initarg :function-name :initform nil :accessor compiler-warning-function-name) |
---|
67 | (source-note :initarg :source-note :initform nil :accessor compiler-warning-source-note) |
---|
68 | (warning-type :initarg :warning-type :reader compiler-warning-warning-type) |
---|
69 | (args :initarg :args :reader compiler-warning-args) |
---|
70 | (nrefs :initform () :accessor compiler-warning-nrefs)) |
---|
71 | (:report report-compiler-warning)) |
---|
72 | |
---|
73 | ;; Backward compatibility |
---|
74 | (defmethod compiler-warning-file-name ((w compiler-warning)) |
---|
75 | (source-note-filename (compiler-warning-source-note w))) |
---|
76 | |
---|
77 | (define-condition style-warning (compiler-warning) |
---|
78 | ((warning-type :initform :unsure) |
---|
79 | (args :initform nil))) |
---|
80 | (define-condition undefined-reference (style-warning) ()) |
---|
81 | (define-condition undefined-type-reference (undefined-reference) ()) |
---|
82 | (define-condition undefined-function-reference (undefined-reference) ()) |
---|
83 | (define-condition macro-used-before-definition (compiler-warning) ()) |
---|
84 | (define-condition invalid-type-warning (style-warning) ()) |
---|
85 | (define-condition invalid-arguments (style-warning) ()) |
---|
86 | (define-condition invalid-arguments-global (style-warning) ()) |
---|
87 | (define-condition undefined-keyword-reference (undefined-reference invalid-arguments) ()) |
---|
88 | |
---|
89 | (define-condition simple-error (simple-condition error) ()) |
---|
90 | |
---|
91 | (define-condition simple-storage-condition (simple-condition storage-condition) ()) |
---|
92 | (define-condition stack-overflow-condition (simple-storage-condition) ()) |
---|
93 | |
---|
94 | (define-condition invalid-memory-access (storage-condition) |
---|
95 | ((address :initarg :address) |
---|
96 | (write-p :initform nil :initarg :write-p)) |
---|
97 | (:report (lambda (c s) |
---|
98 | (with-slots (address write-p) c |
---|
99 | (format s "Fault during ~a memory address #x~x" (if write-p "write to" "read of") address))))) |
---|
100 | |
---|
101 | (define-condition invalid-memory-operation (storage-condition) |
---|
102 | () |
---|
103 | (:report (lambda (c s) |
---|
104 | (declare (ignore c)) |
---|
105 | (format s "Invalid memory operation.")))) |
---|
106 | |
---|
107 | (define-condition write-to-watched-object (storage-condition) |
---|
108 | ((object :initform nil :initarg :object |
---|
109 | :reader write-to-watched-object-object) |
---|
110 | (offset :initarg :offset |
---|
111 | :reader write-to-watched-object-offset) |
---|
112 | (instruction :initarg :instruction |
---|
113 | :reader write-to-watched-object-instruction)) |
---|
114 | (:report report-write-to-watched-object)) |
---|
115 | |
---|
116 | (defun report-write-to-watched-object (c s) |
---|
117 | (with-slots (object offset instruction) c |
---|
118 | (cond |
---|
119 | ((uvectorp object) |
---|
120 | (let* ((count (uvsize object)) |
---|
121 | (nbytes (if (ivectorp object) |
---|
122 | (subtag-bytes (typecode object) count) |
---|
123 | (* count target::node-size))) |
---|
124 | (bytes-per-element (/ nbytes count)) |
---|
125 | (offset (- offset target::misc-data-offset)) |
---|
126 | (index (/ offset bytes-per-element))) |
---|
127 | (format s "Write to watched uvector ~s at " object) |
---|
128 | (if (fixnump index) |
---|
129 | (format s "index ~s" index) |
---|
130 | (format s "an apparently unaligned byte offset ~s" offset)))) |
---|
131 | ((consp object) |
---|
132 | (format s "Write to ~a watched cons cell ~s" |
---|
133 | (cond |
---|
134 | ((= offset target::cons.cdr) "the CDR of") |
---|
135 | ((= offset target::cons.car) "the CAR of") |
---|
136 | (t |
---|
137 | (format nil "an apparently unaligned byte offset (~s) into" |
---|
138 | offset))) |
---|
139 | object)) |
---|
140 | (t |
---|
141 | (format s "Write to a strange object ~s at byte offset ~s" |
---|
142 | object offset))) |
---|
143 | (when instruction |
---|
144 | (format s "~&Faulting instruction: ~s" instruction)))) |
---|
145 | |
---|
146 | (define-condition type-error (error) |
---|
147 | ((datum :initarg :datum) |
---|
148 | (expected-type :initarg :expected-type :reader type-error-expected-type) |
---|
149 | (format-control :initarg :format-control :initform (%rsc-string $xwrongtype) :reader type-error-format-control)) |
---|
150 | (:report (lambda (c s) |
---|
151 | (format s (type-error-format-control c) |
---|
152 | (type-error-datum c) |
---|
153 | (type-error-expected-type c))))) |
---|
154 | |
---|
155 | (define-condition bad-slot-type (type-error) |
---|
156 | ((slot-definition :initform nil :initarg :slot-definition) |
---|
157 | (instance :initform nil :initarg :instance)) |
---|
158 | (:report (lambda (c s) |
---|
159 | (format s "The value ~s can not be used to set the value of the slot ~s in ~s, because it is not of type ~s. " |
---|
160 | (type-error-datum c) |
---|
161 | (slot-definition-name (slot-value c 'slot-definition)) |
---|
162 | (slot-value c 'instance) |
---|
163 | (type-error-expected-type c))))) |
---|
164 | |
---|
165 | (define-condition bad-slot-type-from-initform (bad-slot-type) |
---|
166 | () |
---|
167 | (:report (lambda (c s) |
---|
168 | (let* ((slotd (slot-value c 'slot-definition))) |
---|
169 | (format s "The value ~s, derived from the initform ~s, can not be used to set the value of the slot ~s in ~s, because it is not of type ~s. " |
---|
170 | (type-error-datum c) |
---|
171 | (slot-definition-initform slotd) |
---|
172 | (slot-definition-name slotd) |
---|
173 | (slot-value c 'instance) |
---|
174 | (type-error-expected-type c)))))) |
---|
175 | |
---|
176 | (define-condition bad-slot-type-from-initarg (bad-slot-type) |
---|
177 | ((initarg-name :initarg :initarg-name)) |
---|
178 | (:report (lambda (c s) |
---|
179 | (let* ((slotd (slot-value c 'slot-definition))) |
---|
180 | (format s "The value ~s, derived from the initarg ~s, can not be used to set the value of the slot ~s in ~s, because it is not of type ~s. " |
---|
181 | (type-error-datum c) |
---|
182 | (slot-value c 'initarg-name) |
---|
183 | (slot-definition-name slotd) |
---|
184 | (slot-value c 'instance) |
---|
185 | (type-error-expected-type c)))))) |
---|
186 | |
---|
187 | |
---|
188 | (define-condition improper-list (type-error) |
---|
189 | ((expected-type :initform '(satisfies proper-list-p) :reader type-error-expected-type))) |
---|
190 | |
---|
191 | (define-condition cant-construct-arglist (improper-list) |
---|
192 | ()) |
---|
193 | |
---|
194 | |
---|
195 | (let* ((magic-token '("Unbound"))) |
---|
196 | (defmethod type-error-datum ((c type-error)) |
---|
197 | (let* ((datum-slot (slot-value c 'datum))) |
---|
198 | (if (eq magic-token datum-slot) |
---|
199 | (%unbound-marker-8) |
---|
200 | datum-slot))) |
---|
201 | |
---|
202 | ; do we need this |
---|
203 | (defun signal-type-error (datum expected &optional (format-string (%rsc-string $xwrongtype))) |
---|
204 | (let ((error #'error)) |
---|
205 | (funcall error (make-condition 'type-error |
---|
206 | :format-control format-string |
---|
207 | :datum (if (eq datum (%unbound-marker-8)) magic-token datum) |
---|
208 | :expected-type (%type-error-type expected))))) |
---|
209 | ) |
---|
210 | |
---|
211 | |
---|
212 | (define-condition sequence-index-type-error (type-error) |
---|
213 | ((sequence :initarg :sequence)) |
---|
214 | (:report (lambda (c s) |
---|
215 | (format s "~s is not a valid sequence index for ~s" |
---|
216 | (type-error-datum c) |
---|
217 | (slot-value c 'sequence))))) |
---|
218 | |
---|
219 | |
---|
220 | ;;; This is admittedly sleazy; ANSI CL requires TYPE-ERRORs to be |
---|
221 | ;;; signalled in cases where a type-specifier is not of an appropriate |
---|
222 | ;;; subtype. The sleazy part is whether it's right to overload TYPE-ERROR |
---|
223 | ;;; like this. |
---|
224 | |
---|
225 | (define-condition invalid-subtype-error (type-error) |
---|
226 | () |
---|
227 | (:report (lambda (c s) |
---|
228 | (format s "The type specifier ~S is not determinably a subtype of the type ~S" |
---|
229 | (type-error-datum c) |
---|
230 | (type-error-expected-type c))))) |
---|
231 | |
---|
232 | (define-condition simple-type-error (simple-condition type-error) ()) |
---|
233 | |
---|
234 | (define-condition array-element-type-error (simple-type-error) |
---|
235 | ((array :initarg :array :reader array-element-type-error-array)) |
---|
236 | (:report (lambda (c s) |
---|
237 | (format s (simple-condition-format-control c) |
---|
238 | (type-error-datum c) |
---|
239 | (array-element-type-error-array c))))) |
---|
240 | |
---|
241 | |
---|
242 | |
---|
243 | |
---|
244 | |
---|
245 | (define-condition program-error (error) ()) |
---|
246 | (define-condition simple-program-error (simple-condition program-error) |
---|
247 | ((context :initarg :context :reader simple-program-error-context :initform nil))) |
---|
248 | |
---|
249 | (define-condition invalid-type-specifier (program-error) |
---|
250 | ((typespec :initarg :typespec :reader invalid-type-specifier-typespec)) |
---|
251 | (:report (lambda (c s) |
---|
252 | (with-slots (typespec) c |
---|
253 | (format s "Invalid type specifier: ~s ." typespec))))) |
---|
254 | |
---|
255 | (defun signal-program-error (string &rest args) |
---|
256 | (let* ((e #'error)) |
---|
257 | (funcall e |
---|
258 | (make-condition 'simple-program-error |
---|
259 | :format-control (if (fixnump string) (%rsc-string string) string) |
---|
260 | :format-arguments args)))) |
---|
261 | |
---|
262 | (define-condition simple-destructuring-error (simple-program-error) ()) |
---|
263 | |
---|
264 | (define-condition wrong-number-of-arguments (program-error) |
---|
265 | ((nargs :initform nil |
---|
266 | :initarg :nargs :reader wrong-number-of-arguments-nargs) |
---|
267 | (fn :initform nil :initarg :fn :reader wrong-number-of-arguments-fn)) |
---|
268 | (:report report-argument-mismatch)) |
---|
269 | |
---|
270 | (define-condition too-many-arguments (wrong-number-of-arguments) ()) |
---|
271 | |
---|
272 | (define-condition too-few-arguments (wrong-number-of-arguments) ()) |
---|
273 | |
---|
274 | (defun report-argument-mismatch (c s) |
---|
275 | (let* ((nargs-provided (wrong-number-of-arguments-nargs c)) |
---|
276 | (fn (wrong-number-of-arguments-fn c)) |
---|
277 | (too-many (typep c 'too-many-arguments))) |
---|
278 | (multiple-value-bind (min max scaled-nargs) |
---|
279 | (min-max-actual-args fn nargs-provided) |
---|
280 | (if (not min) |
---|
281 | (progn |
---|
282 | (format s "Function ~s called with too ~a arguments. " |
---|
283 | fn |
---|
284 | (if too-many |
---|
285 | "many" |
---|
286 | "few"))) |
---|
287 | (if too-many |
---|
288 | (format s "Too many arguments in call to ~s:~&~d argument~:p provided, at most ~d accepted. " fn scaled-nargs max) |
---|
289 | (format s "Too few arguments in call to ~s:~&~d argument~:p provided, at least ~d required. " fn scaled-nargs min)))))) |
---|
290 | |
---|
291 | |
---|
292 | |
---|
293 | (define-condition compile-time-program-error (simple-program-error) |
---|
294 | nil ;((context :initarg :context :reader compile-time-program-error-context)) |
---|
295 | (:report |
---|
296 | (lambda (c s) |
---|
297 | (format s "While compiling ~a :~%~a" |
---|
298 | (simple-program-error-context c) |
---|
299 | (apply #'format nil (simple-condition-format-control c) (simple-condition-format-arguments c)))))) |
---|
300 | |
---|
301 | |
---|
302 | |
---|
303 | ;;; Miscellaneous error during compilation (caused by macroexpansion, transforms, compile-time evaluation, etc.) |
---|
304 | ;;; NOT program-errors. |
---|
305 | (define-condition compile-time-error (simple-error) |
---|
306 | ((context :initarg :context :reader compile-time-error-context)) |
---|
307 | (:report |
---|
308 | (lambda (c s) |
---|
309 | (format s "While compiling ~a :~%~a" |
---|
310 | (compile-time-error-context c) |
---|
311 | (format nil "~a" c))))) |
---|
312 | |
---|
313 | (define-condition control-error (error) ()) |
---|
314 | |
---|
315 | (define-condition cant-throw-error (control-error) |
---|
316 | ((tag :initarg :tag)) |
---|
317 | (:report (lambda (c s) |
---|
318 | (format s "Can't throw to tag ~s" (slot-value c 'tag))))) |
---|
319 | |
---|
320 | (define-condition inactive-restart (control-error) |
---|
321 | ((restart-name :initarg :restart-name)) |
---|
322 | (:report (lambda (c s) |
---|
323 | (format s "Restart ~s is not active" (slot-value c 'restart-name))))) |
---|
324 | |
---|
325 | (define-condition lock-protocol-error (control-error) |
---|
326 | ((lock :initarg :lock))) |
---|
327 | |
---|
328 | (define-condition not-lock-owner (lock-protocol-error) |
---|
329 | () |
---|
330 | (:report (lambda (c s) |
---|
331 | (format s "Current process ~s does not own lock ~s" |
---|
332 | *current-process* (slot-value c 'lock))))) |
---|
333 | |
---|
334 | (define-condition not-locked (lock-protocol-error) |
---|
335 | () |
---|
336 | (:report (lambda (c s) |
---|
337 | (format s "Lock ~s isn't locked." (slot-value c 'lock))))) |
---|
338 | |
---|
339 | (define-condition deadlock (lock-protocol-error) |
---|
340 | () |
---|
341 | (:report (lambda (c s) |
---|
342 | (format s "Requested operation on ~s would cause deadlock." (slot-value c 'lock))))) |
---|
343 | |
---|
344 | (define-condition package-error (error) |
---|
345 | ((package :initarg :package :reader package-error-package))) |
---|
346 | (define-condition no-such-package (package-error) |
---|
347 | () |
---|
348 | (:report (lambda (c s) (format s (%rsc-string $xnopkg) (package-error-package c))))) |
---|
349 | (define-condition unintern-conflict-error (package-error) |
---|
350 | ((sym-to-unintern :initarg :sym) |
---|
351 | (conflicting-syms :initarg :conflicts)) |
---|
352 | (:report (lambda (c s) |
---|
353 | (format s (%rsc-string $xunintc) (slot-value c 'sym-to-unintern) (package-error-package c) (slot-value c 'conflicting-syms))))) |
---|
354 | |
---|
355 | (define-condition import-conflict-error (package-error) |
---|
356 | ((imported-sym :initarg :imported-sym) |
---|
357 | (conflicting-sym :initarg :conflicting-sym) |
---|
358 | (conflict-external-p :initarg :conflict-external)) |
---|
359 | (:report (lambda (c s) |
---|
360 | (format s (%rsc-string (if (slot-value c 'conflict-external-p) $ximprtcx $ximprtc)) |
---|
361 | (slot-value c 'imported-sym) |
---|
362 | (package-error-package c) |
---|
363 | (slot-value c 'conflicting-sym))))) |
---|
364 | |
---|
365 | (define-condition use-package-conflict-error (package-error) |
---|
366 | ((package-to-use :initarg :package-to-use) |
---|
367 | (conflicts :initarg :conflicts) |
---|
368 | (external-p :initarg :external-p)) |
---|
369 | (:report (lambda (c s) |
---|
370 | (format s (%rsc-string (if (slot-value c 'external-p) $xusecX $xusec)) |
---|
371 | (slot-value c 'package-to-use) |
---|
372 | (package-error-package c) |
---|
373 | (slot-value c 'conflicts))))) |
---|
374 | |
---|
375 | (define-condition export-conflict-error (package-error) |
---|
376 | ((conflicts :initarg :conflicts)) |
---|
377 | (:report |
---|
378 | (lambda (c s) |
---|
379 | (format s "Name conflict~p detected by ~A :" (length (slot-value c 'conflicts)) 'export) |
---|
380 | (let* ((package (package-error-package c))) |
---|
381 | (dolist (conflict (slot-value c 'conflicts)) |
---|
382 | (destructuring-bind (inherited-p sym-to-export using-package conflicting-sym) conflict |
---|
383 | (format s "~&~A'ing ~S from ~S would cause a name conflict with ~&~ |
---|
384 | the ~a symbol ~S in the package ~s, which uses ~S." |
---|
385 | 'export |
---|
386 | sym-to-export |
---|
387 | package |
---|
388 | (if inherited-p "inherited" "present") |
---|
389 | conflicting-sym |
---|
390 | using-package |
---|
391 | package))))))) |
---|
392 | |
---|
393 | (define-condition export-requires-import (package-error) |
---|
394 | ((to-be-imported :initarg :to-be-imported)) |
---|
395 | (:report |
---|
396 | (lambda (c s) |
---|
397 | (let* ((p (package-error-package c))) |
---|
398 | (format s "The following symbols need to be imported to ~S before they can be exported ~& from that package:~%~s:" p (slot-value c 'to-be-imported)))))) |
---|
399 | |
---|
400 | |
---|
401 | (define-condition package-name-conflict-error (package-error simple-error) ()) |
---|
402 | |
---|
403 | (define-condition package-is-used-by (package-error) |
---|
404 | ((using-packages :initarg :using-packages)) |
---|
405 | (:report (lambda (c s) |
---|
406 | (format s "~S is used by ~S" (package-error-package c) |
---|
407 | (slot-value c 'using-packages))))) |
---|
408 | |
---|
409 | (define-condition symbol-name-not-accessible (package-error) |
---|
410 | ((symbol-name :initarg :symbol-name)) |
---|
411 | (:report (lambda (c s) |
---|
412 | (format s "No aymbol named ~S is accessible in package ~s" |
---|
413 | (slot-value c 'symbol-name) |
---|
414 | (package-error-package c))))) |
---|
415 | |
---|
416 | (define-condition stream-error (error) |
---|
417 | ((stream :initarg :stream :reader stream-error-stream))) |
---|
418 | |
---|
419 | (defun stream-error-context (condition) |
---|
420 | (let* ((stream (stream-error-stream condition))) |
---|
421 | (with-output-to-string (s) |
---|
422 | (format s "on ~s" stream) |
---|
423 | (let* ((pos (ignore-errors (stream-position stream)))) |
---|
424 | (when pos |
---|
425 | (format s ", near position ~d" pos))) |
---|
426 | (let* ((surrounding (stream-surrounding-characters stream))) |
---|
427 | (when surrounding |
---|
428 | (format s ", within ~s" surrounding)))))) |
---|
429 | |
---|
430 | (define-condition parse-error (error) ()) |
---|
431 | (define-condition parse-integer-not-integer-string (parse-error) |
---|
432 | ((string :initarg :string)) |
---|
433 | (:report (lambda (c s) |
---|
434 | (format s "Not an integer string: ~s" (slot-value c 'string))))) |
---|
435 | |
---|
436 | (define-condition reader-error (parse-error stream-error) ()) |
---|
437 | (define-condition end-of-file (stream-error) () |
---|
438 | (:report (lambda (c s) |
---|
439 | (format s "Unexpected end of file ~a" (stream-error-context c))))) |
---|
440 | |
---|
441 | (define-condition io-timeout (stream-error) |
---|
442 | ()) |
---|
443 | |
---|
444 | (define-condition input-timeout (io-timeout) |
---|
445 | () |
---|
446 | (:report (lambda (c s) |
---|
447 | (format s "Input timeout on ~s" (stream-error-stream c))))) |
---|
448 | (define-condition output-timeout (io-timeout) |
---|
449 | () |
---|
450 | (:report (lambda (c s) |
---|
451 | (format s "Output timeout on ~s" (stream-error-stream c))))) |
---|
452 | (define-condition communication-deadline-expired (io-timeout) |
---|
453 | () |
---|
454 | (:report (lambda (c s) |
---|
455 | (format s "Communication deadline timeout on ~s" (stream-error-stream c))))) |
---|
456 | |
---|
457 | |
---|
458 | |
---|
459 | |
---|
460 | (define-condition impossible-number (reader-error) |
---|
461 | ((token :initarg :token :reader impossible-number-token) |
---|
462 | (condition :initarg :condition :reader impossible-number-condition)) |
---|
463 | (:report (lambda (c s) |
---|
464 | (format s "Condition of type ~s raised ~&while trying to parse numeric token ~s ~&~s" |
---|
465 | (type-of (impossible-number-condition c)) |
---|
466 | (impossible-number-token c) |
---|
467 | (stream-error-context c))))) |
---|
468 | |
---|
469 | |
---|
470 | |
---|
471 | (define-condition simple-stream-error (stream-error simple-condition) () |
---|
472 | (:report (lambda (c s) |
---|
473 | (format s "~a : ~&~a" (stream-error-context c) |
---|
474 | (apply #'format |
---|
475 | nil |
---|
476 | (simple-condition-format-control c) |
---|
477 | (simple-condition-format-arguments c)))))) |
---|
478 | |
---|
479 | |
---|
480 | |
---|
481 | |
---|
482 | (define-condition file-error (error) |
---|
483 | ((pathname :initarg :pathname :initform "<unspecified>" :reader file-error-pathname) |
---|
484 | (error-type :initarg :error-type :initform "File error on file ~S")) |
---|
485 | (:report (lambda (c s) |
---|
486 | (format s (slot-value c 'error-type) |
---|
487 | (file-error-pathname c))))) |
---|
488 | |
---|
489 | (define-condition simple-file-error (simple-condition file-error) |
---|
490 | () |
---|
491 | (:report (lambda (c s) |
---|
492 | (apply #'format s (slot-value c 'error-type) |
---|
493 | (file-error-pathname c) |
---|
494 | (simple-condition-format-arguments c))))) |
---|
495 | |
---|
496 | |
---|
497 | (define-condition namestring-parse-error (error) |
---|
498 | ((complaint :reader namestring-parse-error-complaint :initarg :complaint) |
---|
499 | (arguments :reader namestring-parse-error-arguments :initarg :arguments |
---|
500 | :initform nil) |
---|
501 | (namestring :reader namestring-parse-error-namestring :initarg :namestring) |
---|
502 | (offset :reader namestring-parse-error-offset :initarg :offset)) |
---|
503 | (:report (lambda (condition stream) |
---|
504 | (format stream "Parse error in namestring: ~?~% ~A~% ~V@T^" |
---|
505 | (namestring-parse-error-complaint condition) |
---|
506 | (namestring-parse-error-arguments condition) |
---|
507 | (namestring-parse-error-namestring condition) |
---|
508 | (namestring-parse-error-offset condition))))) |
---|
509 | |
---|
510 | (define-condition cell-error (error) |
---|
511 | ((name :initarg :name :reader cell-error-name) |
---|
512 | (error-type :initarg :error-type :initform "Cell error" :reader cell-error-type)) |
---|
513 | (:report (lambda (c s) (format s "~A: ~S" (cell-error-type c) (cell-error-name c))))) |
---|
514 | |
---|
515 | (define-condition unbound-variable (cell-error) |
---|
516 | ((error-type :initform "Unbound variable"))) |
---|
517 | |
---|
518 | (define-condition undefined-function (cell-error) |
---|
519 | ((error-type :initform "Undefined function"))) |
---|
520 | (define-condition undefined-function-call (control-error undefined-function) |
---|
521 | ((function-arguments :initarg :function-arguments :reader undefined-function-call-arguments)) |
---|
522 | (:report (lambda (c s) (format s "Undefined function ~S called with arguments ~:S ." |
---|
523 | (cell-error-name c) |
---|
524 | (undefined-function-call-arguments c))))) |
---|
525 | |
---|
526 | (define-condition call-special-operator-or-macro (undefined-function-call) |
---|
527 | () |
---|
528 | (:report (lambda (c s) (format s "Special operator or global macro-function ~s can't be FUNCALLed or APPLYed" (cell-error-name c))))) |
---|
529 | |
---|
530 | |
---|
531 | (define-condition unbound-slot (cell-error) |
---|
532 | ((instance :initarg :instance :accessor unbound-slot-instance)) |
---|
533 | (:report (lambda (c s) (format s "Slot ~s is unbound in ~s" |
---|
534 | (cell-error-name c) |
---|
535 | (unbound-slot-instance c))))) |
---|
536 | |
---|
537 | |
---|
538 | (define-condition arithmetic-error (error) |
---|
539 | ((operation :initform nil :initarg :operation :reader arithmetic-error-operation) |
---|
540 | (operands :initform nil :initarg :operands :reader arithmetic-error-operands) |
---|
541 | (status :initform nil :initarg :status :reader arithmetic-error-status)) |
---|
542 | (:report (lambda (c s) |
---|
543 | (format s "~S detected" (type-of c)) |
---|
544 | (let* ((operands (arithmetic-error-operands c))) |
---|
545 | (when operands |
---|
546 | (format s "~&performing ~A on ~:S" |
---|
547 | (arithmetic-error-operation c) |
---|
548 | operands)))))) |
---|
549 | |
---|
550 | (define-condition division-by-zero (arithmetic-error) ()) |
---|
551 | |
---|
552 | (define-condition floating-point-underflow (arithmetic-error) ()) |
---|
553 | (define-condition floating-point-overflow (arithmetic-error) ()) |
---|
554 | (define-condition floating-point-inexact (arithmetic-error) ()) |
---|
555 | (define-condition floating-point-invalid-operation (arithmetic-error) ()) |
---|
556 | |
---|
557 | (define-condition compiler-bug (simple-error) |
---|
558 | () |
---|
559 | (:report (lambda (c stream) |
---|
560 | (format stream "Compiler bug or inconsistency:~%") |
---|
561 | (apply #'format stream (simple-condition-format-control c) |
---|
562 | (simple-condition-format-arguments c))))) |
---|
563 | |
---|
564 | (define-condition external-process-creation-failure (serious-condition) |
---|
565 | ((proc :initarg :proc)) |
---|
566 | (:report (lambda (c stream) |
---|
567 | (with-slots (proc) c |
---|
568 | (let* ((code (external-process-%exit-code proc))) |
---|
569 | (format stream "Fork failed in ~s: ~a. " proc (if (eql code -1) "random lisp error" (%strerror code)))))))) |
---|
570 | |
---|
571 | |
---|
572 | (defun restartp (thing) |
---|
573 | (istruct-typep thing 'restart)) |
---|
574 | (setf (type-predicate 'restart) 'restartp) |
---|
575 | |
---|
576 | (defmethod print-object ((restart restart) stream) |
---|
577 | (let ((report (%restart-report restart))) |
---|
578 | (cond ((or *print-escape* (null report)) |
---|
579 | (print-unreadable-object (restart stream :identity t) |
---|
580 | (format stream "~S ~S" |
---|
581 | 'restart (%restart-name restart)))) |
---|
582 | ((stringp report) |
---|
583 | (write-string report stream)) |
---|
584 | (t |
---|
585 | (funcall report stream))))) |
---|
586 | |
---|
587 | (defun %make-restart (name action report interactive test) |
---|
588 | (%cons-restart name action report interactive test)) |
---|
589 | |
---|
590 | (defun make-restart (vector name action-function &key report-function interactive-function test-function) |
---|
591 | (unless vector (setq vector (%cons-restart nil nil nil nil nil))) |
---|
592 | (setf (%restart-name vector) name |
---|
593 | (%restart-action vector) (require-type action-function 'function) |
---|
594 | (%restart-report vector) (if report-function (require-type report-function 'function)) |
---|
595 | (%restart-interactive vector) (if interactive-function (require-type interactive-function 'function)) |
---|
596 | (%restart-test vector) (if test-function (require-type test-function 'function))) |
---|
597 | vector) |
---|
598 | |
---|
599 | (defun restart-name (restart) |
---|
600 | "Return the name of the given restart object." |
---|
601 | (%restart-name (require-type restart 'restart))) |
---|
602 | |
---|
603 | (defun applicable-restart-p (restart condition) |
---|
604 | (let* ((pair (if condition (assq restart *condition-restarts*))) |
---|
605 | (test (%restart-test restart))) |
---|
606 | (and (or (null pair) (eq (%cdr pair) condition)) |
---|
607 | (or (null test) (funcall test condition))))) |
---|
608 | |
---|
609 | (defun compute-restarts (&optional condition &aux restarts) |
---|
610 | "Return a list of all the currently active restarts ordered from most |
---|
611 | recently established to less recently established. If CONDITION is |
---|
612 | specified, then only restarts associated with CONDITION (or with no |
---|
613 | condition) will be returned." |
---|
614 | (dolist (cluster %restarts% (nreverse restarts)) |
---|
615 | (dolist (restart cluster) |
---|
616 | (when (applicable-restart-p restart condition) |
---|
617 | (push restart restarts))))) |
---|
618 | |
---|
619 | (defun find-restart (name &optional condition) |
---|
620 | "Return the first active restart named NAME. If NAME names a |
---|
621 | restart, the restart is returned if it is currently active. If no such |
---|
622 | restart is found, NIL is returned. It is an error to supply NIL as a |
---|
623 | name. If CONDITION is specified and not NIL, then only restarts |
---|
624 | associated with that condition (or with no condition) will be |
---|
625 | returned." |
---|
626 | (dolist (cluster %restarts%) |
---|
627 | (dolist (restart cluster) |
---|
628 | (when (and (or (eq restart name) (eq (restart-name restart) name)) |
---|
629 | (applicable-restart-p restart condition)) |
---|
630 | (return-from find-restart restart))))) |
---|
631 | |
---|
632 | (defun %active-restart (name) |
---|
633 | (dolist (cluster %restarts%) |
---|
634 | (dolist (restart cluster) |
---|
635 | (when (or (eq restart name) |
---|
636 | (let* ((rname (%restart-name restart)) |
---|
637 | (rtest (%restart-test restart))) |
---|
638 | (and (eq rname name) |
---|
639 | (or (null rtest) (funcall rtest nil))))) |
---|
640 | (return-from %active-restart (values restart cluster))))) |
---|
641 | (error 'inactive-restart :restart-name name)) |
---|
642 | |
---|
643 | (defun invoke-restart (restart &rest values) |
---|
644 | "Calls the function associated with the given restart, passing any given |
---|
645 | arguments. If the argument restart is not a restart or a currently active |
---|
646 | non-nil restart name, then a CONTROL-ERROR is signalled." |
---|
647 | (multiple-value-bind (restart tag) (%active-restart restart) |
---|
648 | (let ((fn (%restart-action restart))) |
---|
649 | (cond ((null fn) ; simple restart |
---|
650 | (unless (null values) (%err-disp $xtminps)) |
---|
651 | (throw tag nil)) |
---|
652 | ((fixnump fn) ; restart case |
---|
653 | (throw tag (cons fn values))) |
---|
654 | ((functionp fn) ; restart bind |
---|
655 | (apply fn values)) |
---|
656 | (t ; with-simple-restart |
---|
657 | (throw tag (values nil t))))))) |
---|
658 | |
---|
659 | (defun invoke-restart-no-return (restart) |
---|
660 | (invoke-restart restart) |
---|
661 | (error 'restart-failure :restart restart)) |
---|
662 | |
---|
663 | (defun invoke-restart-interactively (restart) |
---|
664 | "Calls the function associated with the given restart, prompting for any |
---|
665 | necessary arguments. If the argument restart is not a restart or a |
---|
666 | currently active non-NIL restart name, then a CONTROL-ERROR is signalled." |
---|
667 | (let* ((restart (find-restart restart))) |
---|
668 | (format *error-output* "~&Invoking restart: ~a~&" restart) |
---|
669 | (let* ((argfn (%restart-interactive restart)) |
---|
670 | (values (when argfn (funcall argfn)))) |
---|
671 | (apply #'invoke-restart restart values)))) |
---|
672 | |
---|
673 | |
---|
674 | |
---|
675 | (defun maybe-invoke-restart (restart value condition) |
---|
676 | (let ((restart (find-restart restart condition))) |
---|
677 | (when restart (invoke-restart restart value)))) |
---|
678 | |
---|
679 | (defun use-value (value &optional condition) |
---|
680 | "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if |
---|
681 | none exists." |
---|
682 | (maybe-invoke-restart 'use-value value condition)) |
---|
683 | |
---|
684 | (defun store-value (value &optional condition) |
---|
685 | "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if |
---|
686 | none exists." |
---|
687 | (maybe-invoke-restart 'store-value value condition)) |
---|
688 | |
---|
689 | (defun condition-arg (thing args type) |
---|
690 | (cond ((condition-p thing) (if args (%err-disp $xtminps) thing)) |
---|
691 | ((symbolp thing) (apply #'make-condition thing args)) |
---|
692 | (t (make-condition type :format-control thing :format-arguments args)))) |
---|
693 | |
---|
694 | (defun make-condition (name &rest init-list) |
---|
695 | "Make an instance of a condition object using the specified initargs." |
---|
696 | (declare (dynamic-extent init-list)) |
---|
697 | (if (subtypep name 'condition) |
---|
698 | (apply #'make-instance name init-list) |
---|
699 | (let ((class (if (classp name) |
---|
700 | name |
---|
701 | (find-class name)))) ;; elicit an error if no such class |
---|
702 | (unless (class-finalized-p class) |
---|
703 | (finalize-inheritance class)) ;; elicit an error if forward refs. |
---|
704 | (error "~S is not a condition class" class)))) |
---|
705 | |
---|
706 | (defmethod print-object ((c condition) stream) |
---|
707 | (if *print-escape* |
---|
708 | (call-next-method) |
---|
709 | (report-condition c stream))) |
---|
710 | |
---|
711 | (defmethod report-condition ((c condition) stream) |
---|
712 | (princ (cond ((typep c 'error) "Error ") |
---|
713 | ((typep c 'warning) "Warning ") |
---|
714 | (t "Condition ")) |
---|
715 | stream) |
---|
716 | ;Here should dump all slots or something. For now... |
---|
717 | (let ((*print-escape* t)) |
---|
718 | (print-object c stream))) |
---|
719 | |
---|
720 | (defun signal-simple-condition (class-name format-string &rest args) |
---|
721 | (let ((e #'error)) ; Never-tail-call. |
---|
722 | (funcall e (make-condition class-name :format-control format-string :format-arguments args)))) |
---|
723 | |
---|
724 | (defun signal-simple-program-error (format-string &rest args) |
---|
725 | (apply #'signal-simple-condition 'simple-program-error format-string args)) |
---|
726 | |
---|
727 | ;;getting the function name for error functions. |
---|
728 | |
---|
729 | |
---|
730 | (defun %last-fn-on-stack (&optional (number 0) (s (%get-frame-ptr))) |
---|
731 | (let* ((fn nil)) |
---|
732 | (let ((p s)) |
---|
733 | (dotimes (i number) |
---|
734 | (declare (fixnum i)) |
---|
735 | (unless (setq p (parent-frame p nil)) |
---|
736 | (return))) |
---|
737 | (do* ((i number (1+ i))) |
---|
738 | ((null p)) |
---|
739 | (if (setq fn (cfp-lfun p)) |
---|
740 | (return (values fn i)) |
---|
741 | (setq p (parent-frame p nil))))))) |
---|
742 | |
---|
743 | (defun %err-fn-name (lfun) |
---|
744 | "given an lfun returns the name or the string \"Unknown\"" |
---|
745 | (if (lfunp lfun) (or (lfun-name lfun) lfun) |
---|
746 | (or lfun "Unknown"))) |
---|
747 | |
---|
748 | (defun %real-err-fn-name (error-pointer) |
---|
749 | (multiple-value-bind (fn p) (%last-fn-on-stack 0 error-pointer) |
---|
750 | (let ((name (%err-fn-name fn))) |
---|
751 | (if (and (memq name '( call-check-regs)) p) |
---|
752 | (%err-fn-name (%last-fn-on-stack (1+ p) error-pointer)) |
---|
753 | name)))) |
---|
754 | |
---|
755 | |
---|
756 | ;; Some simple restarts for simple error conditions. Callable from the kernel. |
---|
757 | |
---|
758 | (defun find-unique-homonyms (name &optional (test (constantly t))) |
---|
759 | (delete-duplicates |
---|
760 | (loop |
---|
761 | with symbol = (if (consp name) (second name) name) |
---|
762 | with pname = (symbol-name symbol) |
---|
763 | for package in (list-all-packages) |
---|
764 | for other-package-symbol = (find-symbol pname package) |
---|
765 | for canditate = (and other-package-symbol |
---|
766 | (neq other-package-symbol symbol) |
---|
767 | (if (consp name) |
---|
768 | (list (first name) other-package-symbol) |
---|
769 | other-package-symbol)) |
---|
770 | when (and canditate |
---|
771 | (funcall test canditate)) |
---|
772 | collect canditate) |
---|
773 | :test #'equal)) |
---|
774 | |
---|
775 | (def-kernel-restart $xvunbnd %default-unbound-variable-restarts (frame-ptr cell-name) |
---|
776 | (unless *level-1-loaded* |
---|
777 | (dbg cell-name)) ; user should never see this. |
---|
778 | (let ((condition (make-condition 'unbound-variable :name cell-name)) |
---|
779 | (other-variables (find-unique-homonyms cell-name (lambda (name) |
---|
780 | (and (not (keywordp name)) |
---|
781 | (boundp name)))))) |
---|
782 | (flet ((new-value () |
---|
783 | (catch-cancel |
---|
784 | (return-from new-value |
---|
785 | (list (read-from-string |
---|
786 | (get-string-from-user |
---|
787 | (format nil "New value for ~s : " cell-name)))))) |
---|
788 | (continue condition))) ; force error again if cancelled, var still not set. |
---|
789 | (restart-case (%error condition nil frame-ptr) |
---|
790 | (continue () |
---|
791 | :report (lambda (s) (format s "Retry getting the value of ~S." cell-name)) |
---|
792 | (symbol-value cell-name)) |
---|
793 | (use-homonym (homonym) |
---|
794 | :test (lambda (c) (and (or (null c) (eq c condition)) other-variables)) |
---|
795 | :report (lambda (s) |
---|
796 | (if (= 1 (length other-variables)) |
---|
797 | (format s "Use the value of ~s this time." (first other-variables)) |
---|
798 | (format s "Use one of the homonyms ~{~S or ~} this time." other-variables))) |
---|
799 | :interactive (lambda () |
---|
800 | (if (= 1 (length other-variables)) |
---|
801 | other-variables |
---|
802 | (select-item-from-list other-variables :window-title "Select homonym to use"))) |
---|
803 | (symbol-value homonym)) |
---|
804 | (use-value (value) |
---|
805 | :interactive new-value |
---|
806 | :report (lambda (s) (format s "Specify a value of ~S to use this time." cell-name)) |
---|
807 | value) |
---|
808 | (store-value (value) |
---|
809 | :interactive new-value |
---|
810 | :report (lambda (s) (format s "Specify a value of ~S to store and use." cell-name)) |
---|
811 | (setf (symbol-value cell-name) value)))))) |
---|
812 | |
---|
813 | (def-kernel-restart $xnopkg %default-no-package-restart (frame-ptr package-name) |
---|
814 | (or (and *autoload-lisp-package* |
---|
815 | (or (string-equal package-name "LISP") |
---|
816 | (string-equal package-name "USER")) |
---|
817 | (progn |
---|
818 | (require "LISP-PACKAGE") |
---|
819 | (find-package package-name))) |
---|
820 | (let* ((alias (or (%cdr (assoc package-name '(("LISP" . "COMMON-LISP") |
---|
821 | ("USER" . "CL-USER")) |
---|
822 | :test #'string-equal)) |
---|
823 | (if (packagep *package*) (package-name *package*)))) |
---|
824 | (condition (make-condition 'no-such-package :package package-name))) |
---|
825 | (flet ((try-again (p) |
---|
826 | (or (find-package p) (%kernel-restart $xnopkg p)))) |
---|
827 | (restart-case |
---|
828 | (restart-case (%error condition nil frame-ptr) |
---|
829 | (continue () |
---|
830 | :report (lambda (s) (format s "Retry finding package with name ~S." package-name)) |
---|
831 | (try-again package-name)) |
---|
832 | (use-value (value) |
---|
833 | :interactive (lambda () (block nil |
---|
834 | (catch-cancel |
---|
835 | (return (list (get-string-from-user |
---|
836 | "Find package named : ")))) |
---|
837 | (continue condition))) |
---|
838 | :report (lambda (s) (format s "Find specified package instead of ~S ." package-name)) |
---|
839 | (try-again value)) |
---|
840 | (make-nickname () |
---|
841 | :report (lambda (s) (format s "Make ~S be a nickname for package ~S." package-name alias)) |
---|
842 | (let ((p (try-again alias))) |
---|
843 | (push package-name (cdr (pkg.names p))) |
---|
844 | p))) |
---|
845 | (require-lisp-package () |
---|
846 | :test (lambda (c) |
---|
847 | (and (eq c condition) |
---|
848 | (or (string-equal package-name "LISP") (string-equal package-name "USER")))) |
---|
849 | :report (lambda (s) |
---|
850 | (format s "(require :lisp-package) and retry finding package ~s" |
---|
851 | package-name)) |
---|
852 | (require "LISP-PACKAGE") |
---|
853 | (try-again package-name))))))) |
---|
854 | |
---|
855 | (def-kernel-restart $xunintc unintern-conflict-restarts (frame-ptr sym package conflicts) |
---|
856 | (let ((condition (make-condition 'unintern-conflict-error :package package :sym sym :conflicts conflicts))) |
---|
857 | (restart-case (%error condition nil frame-ptr) |
---|
858 | (continue () |
---|
859 | :report (lambda (s) (format s "Try again to unintern ~s from ~s" sym package)) |
---|
860 | (unintern sym package)) |
---|
861 | (do-shadowing-import (ssym) |
---|
862 | :report (lambda (s) (format s "SHADOWING-IMPORT one of ~S in ~S." conflicts package)) |
---|
863 | :interactive (lambda () |
---|
864 | (block nil |
---|
865 | (catch-cancel |
---|
866 | (return (select-item-from-list conflicts |
---|
867 | :window-title |
---|
868 | (format nil "Shadowing-import one of the following in ~s" package) |
---|
869 | :table-print-function #'prin1))) |
---|
870 | (continue condition))) |
---|
871 | (shadowing-import (list ssym) package))))) |
---|
872 | |
---|
873 | |
---|
874 | (def-kernel-restart $xusec blub (frame-ptr package-to-use using-package conflicts) |
---|
875 | (resolve-use-package-conflict-error frame-ptr package-to-use using-package conflicts nil)) |
---|
876 | |
---|
877 | (def-kernel-restart $xusecX blub (frame-ptr package-to-use using-package conflicts) |
---|
878 | (resolve-use-package-conflict-error frame-ptr package-to-use using-package conflicts t)) |
---|
879 | |
---|
880 | (defun resolve-use-package-conflict-error (frame-ptr package-to-use using-package conflicts external-p) |
---|
881 | (let ((condition (make-condition 'use-package-conflict-error |
---|
882 | :package using-package |
---|
883 | :package-to-use package-to-use |
---|
884 | :conflicts conflicts |
---|
885 | :external-p external-p))) |
---|
886 | (flet ((external-test (&rest ignore) (declare (ignore ignore)) external-p) |
---|
887 | (present-test (&rest ignore) (declare (ignore ignore)) (not external-p))) |
---|
888 | (declare (dynamic-extent #'present-test #'external-test)) |
---|
889 | (restart-case (%error condition nil frame-ptr) |
---|
890 | (continue () |
---|
891 | :report (lambda (s) (format s "Try again to use ~s in ~s" package-to-use using-package))) |
---|
892 | (resolve-by-shadowing-import (&rest shadowing-imports) |
---|
893 | :test external-test |
---|
894 | :interactive (lambda () |
---|
895 | (mapcar #'(lambda (pair) |
---|
896 | (block nil |
---|
897 | (catch-cancel |
---|
898 | (return (car (select-item-from-list pair |
---|
899 | :window-title |
---|
900 | (format nil "Shadowing-import one of the following in ~s" using-package) |
---|
901 | :table-print-function #'prin1)))) |
---|
902 | (continue condition))) |
---|
903 | conflicts)) |
---|
904 | :report (lambda (s) (format s "SHADOWING-IMPORT one of each pair of conflicting symbols.")) |
---|
905 | (shadowing-import shadowing-imports using-package)) |
---|
906 | (unintern-all () |
---|
907 | :test present-test |
---|
908 | :report (lambda (s) (format s "UNINTERN all conflicting symbols from ~S" using-package)) |
---|
909 | (dolist (c conflicts) |
---|
910 | (unintern (car c) using-package))) |
---|
911 | (shadow-all () |
---|
912 | :test present-test |
---|
913 | :report (lambda (s) (format s "SHADOW all conflicting symbols in ~S" using-package)) |
---|
914 | (dolist (c conflicts) |
---|
915 | (shadow-1 using-package (car c)))) |
---|
916 | (resolve-by-unintern-or-shadow (&rest dispositions) |
---|
917 | :test present-test |
---|
918 | :interactive (lambda () |
---|
919 | (mapcar #'(lambda (pair) |
---|
920 | (let* ((present-sym (car pair))) |
---|
921 | (block nil |
---|
922 | (catch-cancel |
---|
923 | (return (car (select-item-from-list (list 'shadow 'unintern) |
---|
924 | :window-title |
---|
925 | (format nil "SHADOW ~S in, or UNINTERN ~S from ~S" |
---|
926 | present-sym |
---|
927 | present-sym |
---|
928 | using-package) |
---|
929 | :table-print-function #'prin1))) |
---|
930 | (continue condition))))) |
---|
931 | conflicts)) |
---|
932 | :report (lambda (s) (format s "SHADOW or UNINTERN the conflicting symbols in ~S." using-package)) |
---|
933 | (dolist (d dispositions) |
---|
934 | (let* ((sym (car (pop conflicts)))) |
---|
935 | (if (eq d 'shadow) |
---|
936 | (shadow-1 using-package sym) |
---|
937 | (unintern sym using-package))))))))) |
---|
938 | |
---|
939 | |
---|
940 | (defun resolve-export-conflicts (conflicts package) |
---|
941 | (let* ((first-inherited (caar conflicts)) |
---|
942 | (all-same (dolist (conflict (cdr conflicts) t) |
---|
943 | (unless (eq (car conflict) first-inherited) (return nil)))) |
---|
944 | (all-inherited (and all-same first-inherited)) |
---|
945 | (all-present (and all-same (not first-inherited))) |
---|
946 | (condition (make-condition 'export-conflict-error |
---|
947 | :conflicts conflicts |
---|
948 | :package package))) |
---|
949 | (flet ((check-again () |
---|
950 | (let* ((remaining-conflicts (check-export-conflicts (mapcar #'cadr conflicts) package))) |
---|
951 | (if remaining-conflicts (resolve-export-conflicts remaining-conflicts package))))) |
---|
952 | (restart-case (%error condition nil (%get-frame-ptr)) |
---|
953 | (resolve-all-by-shadowing-import-inherited |
---|
954 | () |
---|
955 | :test (lambda (&rest ignore) (declare (ignore ignore)) all-inherited) |
---|
956 | :report (lambda (s) (format s "SHADOWING-IMPORT all conflicting inherited symbol(s) in using package(s).")) |
---|
957 | (dolist (conflict conflicts (check-again)) |
---|
958 | (destructuring-bind (using-package inherited-sym) (cddr conflict) |
---|
959 | (shadowing-import-1 using-package inherited-sym)))) |
---|
960 | (resolve-all-by-shadowing-import-exported |
---|
961 | () |
---|
962 | :test (lambda (&rest ignore) (declare (ignore ignore)) all-inherited) |
---|
963 | :report (lambda (s) (format s "SHADOWING-IMPORT all conflicting symbol(s) to be exported in using package(s).")) |
---|
964 | (dolist (conflict conflicts (check-again)) |
---|
965 | (destructuring-bind (exported-sym using-package ignore) (cdr conflict) |
---|
966 | (declare (ignore ignore)) |
---|
967 | (shadowing-import-1 using-package exported-sym)))) |
---|
968 | (resolve-all-by-uninterning-present |
---|
969 | () |
---|
970 | :test (lambda (&rest ignore) (declare (ignore ignore)) all-present) |
---|
971 | :report (lambda (s) (format s "UNINTERN all present conflicting symbol(s) in using package(s).")) |
---|
972 | (dolist (conflict conflicts (check-again)) |
---|
973 | (destructuring-bind (using-package inherited-sym) (cddr conflict) |
---|
974 | (unintern inherited-sym using-package)))) |
---|
975 | (resolve-all-by-shadowing-present |
---|
976 | () |
---|
977 | :test (lambda (&rest ignore) (declare (ignore ignore)) all-present) |
---|
978 | :report (lambda (s) (format s "SHADOW all present conflicting symbol(s) in using package(s).")) |
---|
979 | (dolist (conflict conflicts (check-again)) |
---|
980 | (destructuring-bind (using-package inherited-sym) (cddr conflict) |
---|
981 | (shadow-1 using-package inherited-sym)))) |
---|
982 | (review-and-resolve |
---|
983 | (dispositions) |
---|
984 | :report (lambda (s) (format s "Review each name conflict and resolve individually.")) |
---|
985 | :interactive (lambda () |
---|
986 | (let* ((disp nil)) |
---|
987 | (block b |
---|
988 | (catch-cancel |
---|
989 | (dolist (conflict conflicts (return-from b (list disp))) |
---|
990 | (destructuring-bind (inherited-p exported-sym using-package conflicting-sym) conflict |
---|
991 | (let* ((syms (list exported-sym conflicting-sym))) |
---|
992 | (if inherited-p |
---|
993 | (push (list 'shadowing-import |
---|
994 | (select-item-from-list syms |
---|
995 | :window-title |
---|
996 | (format nil "Shadowing-import one of the following in ~s" using-package) |
---|
997 | :table-print-function #'prin1) |
---|
998 | using-package) |
---|
999 | disp) |
---|
1000 | (let* ((selection (car (select-item-from-list syms |
---|
1001 | :window-title |
---|
1002 | (format nil "Shadow ~S or unintern ~s in ~s" |
---|
1003 | exported-sym |
---|
1004 | conflicting-sym using-package) |
---|
1005 | :table-print-function #'prin1)))) |
---|
1006 | (push (if (eq selection 'exported-sym) |
---|
1007 | (list 'shadow (list exported-sym) using-package) |
---|
1008 | (list 'unintern conflicting-sym using-package)) |
---|
1009 | disp))))))) |
---|
1010 | nil))) |
---|
1011 | (dolist (disp dispositions (check-again)) |
---|
1012 | (apply (car disp) (cdr disp)))))))) |
---|
1013 | |
---|
1014 | |
---|
1015 | (def-kernel-restart $xwrongtype default-require-type-restarts (frame-ptr value typespec) |
---|
1016 | (setq typespec (%type-error-type typespec)) |
---|
1017 | (let ((condition (make-condition 'type-error |
---|
1018 | :datum value |
---|
1019 | :expected-type typespec))) |
---|
1020 | (restart-case (%error condition nil frame-ptr) |
---|
1021 | (use-value (newval) |
---|
1022 | :report (lambda (s) |
---|
1023 | (format s "Use a new value of type ~s instead of ~s." typespec value)) |
---|
1024 | :interactive (lambda () |
---|
1025 | (format *query-io* "~&New value of type ~S :" typespec) |
---|
1026 | (list (read *query-io*))) |
---|
1027 | (require-type newval typespec))))) |
---|
1028 | |
---|
1029 | (def-kernel-restart $xudfcall default-undefined-function-call-restarts (frame-ptr function-name args) |
---|
1030 | (unless *level-1-loaded* |
---|
1031 | (dbg function-name)) ; user should never see this |
---|
1032 | (let ((condition (make-condition 'undefined-function-call |
---|
1033 | :name function-name |
---|
1034 | :function-arguments args)) |
---|
1035 | (other-functions (find-unique-homonyms function-name #'fboundp))) |
---|
1036 | (restart-case (%error condition nil frame-ptr) |
---|
1037 | (continue () |
---|
1038 | :report (lambda (s) (format s "Retry applying ~S to ~S." function-name args)) |
---|
1039 | (apply function-name args)) |
---|
1040 | (use-homonym (function-name) |
---|
1041 | :test (lambda (c) (and (or (null c) (eq c condition)) other-functions)) |
---|
1042 | :report (lambda (s) |
---|
1043 | (if (= 1 (length other-functions)) |
---|
1044 | (format s "Apply ~s to ~S this time." (first other-functions) args) |
---|
1045 | (format s "Apply one of ~{~S or ~} to ~S this time." |
---|
1046 | other-functions args))) |
---|
1047 | :interactive (lambda () |
---|
1048 | (if (= 1 (length other-functions)) |
---|
1049 | other-functions |
---|
1050 | (select-item-from-list other-functions :window-title "Select homonym to use"))) |
---|
1051 | (apply (fdefinition function-name) args)) |
---|
1052 | (use-value (function) |
---|
1053 | :interactive (lambda () |
---|
1054 | (format *query-io* "Function to apply instead of ~s :" function-name) |
---|
1055 | (let ((f (read *query-io*))) |
---|
1056 | (unless (symbolp f) (setq f (eval f))) ; almost-the-right-thing (tm) |
---|
1057 | (list (coerce f 'function)))) |
---|
1058 | :report (lambda (s) (format s "Apply specified function to ~S this time." args)) |
---|
1059 | (apply function args)) |
---|
1060 | (store-value (function) |
---|
1061 | :interactive (lambda () |
---|
1062 | (format *query-io* "Function to apply as new definition of ~s :" function-name) |
---|
1063 | (let ((f (read *query-io*))) |
---|
1064 | (unless (symbolp f) (setq f (eval f))) ; almost-the-right-thing (tm) |
---|
1065 | (list (coerce f 'function)))) |
---|
1066 | :report (lambda (s) (format s "Specify a function to use as the definition of ~S." function-name)) |
---|
1067 | (apply (setf (symbol-function function-name) function) args))))) |
---|
1068 | |
---|
1069 | |
---|
1070 | |
---|
1071 | (defun %check-type (value typespec placename typename) |
---|
1072 | (let ((condition (make-condition 'type-error |
---|
1073 | :datum value |
---|
1074 | :expected-type typespec))) |
---|
1075 | (if typename |
---|
1076 | (setf (slot-value condition 'format-control) |
---|
1077 | (format nil "value ~~S is not ~A (~~S)." typename))) |
---|
1078 | (restart-case (%error condition nil (%get-frame-ptr)) |
---|
1079 | (store-value (newval) |
---|
1080 | :report (lambda (s) |
---|
1081 | (format s "Assign a new value of type ~a to ~s" typespec placename)) |
---|
1082 | :interactive (lambda () |
---|
1083 | (format *query-io* "~&New value for ~S :" placename) |
---|
1084 | (list (eval (read)))) |
---|
1085 | newval)))) |
---|
1086 | |
---|
1087 | |
---|
1088 | ; This has to be defined fairly early (assuming, of course, that it "has" to be defined at all ... |
---|
1089 | |
---|
1090 | (defun ensure-value-of-type (value typespec placename &optional typename) |
---|
1091 | (tagbody |
---|
1092 | again |
---|
1093 | (unless (typep value typespec) |
---|
1094 | (let ((condition (make-condition 'type-error |
---|
1095 | :datum value |
---|
1096 | :expected-type typespec))) |
---|
1097 | (if typename |
---|
1098 | (setf (slot-value condition 'format-control) |
---|
1099 | (format nil "value ~~S is not ~A (~~S)." typename))) |
---|
1100 | (restart-case (%error condition nil (%get-frame-ptr)) |
---|
1101 | (store-value (newval) |
---|
1102 | :report (lambda (s) |
---|
1103 | (format s "Assign a new value of type ~a to ~s" typespec placename)) |
---|
1104 | :interactive (lambda () |
---|
1105 | (format *query-io* "~&New value for ~S :" placename) |
---|
1106 | (list (eval (read)))) |
---|
1107 | (setq value newval) |
---|
1108 | (go again)))))) |
---|
1109 | value) |
---|
1110 | |
---|
1111 | ;;;The Error Function |
---|
1112 | |
---|
1113 | (defparameter *kernel-simple-error-classes* |
---|
1114 | (list (cons $xcalltoofew 'simple-destructuring-error) |
---|
1115 | (cons $xcalltoomany 'simple-destructuring-error) |
---|
1116 | (cons $xstkover 'stack-overflow-condition) |
---|
1117 | (cons $xmemfull 'simple-storage-condition) |
---|
1118 | (cons $xwrongtype 'type-error) ; this one needs 2 args |
---|
1119 | (cons $xdivzro 'division-by-zero) |
---|
1120 | (cons $xflovfl 'floating-point-overflow) |
---|
1121 | (cons $xfunbnd 'undefined-function) |
---|
1122 | (cons $xbadkeys 'simple-program-error) |
---|
1123 | (cons $xcallnomatch 'simple-program-error) |
---|
1124 | (cons $xnotfun 'call-special-operator-or-macro) |
---|
1125 | (cons $xaccessnth 'sequence-index-type-error) |
---|
1126 | (cons $ximproperlist 'improper-list) |
---|
1127 | (cons $xnospread 'cant-construct-arglist) |
---|
1128 | (cons $xnotelt 'array-element-type-error) |
---|
1129 | )) |
---|
1130 | |
---|
1131 | |
---|
1132 | (defparameter *simple-error-types* |
---|
1133 | (vector nil 'simple-program-error 'simple-file-error)) |
---|
1134 | |
---|
1135 | (defconstant $pgm-err #x10000) |
---|
1136 | |
---|
1137 | |
---|
1138 | |
---|
1139 | |
---|
1140 | (defparameter %type-error-typespecs% |
---|
1141 | #(array |
---|
1142 | bignum |
---|
1143 | fixnum |
---|
1144 | character |
---|
1145 | integer |
---|
1146 | list |
---|
1147 | number |
---|
1148 | sequence |
---|
1149 | simple-string |
---|
1150 | simple-vector |
---|
1151 | string |
---|
1152 | symbol |
---|
1153 | macptr |
---|
1154 | real |
---|
1155 | cons |
---|
1156 | unsigned-byte |
---|
1157 | (integer 2 36) |
---|
1158 | float |
---|
1159 | rational |
---|
1160 | ratio |
---|
1161 | short-float |
---|
1162 | double-float |
---|
1163 | complex |
---|
1164 | vector |
---|
1165 | simple-base-string |
---|
1166 | function |
---|
1167 | (unsigned-byte 16) |
---|
1168 | (unsigned-byte 8) |
---|
1169 | (unsigned-byte 32) |
---|
1170 | (signed-byte 32) |
---|
1171 | (signed-byte 16) |
---|
1172 | (signed-byte 8) |
---|
1173 | base-char |
---|
1174 | bit |
---|
1175 | (unsigned-byte 24) ; (integer 0 (array-total-size-limit)) |
---|
1176 | (unsigned-byte 64) |
---|
1177 | (signed-byte 64) |
---|
1178 | (unsigned-byte 56) |
---|
1179 | (simple-array double-float (* *)) |
---|
1180 | (simple-array single-float (* *)) |
---|
1181 | (mod #x110000) |
---|
1182 | (array * (* *)) ;2d array |
---|
1183 | (array * (* * *)) ;3d array |
---|
1184 | (array t) |
---|
1185 | (array bit) |
---|
1186 | (array (signed-byte 8)) |
---|
1187 | (array (unsigned-byte 8)) |
---|
1188 | (array (signed-byte 16)) |
---|
1189 | (array (unsigned-byte 16)) |
---|
1190 | (array (signed-byte 32)) |
---|
1191 | (array (unsigned-byte 32)) |
---|
1192 | (array (signed-byte 64)) |
---|
1193 | (array (unsigned-byte 64)) |
---|
1194 | (array fixnum) |
---|
1195 | (array single-float) |
---|
1196 | (array double-float) |
---|
1197 | (array character) |
---|
1198 | (array t (* *)) |
---|
1199 | (array bit (* *)) |
---|
1200 | (array (signed-byte 8) (* *)) |
---|
1201 | (array (unsigned-byte 8) (* *)) |
---|
1202 | (array (signed-byte 16) (* *)) |
---|
1203 | (array (unsigned-byte 16) (* *)) |
---|
1204 | (array (signed-byte 32) (* *)) |
---|
1205 | (array (unsigned-byte 32) (* *)) |
---|
1206 | (array (signed-byte 64) (* *)) |
---|
1207 | (array (unsigned-byte 64) (* *)) |
---|
1208 | (array fixnum (* *)) |
---|
1209 | (array single-float (* *)) |
---|
1210 | (array double-float (* *)) |
---|
1211 | (array character (* *)) |
---|
1212 | (simple-array t (* *)) |
---|
1213 | (simple-array bit (* *)) |
---|
1214 | (simple-array (signed-byte 8) (* *)) |
---|
1215 | (simple-array (unsigned-byte 8) (* *)) |
---|
1216 | (simple-array (signed-byte 16) (* *)) |
---|
1217 | (simple-array (unsigned-byte 16) (* *)) |
---|
1218 | (simple-array (signed-byte 32) (* *)) |
---|
1219 | (simple-array (unsigned-byte 32) (* *)) |
---|
1220 | (simple-array (signed-byte 64) (* *)) |
---|
1221 | (simple-array (unsigned-byte 64) (* *)) |
---|
1222 | (simple-array fixnum (* *)) |
---|
1223 | (simple-array character (* *)) |
---|
1224 | (array t (* * *)) |
---|
1225 | (array bit (* * *)) |
---|
1226 | (array (signed-byte 8) (* * *)) |
---|
1227 | (array (unsigned-byte 8) (* * *)) |
---|
1228 | (array (signed-byte 16) (* * *)) |
---|
1229 | (array (unsigned-byte 16) (* * *)) |
---|
1230 | (array (signed-byte 32) (* * *)) |
---|
1231 | (array (unsigned-byte 32) (* * *)) |
---|
1232 | (array (signed-byte 64) (* * *)) |
---|
1233 | (array (unsigned-byte 64) (* * *)) |
---|
1234 | (array fixnum (* * *)) |
---|
1235 | (array single-float (* * *)) |
---|
1236 | (array double-float (* * *)) |
---|
1237 | (array character (* * *)) |
---|
1238 | (simple-array t (* * *)) |
---|
1239 | (simple-array bit (* * *)) |
---|
1240 | (simple-array (signed-byte 8) (* * *)) |
---|
1241 | (simple-array (unsigned-byte 8) (* * *)) |
---|
1242 | (simple-array (signed-byte 16) (* * *)) |
---|
1243 | (simple-array (unsigned-byte 16) (* * *)) |
---|
1244 | (simple-array (signed-byte 32) (* * *)) |
---|
1245 | (simple-array (unsigned-byte 32) (* * *)) |
---|
1246 | (simple-array (signed-byte 64) (* * *)) |
---|
1247 | (simple-array (unsigned-byte 64) (* * *)) |
---|
1248 | (simple-array fixnum (* * *)) |
---|
1249 | (simple-array single-float (* * *)) |
---|
1250 | (simple-array double-float (* * *)) |
---|
1251 | (simple-array character (* * *)) |
---|
1252 | |
---|
1253 | (vector t) |
---|
1254 | bit-vector |
---|
1255 | (vector (signed-byte 8)) |
---|
1256 | (vector (unsigned-byte 8)) |
---|
1257 | (vector (signed-byte 16)) |
---|
1258 | (vector (unsigned-byte 16)) |
---|
1259 | (vector (signed-byte 32)) |
---|
1260 | (vector (unsigned-byte 32)) |
---|
1261 | (vector (signed-byte 64)) |
---|
1262 | (vector (unsigned-byte 64)) |
---|
1263 | (vector fixnum) |
---|
1264 | (vector single-float) |
---|
1265 | (vector double-float) |
---|
1266 | |
---|
1267 | )) |
---|
1268 | |
---|
1269 | |
---|
1270 | (defun %type-error-type (type) |
---|
1271 | (if (fixnump type) |
---|
1272 | (svref %type-error-typespecs% type) |
---|
1273 | type)) |
---|
1274 | |
---|
1275 | (defun %typespec-id (typespec) |
---|
1276 | (flet ((type-equivalent (t1 t2) (ignore-errors (and (subtypep t1 t2) (subtypep t2 t1))))) |
---|
1277 | (position typespec %type-error-typespecs% :test #'type-equivalent))) |
---|
1278 | |
---|
1279 | |
---|
1280 | (defmethod condition-p ((x t)) nil) |
---|
1281 | (defmethod condition-p ((x condition)) t) |
---|
1282 | |
---|
1283 | |
---|
1284 | |
---|
1285 | (let* ((globals ())) |
---|
1286 | |
---|
1287 | (defun %check-error-globals () |
---|
1288 | (let ((vars ()) |
---|
1289 | (valfs ()) |
---|
1290 | (oldvals ())) |
---|
1291 | (dolist (g globals (values vars valfs oldvals)) |
---|
1292 | (destructuring-bind (sym predicate newvalf) g |
---|
1293 | (let* ((boundp (boundp sym)) |
---|
1294 | (oldval (if boundp (symbol-value sym) (%unbound-marker-8)))) |
---|
1295 | (unless (and boundp (funcall predicate oldval)) |
---|
1296 | (push sym vars) |
---|
1297 | (push oldval oldvals) |
---|
1298 | (push newvalf valfs))))))) |
---|
1299 | |
---|
1300 | (defun check-error-global (sym checkfn newvalfn) |
---|
1301 | (setq sym (require-type sym 'symbol) |
---|
1302 | checkfn (require-type checkfn 'function) |
---|
1303 | newvalfn (require-type newvalfn 'function)) |
---|
1304 | (let ((found (assq sym globals))) |
---|
1305 | (if found |
---|
1306 | (setf (cadr found) checkfn (caddr found) newvalfn) |
---|
1307 | (push (list sym checkfn newvalfn) globals)) |
---|
1308 | sym)) |
---|
1309 | ) |
---|
1310 | |
---|
1311 | (check-error-global '*package* #'packagep #'(lambda () (find-package "CL-USER"))) |
---|
1312 | |
---|
1313 | |
---|
1314 | (flet ((io-stream-p (x) (and (streamp x) (eq (stream-direction x) :io))) |
---|
1315 | (input-stream-p (x) (and (streamp x) (input-stream-p x))) |
---|
1316 | (output-stream-p (x) (and (streamp x) (output-stream-p x))) |
---|
1317 | (default-terminal-io () (make-echoing-two-way-stream *stdin* *stdout*)) |
---|
1318 | (terminal-io () *terminal-io*) |
---|
1319 | (standard-output () *standard-output*)) |
---|
1320 | |
---|
1321 | ;; Note that order matters. These need to come out of %check-error-globals with |
---|
1322 | ;; *terminal-io* first and *trace-output* last |
---|
1323 | (check-error-global '*terminal-io* #'io-stream-p #'default-terminal-io) |
---|
1324 | (check-error-global '*query-io* #'io-stream-p #'terminal-io) |
---|
1325 | (check-error-global '*debug-io* #'io-stream-p #'terminal-io) |
---|
1326 | (check-error-global '*standard-input* #'input-stream-p #'terminal-io) |
---|
1327 | (check-error-global '*standard-output* #'output-stream-p #'terminal-io) |
---|
1328 | (check-error-global '*error-output* #'output-stream-p #'standard-output) |
---|
1329 | (check-error-global '*trace-output* #'output-stream-p #'standard-output)) |
---|
1330 | |
---|