1 |
|
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- |
2 |
|
|
3 |
|
(in-package "CONDITIONS") |
4 |
|
|
5 |
|
(defvar *internal-error-table* (make-hash-table :test 'equal)) |
6 |
|
|
7 |
|
(defmacro find-internal-error-data (error-name error-format-string) |
8 |
|
`(gethash (list ,error-name ,error-format-string) *internal-error-table*)) |
9 |
|
|
10 |
|
(defvar *internal-error-parms* nil) |
11 |
|
|
12 |
|
(defun clcs-universal-error-handler (error-name correctable function-name |
13 |
|
continue-format-string error-format-string |
14 |
|
&rest args |
15 |
|
&aux (internal-error-parms |
16 |
|
(list error-name correctable function-name |
17 |
|
continue-format-string error-format-string))) |
18 |
|
(when (equal internal-error-parms *internal-error-parms*) |
19 |
|
(format t "Universal error handler called recursively ~S~%" |
20 |
|
internal-error-parms) |
21 |
|
(return-from clcs-universal-error-handler)) |
22 |
|
(let* ((*internal-error-parms* (list error-name |
23 |
|
correctable |
24 |
|
function-name |
25 |
|
continue-format-string |
26 |
|
error-format-string)) |
27 |
|
(e-d (or (find-internal-error-data error-name error-format-string) |
28 |
|
(find-internal-error-data error-name t)))) |
29 |
|
(if e-d |
30 |
|
(let ((condition-name (car e-d))) |
31 |
|
(if correctable |
32 |
|
(with-simple-restart |
33 |
|
(continue "~a" (apply #'format nil continue-format-string args)) |
34 |
|
(apply #'error condition-name |
35 |
|
:function-name function-name |
36 |
|
(let ((k-a (mapcan #'list (cdr e-d) args))) |
37 |
|
(if (simple-condition-class-p condition-name) |
38 |
|
(list* :format-string error-format-string |
39 |
|
:format-arguments args |
40 |
|
k-a) |
41 |
|
k-a)))) |
42 |
|
(apply #'error condition-name |
43 |
|
:function-name function-name |
44 |
|
(let ((k-a (mapcan #'list (cdr e-d) args))) |
45 |
|
(if (simple-condition-class-p condition-name) |
46 |
|
(list* :format-string error-format-string |
47 |
|
:format-arguments args |
48 |
|
k-a) |
49 |
|
k-a))))) |
50 |
|
(if correctable |
51 |
|
(with-simple-restart |
52 |
|
(continue "~a" (apply #'format nil continue-format-string args)) |
53 |
|
(error 'internal-simple-error |
54 |
|
:function-name function-name |
55 |
|
:format-string error-format-string |
56 |
|
:format-arguments args)) |
57 |
|
(error 'internal-simple-error |
58 |
|
:function-name function-name |
59 |
|
:format-string error-format-string |
60 |
|
:format-arguments args) |
61 |
|
)))) |
62 |
|
|
63 |
|
(defun set-internal-error (error-keyword error-format condition-name |
64 |
|
&rest keyword-list) |
65 |
|
(setf (find-internal-error-data error-keyword error-format) |
66 |
|
(cons condition-name keyword-list))) |
67 |
|
|
68 |
|
(defun initialize-internal-error-table () |
69 |
|
(declare (special *internal-error-list*)) |
70 |
|
(clrhash *internal-error-table*) |
71 |
|
(dolist (error-data *internal-error-list*) |
72 |
|
(apply #'set-internal-error error-data))) |
73 |
|
|
74 |
|
(defparameter *internal-error-list* |
75 |
|
'((:control-error "control error" internal-simple-control-error) |
76 |
|
(:error "The argument ~S for ~S, is a logarithmic singularity." arithmetic-error :operands :operation) |
77 |
|
(:error "APPLY sended too few arguments to LAMBDA." internal-simple-control-error) |
78 |
|
(:error "APPLY sended too few arguments to LAMBDA." internal-simple-control-error) |
79 |
|
(:error "Expected ~S args but received ~S args" internal-simple-control-error) |
80 |
|
(:error "Keywords and values do not match." internal-simple-program-error) ;?? |
81 |
|
(:error "Wrong number of args" internal-simple-program-error) |
82 |
|
(:error "~S is an illegal index to ~S." internal-simple-error) |
83 |
|
(:error "~S is not a keyword." internal-simple-program-error) ;?? |
84 |
|
(:invalid-form "Invalid macro call to ~S." internal-simple-program-error) ; |<function>| |
85 |
|
(:invalid-form "~S is an illegal declaration form." internal-simple-program-error) |
86 |
|
(:invalid-variable "~S is an invalid variable." internal-simple-program-error ) ; |obj| |
87 |
|
(:package-error "A package error occurred on ~S: ~S." internal-package-error :package :message) ; |<function>| |top - base| |
88 |
|
(:parse-error "parse error" internal-simple-parse-error) ; |<function>| |top - base| |
89 |
|
(:too-few-arguments "~S [or a callee] requires more than ~R argument~:p." internal-simple-program-error) ; |<function>| |top - base| |
90 |
|
(:too-few-arguments "Symbol type specifiers must be supplied." internal-simple-program-error) |
91 |
|
(:too-many-arguments "~S [or a callee] requires only ~R argument~:p,~% but ~R ~:*~[were~;was~:;were~] supplied." internal-simple-program-error) ; |<function>| |n| |top - base| |
92 |
|
(:too-many-arguments "~S [or a callee] requires less than ~R argument~:p." internal-simple-program-error) ; |<function>| |top - base| |
93 |
|
(:unbound-variable "The variable ~S is unbound." internal-unbound-variable :name) ; |sym| |
94 |
|
(:undefined-function "The function ~S is undefined." internal-undefined-function :name) |
95 |
|
(:unexpected-keyword "~S does not allow the keyword ~S." internal-simple-program-error) ; |<function>| |key| |
96 |
|
(:wrong-type-argument "~S is not of type ~S." internal-type-error :datum :expected-type) |
97 |
|
(:wrong-type-argument "Cannot coerce ~S to class ~S." internal-type-error :datum :expected-type) |
98 |
|
(:wrong-type-argument "The value of ~S is not ~S." internal-type-error :datum :expected-type) |
99 |
|
(:wrong-type-argument "The value of ~S is not of type ~S." internal-type-error :datum :expected-type) |
100 |
|
(:wrong-type-argument "The value of ~S is not ~S, but ~S." internal-type-error :datum :expected-type) |
101 |
|
(:wrong-type-argument "The value of ~S is not of type ~S, but ~S." internal-type-error :datum :expected-type) |
102 |
|
|
103 |
|
; those had been commented out before - have to check them |
104 |
|
; (:too-few-arguments "~S [or a callee] requires ~R argument~:p,~% but only ~R ~:*~[were~;was~:;were~] supplied." internal-simple-program-error) ; |<function>| |n| |top - base| |
105 |
|
; (:invalid-function "~S is invalid as a function." internal-type-error :datum :expected-type) ; |obj| |
106 |
|
; (:invalid-variable "~S is not a symbol." internal-simple-error) ;?? |
107 |
|
; (:invalid-variable "~S is not a variable." internal-simple-program-error) |
108 |
|
; (:too-few-arguments "Too few arguments." internal-simple-control-error) ; |<function>| |args| |
109 |
|
; (:too-many-arguments "Too many arguments." internal-simple-control-error) ; |<function>| |args| |
110 |
|
|
111 |
|
(:error "Cannot create the file ~A." internal-simple-file-error :pathname) |
112 |
|
(:error "Cannot open the file ~A." internal-simple-file-error :pathname) |
113 |
|
(:error "Cannot read the stream ~S." internal-simple-stream-error :stream) |
114 |
|
(:error "Cannot write to the stream ~S." internal-simple-stream-error :stream) |
115 |
|
(:error "Cannot close the standard input." internal-simple-stream-error) ; no stream here!! |
116 |
|
(:error "Cannot close the standard output." internal-simple-stream-error) ; no stream here!! |
117 |
|
(:error "Unexpected end of ~S." internal-end-of-file :stream) |
118 |
|
(:error "Cannot append to the file ~A." internal-simple-file-error :pathname) |
119 |
|
(:error "The file ~A already exists." internal-simple-file-error :pathname) |
120 |
|
(:error "The file ~A does not exist." internal-simple-file-error :pathname) |
121 |
|
(:error "~S is an illegal IF-DOES-NOT-EXIST option." internal-simple-control-error) |
122 |
|
(:error "~S is an illegal IF-EXISTS option." internal-simple-control-error) |
123 |
|
(:error "~S is a too long file name." internal-simple-file-error :pathname) |
124 |
|
(:error "Illegal open mode for ~S." internal-simple-control-error) |
125 |
|
|
126 |
|
(:pathname-error "Invalid device in pathname ~S." internal-simple-file-error :pathname) |
127 |
|
(:pathname-error "Invalid device in logical pathname ~S." internal-simple-file-error :pathname) |
128 |
|
(:pathname-error "Invalid directory in logical pathname ~S." internal-simple-file-error :pathname) |
129 |
|
(:pathname-error "Invalid directory in pathname ~S." internal-simple-file-error :pathname) |
130 |
|
(:pathname-error "Invalid host in logical pathname ~S." internal-simple-file-error :pathname) |
131 |
|
(:pathname-error "Invalid host in pathname ~S." internal-simple-file-error :pathname) |
132 |
|
(:pathname-error "The pathname ~S does not match the host." internal-simple-file-error :pathname) |
133 |
|
(:pathname-error "Invalid name in pathname ~S." internal-simple-file-error :pathname) |
134 |
|
(:pathname-error "Invalid 4th name component in namestring ~S." internal-simple-file-error :pathname) |
135 |
|
(:pathname-error "Invalid blank component in namestring ~S." internal-simple-file-error :pathname) |
136 |
|
(:pathname-error "Invalid component in namestring ~S." internal-simple-file-error :pathname) |
137 |
|
(:pathname-error "Invalid character in logical pathname namestring ~S." internal-simple-file-error :pathname) |
138 |
|
(:pathname-error "Invalid device or host in namestring ~S." internal-simple-file-error :pathname) |
139 |
|
(:pathname-error "Invalid type in pathname ~S." internal-simple-file-error :pathname) |
140 |
|
(:pathname-error "Invalid version in pathname ~S." internal-simple-file-error :pathname) |
141 |
|
(:pathname-error "Translate logical pathname ~S recursion stop." internal-simple-file-error :pathname) |
142 |
|
(:pathname-error "No translation matches ~S." internal-simple-file-error :pathname) |
143 |
|
(:pathname-error "File ~S is wild." internal-simple-file-error :pathname) |
144 |
|
(:pathname-error "File ~S does not exist." internal-simple-file-error :pathname) |
145 |
|
(:pathname-error "Cannot change the current directory to ~S." internal-simple-file-error :pathname) |
146 |
|
(:pathname-error "Cannot make the directory ~S." internal-simple-file-error :pathname) |
147 |
|
(:pathname-error "Cannot remove the directory ~S." internal-simple-file-error :pathname) |
148 |
|
|
149 |
|
(:pathname-error "Cannot find host ~S." internal-simple-control-error) |
150 |
|
(:pathname-error "Invalid key for wild-pathname-p ~S." internal-simple-control-error) |
151 |
|
(:pathname-error "Token overrun at ~S." internal-simple-control-error) |
152 |
|
(:pathname-error "Invalid pathname component ~S." internal-simple-control-error) |
153 |
|
|
154 |
|
(:pathname-error "Pathname ~S is not a ~S." internal-type-error :datum :expected-type) |
155 |
|
(:pathname-error "Cannot coerce ~S to a ~S." internal-type-error :datum :expected-type) |
156 |
|
(:pathname-error "Cannot coerce ~S to a ~S namestring." internal-type-error :datum :expected-type) |
157 |
|
(:pathname-error "Cannot parse the namestring stream ~S to a ~S." internal-type-error :datum :expected-type) |
158 |
|
(:pathname-error "Cannot parse the namestring thing ~S to a ~S." internal-type-error :datum :expected-type) |
159 |
|
|
160 |
|
; those can be matched by a simple t |
161 |
|
(:error t internal-simple-error) |
162 |
|
(:too-few-arguments t internal-simple-control-error) |
163 |
|
(:too-many-arguments t internal-simple-control-error) |
164 |
|
(:control-error t internal-simple-control-error) |
165 |
|
(:unexpected-keyword t internal-simple-control-error) |
166 |
|
(:parse-error t internal-simple-parse-error) |
167 |
|
(:invalid-form t internal-simple-program-error) |
168 |
|
(:invalid-variable t internal-simple-program-error ) |
169 |
|
|
170 |
|
; those MUST NOT be matched by a simple t - as they have arguments. |
171 |
|
; (:unbound-variable t internal-unbound-variable :name) |
172 |
|
; (:undefined-function t internal-undefined-function :name) |
173 |
|
; (:wrong-type-argument t internal-type-error :datum :expected-type) |
174 |
|
; (:invalid-function t internal-type-error :datum :expected-type) |
175 |
|
; (:package-error t internal-package-error :package :message) |
176 |
|
)) |
177 |
|
|
178 |
|
(initialize-internal-error-table) |
179 |
|
|
180 |
|
(defun condition-backtrace (condition) |
181 |
|
(let* ((*debug-io* *error-output*) |
182 |
|
(si::*ihs-base* (1+ si::*ihs-top*)) |
183 |
|
(si::*ihs-top* (1- (si::ihs-top))) |
184 |
|
(si::*current-ihs* si::*ihs-top*) |
185 |
|
(si::*frs-base* (or (si::sch-frs-base si::*frs-top* si::*ihs-base*) |
186 |
|
(1+ (si::frs-top)))) |
187 |
|
(si::*frs-top* (si::frs-top)) |
188 |
|
(si::*break-env* nil)) |
189 |
|
(format *error-output* "~%~A~%" condition) |
190 |
|
(si::simple-backtrace))) |
191 |
|
|
192 |
|
(defvar *error-set-break-p* nil) |
193 |
|
|
194 |
|
(defun clcs-error-set (form) |
195 |
|
(let ((cond nil)) |
196 |
|
(restart-case (handler-bind ((error #'(lambda (condition) |
197 |
|
(unless (or si::*break-enable* |
198 |
|
*error-set-break-p*) |
199 |
|
(condition-backtrace condition) |
200 |
|
(return-from clcs-error-set condition)) |
201 |
|
(setq cond condition) |
202 |
|
nil))) |
203 |
|
(values-list (cons nil (multiple-value-list (eval form))))) |
204 |
|
(si::error-set () |
205 |
|
:report (lambda (stream) |
206 |
|
(format stream "~S" `(si::error-set ',form))) |
207 |
|
cond)))) |
208 |
|
|
209 |
|
(eval-when (compile load eval) |
210 |
|
|
211 |
|
(defun reset-function (symbol) ; invoke compiler::compiler-clear-compiler-properties |
212 |
|
(setf (symbol-function symbol) (symbol-function symbol))) |
213 |
|
|
214 |
|
(reset-function 'si::error-set) |
215 |
|
(reset-function 'load) |
216 |
|
(reset-function 'open) |
217 |
|
) |
218 |
|
|
219 |
|
(setq compiler::*compiler-break-enable* t) |
220 |
|
|
221 |
|
(defun compiler::cmp-toplevel-eval (form) |
222 |
|
(let* (;;(si::*ihs-base* si::*ihs-top*) ; show the whole stack |
223 |
|
(si::*ihs-top* (1- (si::ihs-top))) |
224 |
|
(*break-enable* compiler::*compiler-break-enable*) |
225 |
|
(si::*break-hidden-packages* |
226 |
|
(cons (find-package 'compiler) |
227 |
|
si::*break-hidden-packages*))) |
228 |
|
(si:error-set form))) |