4 |
|
|
5 |
(defvar *internal-error-table* (make-hash-table :test 'equal)) |
(defvar *internal-error-table* (make-hash-table :test 'equal)) |
6 |
|
|
7 |
(defmacro find-internal-error-data (error-name error-format-string) |
;(defmacro find-internal-error-data (error-name error-format-string) |
8 |
`(gethash (list ,error-name ,error-format-string) *internal-error-table*)) |
; `(gethash (list ,error-name ,error-format-string) *internal-error-table*)) |
9 |
|
(defmacro find-internal-error-data (error-name) |
10 |
|
`(gethash (list ,error-name) *internal-error-table*)) |
11 |
|
|
12 |
|
;(defun clcs-universal-error-handler (error-name correctable function-name |
13 |
|
; continue-format-string error-format-string |
14 |
|
; &rest args) |
15 |
|
; (if correctable |
16 |
|
; (with-simple-restart |
17 |
|
; (continue "~a" (apply #'format nil continue-format-string args)) |
18 |
|
; (error 'internal-simple-error |
19 |
|
; :function-name function-name |
20 |
|
; :format-string error-format-string |
21 |
|
; :format-arguments args)) |
22 |
|
; (let ((e-d (find-internal-error-data error-name error-format-string))) |
23 |
|
; (if e-d |
24 |
|
; (let ((condition-name (car e-d))) |
25 |
|
; (apply #'error condition-name |
26 |
|
; :function-name function-name |
27 |
|
; (let ((k-a (mapcan #'list (cdr e-d) args))) |
28 |
|
; (if (simple-condition-class-p condition-name) |
29 |
|
; (list* :format-string error-format-string |
30 |
|
; :format-arguments args |
31 |
|
; k-a) |
32 |
|
; k-a)))) |
33 |
|
; (error 'internal-simple-error :function-name function-name |
34 |
|
; :format-string error-format-string :format-arguments args))))) |
35 |
|
|
36 |
(defun clcs-universal-error-handler (error-name correctable function-name |
(defun clcs-universal-error-handler (error-name correctable function-name |
37 |
continue-format-string error-format-string |
continue-format-string error-format-string |
38 |
&rest args) |
&rest args) |
39 |
(if correctable |
(let ((e-d (find-internal-error-data error-name))) |
40 |
(with-simple-restart |
(if e-d |
41 |
(continue "~a" (apply #'format nil continue-format-string args)) |
(let ((condition-name (car e-d))) |
42 |
(error 'internal-simple-error |
(if correctable |
43 |
:function-name function-name |
(with-simple-restart |
44 |
:format-string error-format-string |
(continue "~a" (apply #'format nil continue-format-string args)) |
45 |
:format-arguments args)) |
(apply #'error condition-name |
46 |
(let ((e-d (find-internal-error-data error-name error-format-string))) |
:function-name function-name |
47 |
(if e-d |
(let ((k-a (mapcan #'list (cdr e-d) args))) |
48 |
(let ((condition-name (car e-d))) |
(if (simple-condition-class-p condition-name) |
49 |
(apply #'error condition-name |
(list* :format-string error-format-string |
50 |
:function-name function-name |
:format-arguments args |
51 |
(let ((k-a (mapcan #'list (cdr e-d) args))) |
k-a) |
52 |
(if (simple-condition-class-p condition-name) |
k-a)))) |
53 |
(list* :format-string error-format-string |
(apply #'error condition-name |
54 |
:format-arguments args |
:function-name function-name |
55 |
k-a) |
(let ((k-a (mapcan #'list (cdr e-d) args))) |
56 |
k-a)))) |
(if (simple-condition-class-p condition-name) |
57 |
(error 'internal-simple-error :function-name function-name |
(list* :format-string error-format-string |
58 |
:format-string error-format-string :format-arguments args))))) |
:format-arguments args |
59 |
|
k-a) |
60 |
|
k-a))))) |
61 |
|
(error 'internal-simple-error :function-name function-name |
62 |
|
:format-string error-format-string :format-arguments args)))) |
63 |
|
|
64 |
(defun set-internal-error (error-keyword error-format condition-name |
(defun set-internal-error (error-keyword error-format condition-name |
65 |
&rest keyword-list) |
&rest keyword-list) |
66 |
(setf (find-internal-error-data error-keyword error-format) |
; (setf (find-internal-error-data error-keyword error-format) |
67 |
|
(setf (find-internal-error-data error-keyword) |
68 |
(cons condition-name keyword-list))) |
(cons condition-name keyword-list))) |
69 |
|
|
70 |
(defun initialize-internal-error-table () |
(defun initialize-internal-error-table () |
76 |
(defparameter *internal-error-list* |
(defparameter *internal-error-list* |
77 |
'(("FEwrong_type_argument" :wrong-type-argument "~S is not of type ~S." |
'(("FEwrong_type_argument" :wrong-type-argument "~S is not of type ~S." |
78 |
internal-type-error :datum :expected-type) |
internal-type-error :datum :expected-type) |
79 |
|
("FEpackage_error" :package-error "A package error occurred on ~S:~S." |
80 |
|
internal-package-error) ; |<function>| |top - base| |
81 |
("FEtoo_few_arguments" :too-few-arguments "~S [or a callee] requires more than ~R argument~:p." |
("FEtoo_few_arguments" :too-few-arguments "~S [or a callee] requires more than ~R argument~:p." |
82 |
internal-simple-control-error) ; |<function>| |top - base| |
internal-simple-control-error) ; |<function>| |top - base| |
83 |
("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments." |
("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments." |