/[gcl]/gcl/clcs/gcl_clcs_kcl_cond.lisp
ViewVC logotype

Diff of /gcl/clcs/gcl_clcs_kcl_cond.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:54 2005 UTC revision 1.2 by camm, Sat May 7 02:52:28 2005 UTC
# Line 0  Line 1 
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)))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26