← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to clcs/unused/test5.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
clcs/unused/test5.lisp
 
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
;;; Start
 
24
 
 
25
(DEFINE-CONDITION WARNING (CONDITION)
 
26
  ())
 
27
 
 
28
(DEFINE-CONDITION SERIOUS-CONDITION (CONDITION)
 
29
  ())
 
30
 
 
31
(DEFINE-CONDITION lisp:ERROR (SERIOUS-CONDITION)
 
32
  ())
 
33
 
 
34
(DEFUN SIMPLE-CONDITION-PRINTER (CONDITION STREAM)
 
35
  (APPLY #'FORMAT STREAM (SIMPLE-CONDITION-FORMAT-STRING    CONDITION)
 
36
                         (SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)))
 
37
 
 
38
(DEFINE-CONDITION SIMPLE-CONDITION (CONDITION)
 
39
  #-(or clos pcl)
 
40
  (FORMAT-STRING (FORMAT-ARGUMENTS '()))
 
41
  #+(or clos pcl)
 
42
  ((FORMAT-STRING :type string
 
43
                  :initarg :FORMAT-STRING
 
44
                  :reader SIMPLE-CONDITION-FORMAT-STRING)
 
45
   (FORMAT-ARGUMENTS :initarg :FORMAT-ARGUMENTS
 
46
                     :reader SIMPLE-CONDITION-FORMAT-ARGUMENTS
 
47
                     :initform '()))
 
48
  #-(or clos pcl)(:CONC-NAME %%SIMPLE-CONDITION-)
 
49
  (:REPORT SIMPLE-CONDITION-PRINTER))
 
50
 
 
51
(DEFINE-CONDITION SIMPLE-WARNING (#+(or clos pcl) SIMPLE-CONDITION WARNING)
 
52
  #-(or clos pcl)
 
53
  (FORMAT-STRING (FORMAT-ARGUMENTS '()))
 
54
  #+(or clos pcl)
 
55
  ()
 
56
  #-(or clos pcl)(:CONC-NAME %%SIMPLE-WARNING-)
 
57
  #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER))
 
58
 
 
59
(DEFINE-CONDITION SIMPLE-ERROR (#+(or clos pcl) SIMPLE-CONDITION lisp:ERROR)
 
60
  #-(or clos pcl)
 
61
  (FORMAT-STRING (FORMAT-ARGUMENTS '()))
 
62
  #+(or clos pcl)
 
63
  ()
 
64
  #-(or clos pcl)(:CONC-NAME %%SIMPLE-ERROR-)
 
65
  #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER))
 
66
 
 
67
(DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) ())
 
68
 
 
69
(DEFINE-CONDITION STACK-OVERFLOW    (STORAGE-CONDITION) ())
 
70
 
 
71
(DEFINE-CONDITION STORAGE-EXHAUSTED (STORAGE-CONDITION) ())
 
72
 
 
73
(DEFINE-CONDITION TYPE-ERROR (lisp:ERROR)
 
74
  #-(or clos pcl)
 
75
  (DATUM EXPECTED-TYPE)
 
76
  #+(or clos pcl)
 
77
  ((DATUM :initarg :DATUM
 
78
          :reader TYPE-ERROR-DATUM)
 
79
   (EXPECTED-TYPE :initarg :EXPECTED-TYPE
 
80
                  :reader TYPE-ERROR-EXPECTED-TYPE))
 
81
  (:report
 
82
    (lambda (condition stream)
 
83
      (format stream "~S is not of type ~S."
 
84
              (TYPE-ERROR-DATUM CONDITION)
 
85
              (TYPE-ERROR-EXPECTED-TYPE CONDITION)))))
 
86
 
 
87
(DEFINE-CONDITION SIMPLE-TYPE-ERROR (#+(or clos pcl) SIMPLE-CONDITION TYPE-ERROR)
 
88
  #-(or clos pcl)
 
89
  (FORMAT-STRING (FORMAT-ARGUMENTS '()))
 
90
  #+(or clos pcl)
 
91
  ()
 
92
  #-(or clos pcl)(:CONC-NAME %%SIMPLE-TYPE-ERROR-)
 
93
  #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER))
 
94
 
 
95
(DEFINE-CONDITION CASE-FAILURE (TYPE-ERROR)
 
96
 #-(or clos pcl)
 
97
 (NAME POSSIBILITIES)
 
98
 #+(or clos pcl)
 
99
 ((NAME :initarg :NAME
 
100
        :reader CASE-FAILURE-NAME)
 
101
  (POSSIBILITIES :initarg :POSSIBILITIES
 
102
                 :reader CASE-FAILURE-POSSIBILITIES))
 
103
  (:REPORT
 
104
    (LAMBDA (CONDITION STREAM)
 
105
      (FORMAT STREAM "~S fell through ~S expression.~%Wanted one of ~:S."
 
106
              (TYPE-ERROR-DATUM CONDITION)
 
107
              (CASE-FAILURE-NAME CONDITION)
 
108
              (CASE-FAILURE-POSSIBILITIES CONDITION)))))
 
109
 
 
110
(DEFINE-CONDITION PROGRAM-ERROR (lisp:ERROR)
 
111
  ())
 
112
 
 
113
(DEFINE-CONDITION CONTROL-ERROR (lisp:ERROR)
 
114
  ())
 
115
 
 
116
(DEFINE-CONDITION STREAM-ERROR (lisp:ERROR)
 
117
  #-(or clos pcl)
 
118
  (STREAM)
 
119
  #+(or clos pcl)
 
120
  ((STREAM :initarg :STREAM
 
121
           :reader STREAM-ERROR-STREAM)))
 
122
 
 
123
(DEFINE-CONDITION END-OF-FILE (STREAM-ERROR)
 
124
  ()
 
125
  (:REPORT (LAMBDA (CONDITION STREAM)
 
126
             (FORMAT STREAM "Unexpected end of file on ~S."
 
127
                     (STREAM-ERROR-STREAM CONDITION)))))
 
128
 
 
129
(DEFINE-CONDITION FILE-ERROR (lisp:ERROR)
 
130
  #-(or clos pcl)
 
131
  (PATHNAME)
 
132
  #+(or clos pcl)
 
133
  ((PATHNAME :initarg :PATHNAME
 
134
             :reader FILE-ERROR-PATHNAME)))
 
135
 
 
136
(DEFINE-CONDITION PACKAGE-ERROR (lisp:ERROR)
 
137
  #-(or clos pcl)
 
138
  (PACKAGE)
 
139
  #+(or clos pcl)
 
140
  ((PACKAGE :initarg :PACKAGE
 
141
            :reader PACKAGE-ERROR-PACKAGE)))
 
142
 
 
143
(DEFINE-CONDITION CELL-ERROR (lisp:ERROR)
 
144
  #-(or clos pcl)
 
145
  (NAME)
 
146
  #+(or clos pcl)
 
147
  ((NAME :initarg :NAME
 
148
         :reader CELL-ERROR-NAME)))
 
149
 
 
150
(DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR)
 
151
  ()
 
152
  (:REPORT (LAMBDA (CONDITION STREAM)
 
153
             (FORMAT STREAM "The function ~S is undefined."
 
154
                     (CELL-ERROR-NAME CONDITION)))))
 
155
 
 
156
(DEFINE-CONDITION ARITHMETIC-ERROR (lisp:ERROR)
 
157
  #-(or clos pcl)
 
158
  (OPERATION OPERANDS)
 
159
  #+(or clos pcl)
 
160
  ((OPERATION :initarg :OPERATION
 
161
              :reader ARITHMETIC-ERROR-OPERATION)))
 
162
 
 
163
(DEFINE-CONDITION DIVISION-BY-ZERO         (ARITHMETIC-ERROR)
 
164
  ())
 
165
 
 
166
(DEFINE-CONDITION FLOATING-POINT-OVERFLOW  (ARITHMETIC-ERROR)
 
167
  ())
 
168
 
 
169
(DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR)
 
170
  ())
 
171
 
 
172
(DEFINE-CONDITION ABORT-FAILURE (CONTROL-ERROR) ()
 
173
  (:REPORT "Abort failed."))
 
174
 
 
175
 
 
176
#+kcl
 
177
(progn
 
178
 
 
179
;;; When this form is present, the compiled behavior disagrees with
 
180
;;; the interpreted behavior.  The interpreted behavior is correct.
 
181
(define-condition internal-error (lisp:error)
 
182
  #-(or clos pcl)
 
183
  ((function-name nil))
 
184
  #+(or clos pcl)
 
185
  ((function-name :initarg :function-name
 
186
                  :reader internal-error-function-name
 
187
                  :initform 'nil))
 
188
  (:report (lambda (condition stream)
 
189
             (when (internal-error-function-name condition)
 
190
               (format stream "Error in ~S [or a callee]: "
 
191
                       (internal-error-function-name condition)))
 
192
             #+(or clos pcl)(call-next-method))))
 
193
 
 
194
(defun internal-simple-error-printer (condition stream)
 
195
  (when (internal-error-function-name condition)
 
196
    (format stream "Error in ~S [or a callee]: "
 
197
            (internal-error-function-name condition)))
 
198
  (apply #'format stream (simple-condition-format-string    condition)
 
199
                         (simple-condition-format-arguments condition)))
 
200
 
 
201
(define-condition internal-simple-error 
 
202
    (internal-error #+(or clos pcl) simple-condition)
 
203
  #-(or clos pcl)
 
204
  ((function-name nil) format-string (format-arguments '()))
 
205
  #+(or clos pcl)
 
206
  ()
 
207
  #-(or clos pcl)(:conc-name %%internal-simple-error-)
 
208
  (:report internal-simple-error-printer))
 
209
 
 
210
(define-condition internal-type-error 
 
211
    (#+(or clos pcl) internal-error type-error)
 
212
  #-(or clos pcl)
 
213
  ((function-name nil))
 
214
  #+(or clos pcl)
 
215
  ()
 
216
  #-(or clos pcl)(:conc-name %%internal-type-error-)
 
217
  #-(or clos pcl)(:report (lambda (condition stream)
 
218
                            (when (internal-error-function-name condition)
 
219
                              (format stream "Error in ~S [or a callee]: "
 
220
                                      (internal-error-function-name condition)))
 
221
                            (format stream "~S is not of type ~S."
 
222
                                    (type-error-datum condition)
 
223
                                    (type-error-expected-type condition)))))
 
224
 
 
225
(define-condition internal-simple-program-error 
 
226
    (#+(or clos pcl) internal-simple-error program-error)
 
227
  #-(or clos pcl)
 
228
  ((function-name nil) format-string (format-arguments '()))
 
229
  #+(or clos pcl)
 
230
  ()
 
231
  #-(or clos pcl)(:conc-name %%internal-simple-program-error-)
 
232
  #-(or clos pcl)(:report internal-simple-error-printer))
 
233
 
 
234
(define-condition internal-simple-control-error 
 
235
    (#+(or clos pcl) internal-simple-error control-error)
 
236
  #-(or clos pcl)
 
237
  ((function-name nil) format-string (format-arguments '()))
 
238
  #+(or clos pcl)
 
239
  ()
 
240
  #-(or clos pcl)(:conc-name %%internal-simple-control-error-)
 
241
  #-(or clos pcl)(:report internal-simple-error-printer))
 
242
 
 
243
 
 
244
(define-condition internal-unbound-variable 
 
245
    (#+(or clos pcl) internal-error unbound-variable)
 
246
  #-(or clos pcl)
 
247
  ((function-name nil))
 
248
  #+(or clos pcl)
 
249
  ()
 
250
  #-(or clos pcl)(:conc-name %%internal-unbound-variable-)
 
251
  #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM)
 
252
                            (when (internal-error-function-name condition)
 
253
                              (format stream "Error in ~S [or a callee]: "
 
254
                                      (internal-error-function-name condition)))
 
255
                            (FORMAT STREAM "The variable ~S is unbound."
 
256
                                    (CELL-ERROR-NAME CONDITION)))))
 
257
 
 
258
#-(or pcl clos)
 
259
(defun internal-error-function-name (condition) 
 
260
  (etypecase condition
 
261
    (internal-error                
 
262
     (%%internal-error-function-name condition))
 
263
    (internal-simple-error         
 
264
     (%%internal-simple-error-function-name condition))
 
265
    (internal-type-error 
 
266
     (%%internal-type-error-function-name condition))
 
267
    (internal-simple-program-error
 
268
     (%%internal-simple-program-error-function-name condition))
 
269
    (internal-simple-control-error
 
270
     (%%internal-simple-control-error-function-name condition))
 
271
    (internal-unbound-variable  
 
272
     (%%internal-unbound-variable-function-name condition))
 
273
    (internal-undefined-function 
 
274
     (%%internal-undefined-function-function-name condition))
 
275
    (internal-end-of-file        
 
276
     (%%internal-end-of-file-function-name condition))
 
277
    (internal-simple-file-error  
 
278
     (%%internal-simple-file-error-function-name condition))
 
279
    (internal-simple-stream-error 
 
280
     (%%internal-simple-stream-error-function-name condition))))
 
281
)
 
282
 
 
283
#-(or clos pcl)
 
284
(progn
 
285
 
 
286
(DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION)
 
287
  (ETYPECASE CONDITION
 
288
    (SIMPLE-CONDITION  (%%SIMPLE-CONDITION-FORMAT-STRING  CONDITION))
 
289
    (SIMPLE-WARNING    (%%SIMPLE-WARNING-FORMAT-STRING    CONDITION))
 
290
    (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION))
 
291
    (SIMPLE-ERROR      (%%SIMPLE-ERROR-FORMAT-STRING      CONDITION))
 
292
    #+kcl(internal-simple-error
 
293
          (%%internal-simple-error-format-string condition))
 
294
    #+kcl(internal-simple-program-error
 
295
          (%%internal-simple-program-error-format-string condition))
 
296
    #+kcl(internal-simple-control-error
 
297
          (%%internal-simple-control-error-format-string condition))
 
298
    #+kcl(internal-simple-file-error
 
299
          (%%internal-simple-file-error-format-string condition))
 
300
    #+kcl(internal-simple-stream-error
 
301
          (%%internal-simple-stream-error-format-string condition))))
 
302
 
 
303
(DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION)
 
304
  (ETYPECASE CONDITION
 
305
    (SIMPLE-CONDITION  (%%SIMPLE-CONDITION-FORMAT-ARGUMENTS  CONDITION))
 
306
    (SIMPLE-WARNING    (%%SIMPLE-WARNING-FORMAT-ARGUMENTS    CONDITION))
 
307
    (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION))
 
308
    (SIMPLE-ERROR      (%%SIMPLE-ERROR-FORMAT-ARGUMENTS      CONDITION))
 
309
    #+kcl(internal-simple-error
 
310
          (%%internal-simple-error-format-arguments condition))
 
311
    #+kcl(internal-simple-program-error
 
312
          (%%internal-simple-program-error-format-arguments condition))
 
313
    #+kcl(internal-simple-control-error
 
314
          (%%internal-simple-control-error-format-arguments condition))
 
315
    #+kcl(internal-simple-file-error
 
316
          (%%internal-simple-file-error-format-arguments condition))
 
317
    #+kcl(internal-simple-stream-error
 
318
          (%%internal-simple-stream-error-format-arguments condition))))
 
319
 
 
320
(defun simple-condition-class-p (type)
 
321
  (member type '(SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-TYPE-ERROR SIMPLE-ERROR
 
322
                 #+kcl internal-simple-error
 
323
                 #+kcl internal-simple-program-error
 
324
                 #+kcl internal-simple-control-error
 
325
                 #+kcl internal-simple-file-error
 
326
                 #+kcl internal-simple-stream-error)))
 
327
)
 
328
 
 
329
#+(or clos pcl)
 
330
(progn
 
331
(defvar *simple-condition-class* (find-class 'simple-condition))
 
332
 
 
333
(defun simple-condition-class-p (TYPE)
 
334
  (when (symbolp TYPE)
 
335
    (setq TYPE (find-class TYPE)))
 
336
  (and (typep TYPE 'standard-class)
 
337
       (member *simple-condition-class* 
 
338
               (#+pcl pcl::class-precedence-list
 
339
                #-pcl clos::class-precedence-list
 
340
                  type))))
 
341
)
 
342