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

Diff of /gcl/clcs/gcl_clcs_condition_definitions.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    (eval-when (compile load eval)
6    (pushnew #+(or clos pcl) :clos-conditions #-(or clos pcl) :defstruct-conditions
7             *features*)
8    )
9    
10    (eval-when (compile load eval)
11    (when (and (member :clos-conditions *features*)
12               (member :defstruct-conditions *features*))
13      (dolist (sym '(simple-condition-format-string simple-condition-format-arguments
14                     type-error-datum type-error-expected-type
15                     case-failure-name case-failure-possibilities
16                     stream-error-stream file-error-pathname package-error-package
17                     cell-error-name arithmetic-error-operation
18                     internal-error-function-name))
19        (when (fboundp sym) (fmakunbound sym)))
20      (setq *features* (remove :defstruct-conditions *features*)))
21    )
22    
23    (DEFINE-CONDITION WARNING (CONDITION)
24      ())
25    
26    (DEFINE-CONDITION SERIOUS-CONDITION (CONDITION)
27      ())
28    
29    (DEFINE-CONDITION ERROR (SERIOUS-CONDITION)
30      ())
31    
32    (DEFUN SIMPLE-CONDITION-PRINTER (CONDITION STREAM)
33      (APPLY #'FORMAT STREAM (SIMPLE-CONDITION-FORMAT-STRING    CONDITION)
34                             (SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)))
35    
36    (DEFINE-CONDITION SIMPLE-CONDITION (CONDITION)
37      #-(or clos pcl)
38      (FORMAT-STRING (FORMAT-ARGUMENTS '()))
39      #+(or clos pcl)
40      ((FORMAT-STRING :type string
41                      :initarg :FORMAT-STRING
42                      :reader SIMPLE-CONDITION-FORMAT-STRING)
43       (FORMAT-ARGUMENTS :initarg :FORMAT-ARGUMENTS
44                         :reader SIMPLE-CONDITION-FORMAT-ARGUMENTS
45                         :initform '()))
46      #-(or clos pcl)(:CONC-NAME %%SIMPLE-CONDITION-)
47      (:REPORT SIMPLE-CONDITION-PRINTER))
48    
49    (DEFINE-CONDITION SIMPLE-WARNING (#+(or clos pcl) SIMPLE-CONDITION WARNING)
50      #-(or clos pcl)
51      (FORMAT-STRING (FORMAT-ARGUMENTS '()))
52      #+(or clos pcl)
53      ()
54      #-(or clos pcl)(:CONC-NAME %%SIMPLE-WARNING-)
55      #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER))
56    
57    (DEFINE-CONDITION SIMPLE-ERROR (#+(or clos pcl) SIMPLE-CONDITION ERROR)
58      #-(or clos pcl)
59      (FORMAT-STRING (FORMAT-ARGUMENTS '()))
60      #+(or clos pcl)
61      ()
62      #-(or clos pcl)(:CONC-NAME %%SIMPLE-ERROR-)
63      #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER))
64    
65    (DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) ())
66    
67    (DEFINE-CONDITION STACK-OVERFLOW    (STORAGE-CONDITION) ())
68    
69    (DEFINE-CONDITION STORAGE-EXHAUSTED (STORAGE-CONDITION) ())
70    
71    (DEFINE-CONDITION TYPE-ERROR (ERROR)
72      #-(or clos pcl)
73      (DATUM EXPECTED-TYPE)
74      #+(or clos pcl)
75      ((DATUM :initarg :DATUM
76              :reader TYPE-ERROR-DATUM)
77       (EXPECTED-TYPE :initarg :EXPECTED-TYPE
78                      :reader TYPE-ERROR-EXPECTED-TYPE))
79      (:report
80        (lambda (condition stream)
81          (format stream "~S is not of type ~S."
82                  (TYPE-ERROR-DATUM CONDITION)
83                  (TYPE-ERROR-EXPECTED-TYPE CONDITION)))))
84    
85    (DEFINE-CONDITION SIMPLE-TYPE-ERROR (#+(or clos pcl) SIMPLE-CONDITION TYPE-ERROR)
86      #-(or clos pcl)
87      (FORMAT-STRING (FORMAT-ARGUMENTS '()))
88      #+(or clos pcl)
89      ()
90      #-(or clos pcl)(:CONC-NAME %%SIMPLE-TYPE-ERROR-)
91      #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER))
92    
93    (DEFINE-CONDITION CASE-FAILURE (TYPE-ERROR)
94     #-(or clos pcl)
95     (NAME POSSIBILITIES)
96     #+(or clos pcl)
97     ((NAME :initarg :NAME
98            :reader CASE-FAILURE-NAME)
99      (POSSIBILITIES :initarg :POSSIBILITIES
100                     :reader CASE-FAILURE-POSSIBILITIES))
101      (:REPORT
102        (LAMBDA (CONDITION STREAM)
103          (FORMAT STREAM "~S fell through ~S expression.~%Wanted one of ~:S."
104                  (TYPE-ERROR-DATUM CONDITION)
105                  (CASE-FAILURE-NAME CONDITION)
106                  (CASE-FAILURE-POSSIBILITIES CONDITION)))))
107    
108    (DEFINE-CONDITION PROGRAM-ERROR (ERROR)
109      ())
110    
111    (DEFINE-CONDITION CONTROL-ERROR (ERROR)
112      ())
113    
114    (DEFINE-CONDITION PARSE-ERROR (ERROR)
115      ())
116    
117    (DEFINE-CONDITION STREAM-ERROR (ERROR)
118      #-(or clos pcl)
119      (STREAM)
120      #+(or clos pcl)
121      ((STREAM :initarg :STREAM
122               :reader STREAM-ERROR-STREAM)))
123    
124    (DEFINE-CONDITION END-OF-FILE (STREAM-ERROR)
125      ()
126      (:REPORT (LAMBDA (CONDITION STREAM)
127                 (FORMAT STREAM "Unexpected end of file on ~S."
128                         (STREAM-ERROR-STREAM CONDITION)))))
129    
130    (DEFINE-CONDITION FILE-ERROR (ERROR)
131      #-(or clos pcl)
132      (PATHNAME)
133      #+(or clos pcl)
134      ((PATHNAME :initarg :PATHNAME
135                 :reader FILE-ERROR-PATHNAME)))
136    
137    (DEFINE-CONDITION PACKAGE-ERROR (ERROR)
138      #-(or clos pcl)
139      (PACKAGE)
140      #+(or clos pcl)
141      ((PACKAGE :initarg :PACKAGE
142                :reader PACKAGE-ERROR-PACKAGE)
143       (MESSAGE :initarg :MESSAGE
144                :reader PACKAGE-ERROR-MESSAGE))
145      (:report
146        (lambda (condition stream)
147          (format stream "A package error occurred on ~S: ~S."
148                  (PACKAGE-ERROR-PACKAGE CONDITION)
149                  (PACKAGE-ERROR-MESSAGE CONDITION)))))
150                  
151    
152    (DEFINE-CONDITION CELL-ERROR (ERROR)
153      #-(or clos pcl)
154      (NAME)
155      #+(or clos pcl)
156      ((NAME :initarg :NAME
157             :reader CELL-ERROR-NAME)))
158    
159    (DEFINE-CONDITION UNBOUND-VARIABLE (CELL-ERROR)
160      ()
161      (:REPORT (LAMBDA (CONDITION STREAM)
162                 (FORMAT STREAM "The variable ~S is unbound."
163                         (CELL-ERROR-NAME CONDITION)))))
164      
165    (DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR)
166      ()
167      (:REPORT (LAMBDA (CONDITION STREAM)
168                 (FORMAT STREAM "The function ~S is undefined."
169                         (CELL-ERROR-NAME CONDITION)))))
170    
171    (DEFINE-CONDITION ARITHMETIC-ERROR (ERROR)
172      #-(or clos pcl)
173      (OPERATION OPERANDS)
174      #+(or clos pcl)
175      ((OPERATION :initarg :OPERATION
176                  :reader ARITHMETIC-ERROR-OPERATION)))
177    
178    (DEFINE-CONDITION DIVISION-BY-ZERO         (ARITHMETIC-ERROR)
179      ())
180    
181    (DEFINE-CONDITION FLOATING-POINT-OVERFLOW  (ARITHMETIC-ERROR)
182      ())
183    
184    (DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR)
185      ())
186    
187    (DEFINE-CONDITION ABORT-FAILURE (CONTROL-ERROR) ()
188      (:REPORT "Abort failed."))
189    
190    #+kcl
191    (progn
192    (define-condition internal-warning ( warning)
193      #-(or clos pcl)
194      ((function-name nil))
195      #+(or clos pcl)
196      ((function-name :initarg :function-name
197                      :reader internal-error-function-name
198                      :initform 'nil))
199      (:report (lambda (condition stream)
200                 (when (internal-error-function-name condition)
201                   (format stream "Warning in ~S [or a callee]: "
202                           (internal-error-function-name condition)))
203                 #+(or clos pcl)(call-next-method))))
204    
205    (define-condition internal-error ( error)
206      #-(or clos pcl)
207      ((function-name nil))
208      #+(or clos pcl)
209      ((function-name :initarg :function-name
210                      :reader internal-error-function-name
211                      :initform 'nil))
212      (:report (lambda (condition stream)
213                 (when (internal-error-function-name condition)
214                   (format stream "Error in ~S [or a callee]: "
215                           (internal-error-function-name condition)))
216                 #+(or clos pcl)(call-next-method))))
217    
218    (defun internal-simple-error-printer (condition stream)
219      (when (internal-error-function-name condition)
220        (format stream "Error in ~S [or a callee]: "
221                (internal-error-function-name condition)))
222      (apply #'format stream (simple-condition-format-string    condition)
223                             (simple-condition-format-arguments condition)))
224    
225    (defun internal-simple-warning-printer (condition stream)
226      (when (internal-error-function-name condition)
227        (format stream "Warning in ~S [or a callee]: "
228                (internal-error-function-name condition)))
229      (apply #'format stream (simple-condition-format-string    condition)
230                             (simple-condition-format-arguments condition)))
231    
232    (define-condition internal-simple-error
233        (internal-error #+(or clos pcl) simple-condition)
234      #-(or clos pcl)
235      ((function-name nil) format-string (format-arguments '()))
236      #+(or clos pcl)
237      ()
238      #-(or clos pcl)(:conc-name %%internal-simple-error-)
239      (:report internal-simple-error-printer))
240    
241    (define-condition internal-simple-warning
242        (internal-warning #+(or clos pcl) simple-condition)
243      #-(or clos pcl)
244      ((function-name nil) format-string (format-arguments '()))
245      #+(or clos pcl)
246      ()
247      #-(or clos pcl)(:conc-name %%internal-simple-warning-)
248      (:report internal-simple-warning-printer))
249    
250    (define-condition internal-type-error
251        (#+(or clos pcl) internal-error type-error)
252      #-(or clos pcl)
253      ((function-name nil))
254      #+(or clos pcl)
255      ()
256      #-(or clos pcl)(:conc-name %%internal-type-error-)
257      #-(or clos pcl)(:report (lambda (condition stream)
258                                (when (internal-error-function-name condition)
259                                  (format stream "Error in ~S [or a callee]: "
260                                          (internal-error-function-name condition)))
261                                (format stream "~S is not of type ~S."
262                                        (type-error-datum condition)
263                                        (type-error-expected-type condition)))))
264    
265    (define-condition internal-package-error
266       (#+(or clos pcl) internal-error package-error)
267     #-(or clos pcl)
268     ((function-name nil))
269     #+(or clos pcl)
270     ()
271     #-(or clos pcl)(:conc-name %%internal-package-error-)
272     #-(or clos pcl)(:report (lambda (condition stream)
273                                (when (internal-error-function-name condition)
274                                  (format stream "Error in ~S [or a callee]: "
275                                          (internal-error-function-name condition)))
276                                (format stream "A package error occurred on ~S: ~S."
277                                        (package-error-package condition)
278                                        (package-error-message condition)))))
279    
280    (define-condition internal-simple-program-error
281        (#+(or clos pcl) internal-simple-error program-error)
282      #-(or clos pcl)
283      ((function-name nil) format-string (format-arguments '()))
284      #+(or clos pcl)
285      ()
286      #-(or clos pcl)(:conc-name %%internal-simple-program-error-)
287      #-(or clos pcl)(:report internal-simple-error-printer))
288    
289    (define-condition internal-simple-parse-error
290        (#+(or clos pcl) internal-simple-error parse-error)
291      #-(or clos pcl)
292      ((function-name nil) format-string (format-arguments '()))
293      #+(or clos pcl)
294      ()
295      #-(or clos pcl)(:conc-name %%internal-simple-parse-error-)
296      #-(or clos pcl)(:report internal-simple-error-printer))
297    
298    (define-condition internal-simple-control-error
299        (#+(or clos pcl) internal-simple-error control-error)
300      #-(or clos pcl)
301      ((function-name nil) format-string (format-arguments '()))
302      #+(or clos pcl)
303      ()
304      #-(or clos pcl)(:conc-name %%internal-simple-control-error-)
305      #-(or clos pcl)(:report internal-simple-error-printer))
306    
307    (define-condition internal-unbound-variable
308        (#+(or clos pcl) internal-error unbound-variable)
309      #-(or clos pcl)
310      ((function-name nil))
311      #+(or clos pcl)
312      ()
313      #-(or clos pcl)(:conc-name %%internal-unbound-variable-)
314      #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM)
315                                (when (internal-error-function-name condition)
316                                  (format stream "Error in ~S [or a callee]: "
317                                          (internal-error-function-name condition)))
318                                (FORMAT STREAM "The variable ~S is unbound."
319                                        (CELL-ERROR-NAME CONDITION)))))
320    
321    (define-condition internal-undefined-function
322        (#+(or clos pcl) internal-error undefined-function)
323      #-(or clos pcl)
324      ((function-name nil))
325      #+(or clos pcl)
326      ()
327      #-(or clos pcl)(:conc-name %%internal-undefined-function-)
328      #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM)
329                                (when (internal-error-function-name condition)
330                                  (format stream "Error in ~S [or a callee]: "
331                                          (internal-error-function-name condition)))
332                                (FORMAT STREAM "The function ~S is undefined."
333                                        (CELL-ERROR-NAME CONDITION)))))
334    
335    (define-condition internal-end-of-file
336        (#+(or clos pcl) internal-error end-of-file)
337      #-(or clos pcl)
338      ((function-name nil))
339      #+(or clos pcl)
340      ()
341      #-(or clos pcl)(:conc-name %%internal-end-of-file-)
342      #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM)
343                                (when (internal-error-function-name condition)
344                                  (format stream "Error in ~S [or a callee]: "
345                                          (internal-error-function-name condition)))
346                                (FORMAT STREAM "Unexpected end of file on ~S."
347                                        (STREAM-ERROR-STREAM CONDITION)))))
348    
349    (define-condition internal-simple-file-error
350        (#+(or clos pcl) internal-simple-error file-error)
351      #-(or clos pcl)
352      ((function-name nil) format-string (format-arguments '()))
353      #+(or clos pcl)
354      ()
355      #-(or clos pcl)(:conc-name %%internal-simple-file-error-)
356      #-(or clos pcl)(:report internal-simple-error-printer))
357    
358    (define-condition internal-simple-stream-error
359        (#+(or clos pcl) internal-simple-error stream-error)
360      #-(or clos pcl)
361      ((function-name nil) format-string (format-arguments '()))
362      #+(or clos pcl)
363      ()
364      #-(or clos pcl)(:conc-name %%internal-simple-stream-error-)
365      #-(or clos pcl)(:report internal-simple-error-printer))
366    
367    #-(or pcl clos)
368    (defun internal-error-function-name (condition)
369      (etypecase condition
370        (internal-error                
371         (%%internal-error-function-name condition))
372        (internal-simple-error        
373         (%%internal-simple-error-function-name condition))
374        (internal-type-error
375         (%%internal-type-error-function-name condition))
376        (internal-simple-program-error
377         (%%internal-simple-program-error-function-name condition))
378        (internal-simple-parse-error
379         (%%internal-simple-parse-error-function-name condition))
380        (internal-simple-control-error
381         (%%internal-simple-control-error-function-name condition))
382        (internal-unbound-variable  
383         (%%internal-unbound-variable-function-name condition))
384        (internal-undefined-function
385         (%%internal-undefined-function-function-name condition))
386        (internal-end-of-file        
387         (%%internal-end-of-file-function-name condition))
388        (internal-simple-file-error  
389         (%%internal-simple-file-error-function-name condition))
390        (internal-simple-stream-error
391         (%%internal-simple-stream-error-function-name condition))))
392    )
393    
394    #-(or clos pcl)
395    (progn
396    
397    (DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION)
398      (ETYPECASE CONDITION
399        (SIMPLE-CONDITION  (%%SIMPLE-CONDITION-FORMAT-STRING  CONDITION))
400        (SIMPLE-WARNING    (%%SIMPLE-WARNING-FORMAT-STRING    CONDITION))
401        (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION))
402        (SIMPLE-ERROR      (%%SIMPLE-ERROR-FORMAT-STRING      CONDITION))
403        #+kcl(internal-simple-error
404              (%%internal-simple-error-format-string condition))
405        #+kcl(internal-simple-program-error
406              (%%internal-simple-program-error-format-string condition))
407        #+kcl(internal-simple-parse-error
408              (%%internal-simple-parse-error-format-string condition))
409        #+kcl(internal-simple-control-error
410              (%%internal-simple-control-error-format-string condition))
411        #+kcl(internal-simple-file-error
412              (%%internal-simple-file-error-format-string condition))
413        #+kcl(internal-simple-stream-error
414              (%%internal-simple-stream-error-format-string condition))))
415    
416    (DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION)
417      (ETYPECASE CONDITION
418        (SIMPLE-CONDITION  (%%SIMPLE-CONDITION-FORMAT-ARGUMENTS  CONDITION))
419        (SIMPLE-WARNING    (%%SIMPLE-WARNING-FORMAT-ARGUMENTS    CONDITION))
420        (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION))
421        (SIMPLE-ERROR      (%%SIMPLE-ERROR-FORMAT-ARGUMENTS      CONDITION))
422        #+kcl(internal-simple-error
423              (%%internal-simple-error-format-arguments condition))
424        #+kcl(internal-simple-program-error
425              (%%internal-simple-program-error-format-arguments condition))
426        #+kcl(internal-simple-parse-error
427              (%%internal-simple-parse-error-format-arguments condition))
428        #+kcl(internal-simple-control-error
429              (%%internal-simple-control-error-format-arguments condition))
430        #+kcl(internal-simple-file-error
431              (%%internal-simple-file-error-format-arguments condition))
432        #+kcl(internal-simple-stream-error
433              (%%internal-simple-stream-error-format-arguments condition))))
434    
435    (defun simple-condition-class-p (type)
436      (member type '(SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-TYPE-ERROR SIMPLE-ERROR
437                     #+kcl internal-simple-error
438                     #+kcl internal-simple-program-error
439                     #+kcl internal-simple-parse-error
440                     #+kcl internal-simple-control-error
441                     #+kcl internal-simple-file-error
442                     #+kcl internal-simple-stream-error)))
443    )
444    
445    #+(or clos pcl)
446    (progn
447    (defvar *simple-condition-class* (find-class 'simple-condition))
448    
449    (defun simple-condition-class-p (TYPE)
450      (when (symbolp TYPE)
451        (setq TYPE (find-class TYPE)))
452      (and (typep TYPE 'standard-class)
453           (member *simple-condition-class*
454                   (#+pcl pcl::class-precedence-list
455                    #-pcl clos::class-precedence-list
456                      type))))
457    )
458    

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