1
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
3
(in-package "CONDITIONS")
5
(defvar *internal-error-table* (make-hash-table :test 'equal))
7
;(defmacro find-internal-error-data (error-name error-format-string)
8
; `(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*))
12
;(defun clcs-universal-error-handler (error-name correctable function-name
13
; continue-format-string error-format-string
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)))
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
33
; (error 'internal-simple-error :function-name function-name
34
; :format-string error-format-string :format-arguments args)))))
36
(defvar *internal-error-parms* nil)
38
(defun clcs-universal-error-handler (error-name correctable function-name
39
continue-format-string error-format-string
41
&aux (internal-error-parms
42
(list error-name correctable function-name
43
continue-format-string error-format-string)))
44
(when (equal internal-error-parms *internal-error-parms*)
45
(format t "Universal error handler called recursively ~S~%"
47
(return-from clcs-universal-error-handler))
48
(let* ((*internal-error-parms* (list error-name correctable function-name
49
continue-format-string error-format-string))
50
(e-d (find-internal-error-data error-name)))
52
(let ((condition-name (car e-d)))
55
(continue "~a" (apply #'format nil continue-format-string args))
56
(apply #'error condition-name
57
:function-name function-name
58
(let ((k-a (mapcan #'list (cdr e-d) args)))
59
(if (simple-condition-class-p condition-name)
60
(list* :format-string error-format-string
61
:format-arguments args
64
(apply #'error condition-name
65
:function-name function-name
66
(let ((k-a (mapcan #'list (cdr e-d) args)))
67
(if (simple-condition-class-p condition-name)
68
(list* :format-string error-format-string
69
:format-arguments args
72
(error 'internal-simple-error :function-name function-name
73
:format-string error-format-string :format-arguments args))))
75
(defun set-internal-error (error-keyword error-format condition-name
77
(declare (ignore error-format))
78
; (setf (find-internal-error-data error-keyword error-format)
79
(setf (find-internal-error-data error-keyword)
80
(cons condition-name keyword-list)))
82
(defun initialize-internal-error-table ()
83
(declare (special *internal-error-list*))
84
(clrhash *internal-error-table*)
85
(dolist (error-data *internal-error-list*)
86
(apply #'set-internal-error (cdr error-data))))
88
(defparameter *internal-error-list*
89
'(("FEwrong_type_argument" :wrong-type-argument "~S is not of type ~S."
90
internal-type-error :datum :expected-type)
91
("FEpackage_error" :package-error "A package error occurred on ~S: ~S."
92
internal-package-error :package :message) ; |<function>| |top - base|
93
("FEtoo_few_arguments" :too-few-arguments "~S [or a callee] requires more than ~R argument~:p."
94
internal-simple-program-error) ; |<function>| |top - base|
95
("FEparse_error" :parse-error "parse error"
96
internal-simple-parse-error) ; |<function>| |top - base|
97
; ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments."
98
; internal-simple-control-error) ; |<function>| |args|
99
("FEtoo_many_arguments" :too-many-arguments "~S [or a callee] requires less than ~R argument~:p."
100
internal-simple-program-error) ; |<function>| |top - base|
101
; ("FEtoo_many_argumentsF" :too-many-arguments "Too many arguments."
102
; internal-simple-control-error) ; |<function>| |args|
103
("FEinvalid_macro_call" :invalid-form "Invalid macro call to ~S."
104
internal-simple-program-error) ; |<function>|
105
("FEunexpected_keyword" :unexpected-keyword "~S does not allow the keyword ~S."
106
internal-simple-program-error) ; |<function>| |key|
107
("FEunbound_variable" :unbound-variable "The variable ~S is unbound."
108
internal-unbound-variable :name) ; |sym|
109
("FEundefined_function" :undefined-function "The function ~S is undefined."
110
internal-undefined-function :name)
111
("FEinvalid_function" :invalid-function "~S is invalid as a function."
112
internal-type-error :datum :expected-type) ; |obj|
113
("FEinvalid_variable" :invalid-variable "~S is an invalid variable."
114
internal-simple-program-error ) ; |obj|
115
("check_arg_failed" :too-few-arguments "~S [or a callee] requires ~R argument~:p,~%\
116
but only ~R ~:*~[were~;was~:;were~] supplied."
117
internal-simple-program-error) ; |<function>| |n| |top - base|
118
; ("check_arg_failed" :too-many-arguments "~S [or a callee] requires only ~R argument~:p,~%\
119
;but ~R ~:*~[were~;was~:;were~] supplied."
120
; internal-simple-program-error) ; |<function>| |n| |top - base|
121
("ck_larg_at_least" :error "APPLY sended too few arguments to LAMBDA."
122
internal-simple-control-error)
123
("ck_larg_exactly" :error "APPLY sended too few arguments to LAMBDA."
124
internal-simple-control-error)
125
("keyword_value_mismatch" :error "Keywords and values do not match."
126
internal-simple-program-error) ;??
127
("not_a_keyword" :error "~S is not a keyword."
128
internal-simple-program-error) ;??
129
("illegal_declare" :invalid-form "~S is an illegal declaration form."
130
internal-simple-program-error)
131
; ("not_a_symbol" :invalid-variable "~S is not a symbol."
132
; internal-simple-error) ;??
133
; ("not_a_variable" :invalid-variable "~S is not a variable."
134
; internal-simple-program-error)
135
("illegal_index" :error "~S is an illegal index to ~S."
136
internal-simple-error)
137
("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args"
138
internal-simple-control-error)
139
("end_of_stream" :error "Unexpected end of ~S."
140
internal-end-of-file :stream)
141
("open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option."
142
internal-simple-control-error)
143
("open_stream" :error "The file ~A already exists."
144
internal-simple-file-error :pathname)
145
("open_stream" :error "Cannot append to the file ~A."
146
internal-simple-file-error :pathname)
147
("open_stream" :error "~S is an illegal IF-EXISTS option."
148
internal-simple-control-error)
149
("control error" :control-error "control error"
150
internal-simple-control-error)
151
("close_stream" :error "Cannot close the standard output."
152
internal-simple-stream-error) ; no stream here!!
153
("close_stream" :error "Cannot close the standard input."
154
internal-simple-stream-error) ; no stream here!!
155
("too_long_file_name" :error "~S is a too long file name."
156
internal-simple-file-error :pathname)
157
("cannot_open" :error "Cannot open the file ~A."
158
internal-simple-file-error :pathname)
159
("cannot_create" :error "Cannot create the file ~A."
160
internal-simple-file-error :pathname)
161
("cannot_read" :error "Cannot read the stream ~S."
162
internal-simple-stream-error :stream)
163
("cannot_write" :error "Cannot write to the stream ~S."
164
internal-simple-stream-error :stream)
165
("" :error "" internal-simple-error)
168
(initialize-internal-error-table)
170
(defun condition-backtrace (condition)
171
(let* ((*debug-io* *error-output*)
172
(si::*ihs-base* (1+ si::*ihs-top*))
173
(si::*ihs-top* (1- (si::ihs-top)))
174
(si::*current-ihs* si::*ihs-top*)
175
(si::*frs-base* (or (si::sch-frs-base si::*frs-top* si::*ihs-base*)
177
(si::*frs-top* (si::frs-top))
178
(si::*break-env* nil))
179
(format *error-output* "~%~A~%" condition)
180
(si::simple-backtrace)))
182
(defvar *error-set-break-p* nil)
184
(defun clcs-error-set (form)
186
(restart-case (handler-bind ((error #'(lambda (condition)
187
(unless (or si::*break-enable*
189
(condition-backtrace condition)
190
(return-from clcs-error-set condition))
191
(setq cond condition)
193
(values-list (cons nil (multiple-value-list (eval form)))))
195
:report (lambda (stream)
196
(format stream "~S" `(si::error-set ',form)))
199
(eval-when (compile load eval)
201
(defun reset-function (symbol) ; invoke compiler::compiler-clear-compiler-properties
202
(setf (symbol-function symbol) (symbol-function symbol)))
204
(reset-function 'si::error-set)
205
(reset-function 'load)
206
(reset-function 'open)
209
(setq compiler::*compiler-break-enable* t)
211
(defun compiler::cmp-toplevel-eval (form)
212
(let* (;;(si::*ihs-base* si::*ihs-top*) ; show the whole stack
213
(si::*ihs-top* (1- (si::ihs-top)))
214
(*break-enable* compiler::*compiler-break-enable*)
215
(si::*break-hidden-packages*
216
(cons (find-package 'compiler)
217
si::*break-hidden-packages*)))
218
(si:error-set form)))
added
removed
clcs/clcs_kcl_cond.lisp
