← Back to branch summary

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

« back to all changes in this revision

Viewing changes to clcs/clcs_conditions.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/clcs_conditions.lisp
 
1
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
 
2
 
 
3
(in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL"))
 
4
 
 
5
#+kcl
 
6
(eval-when (compile load eval)
 
7
(when (fboundp 'remove-clcs-symbols)
 
8
  (remove-clcs-symbols))
 
9
)
 
10
 
 
11
;DEFINE-CONDITION
 
12
;MAKE-CONDITION
 
13
;condition printing
 
14
;(define-condition CONDITION ...)
 
15
;CONDITIONP
 
16
;CONDITION-CLASS-P
 
17
;SIMPLE-CONDITION-P
 
18
;SIMPLE-CONDITION-CLASS-P
 
19
 
 
20
#-(or clos pcl)
 
21
(progn
 
22
(DEFUN CONDITION-PRINT (CONDITION STREAM DEPTH)
 
23
  DEPTH ;ignored
 
24
  (COND (*PRINT-ESCAPE*
 
25
         (FORMAT STREAM "#<~S.~D>" (TYPE-OF CONDITION) (UNIQUE-ID CONDITION)))
 
26
        (T
 
27
         (CONDITION-REPORT CONDITION STREAM))))
 
28
 
 
29
(DEFSTRUCT (CONDITION :CONC-NAME
 
30
                      (:CONSTRUCTOR |Constructor for CONDITION|)
 
31
                      (:PREDICATE NIL)
 
32
                      (:PRINT-FUNCTION CONDITION-PRINT))
 
33
  (-DUMMY-SLOT- NIL))
 
34
 
 
35
(EVAL-WHEN (EVAL COMPILE LOAD)
 
36
 
 
37
(DEFMACRO PARENT-TYPE     (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'PARENT-TYPE))
 
38
(DEFMACRO SLOTS           (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'SLOTS))
 
39
(DEFMACRO CONC-NAME       (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'CONC-NAME))
 
40
(DEFMACRO REPORT-FUNCTION (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'REPORT-FUNCTION))
 
41
(DEFMACRO MAKE-FUNCTION   (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'MAKE-FUNCTION))
 
42
 
 
43
);NEHW-LAVE
 
44
 
 
45
(DEFUN CONDITION-REPORT (CONDITION STREAM)
 
46
  (DO ((TYPE (TYPE-OF CONDITION) (PARENT-TYPE TYPE)))
 
47
      ((NOT TYPE) (FORMAT STREAM "The condition ~A occurred." (TYPE-OF CONDITION)))
 
48
    (LET ((REPORTER (REPORT-FUNCTION TYPE)))
 
49
      (WHEN REPORTER
 
50
        (FUNCALL REPORTER CONDITION STREAM)
 
51
        (RETURN NIL)))))
 
52
 
 
53
(SETF (MAKE-FUNCTION   'CONDITION) '|Constructor for CONDITION|)
 
54
 
 
55
(DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS)
 
56
  (LET ((FN (MAKE-FUNCTION TYPE)))
 
57
    (COND ((NOT FN) (ERROR 'SIMPLE-TYPE-ERROR
 
58
                           :DATUM TYPE
 
59
                           :EXPECTED-TYPE '(SATISFIES MAKE-FUNCTION)
 
60
                           :FORMAT-STRING "Not a condition type: ~S"
 
61
                           :FORMAT-ARGUMENTS (LIST TYPE)))
 
62
          (T (APPLY FN SLOT-INITIALIZATIONS)))))
 
63
 
 
64
(EVAL-WHEN (EVAL COMPILE LOAD) ;Some utilities that are used at macro expansion time
 
65
 
 
66
(DEFUN PARSE-NEW-AND-USED-SLOTS (SLOTS PARENT-TYPE)
 
67
  (LET ((NEW '()) (USED '()))
 
68
    (DOLIST (SLOT SLOTS)
 
69
      (IF (SLOT-USED-P (CAR SLOT) PARENT-TYPE)
 
70
          (PUSH SLOT USED)
 
71
          (PUSH SLOT NEW)))
 
72
    (VALUES NEW USED)))
 
73
 
 
74
(DEFUN SLOT-USED-P (SLOT-NAME TYPE)
 
75
  (COND ((EQ TYPE 'CONDITION) NIL)
 
76
        ((NOT TYPE) (ERROR "The type ~S does not inherit from CONDITION." TYPE))
 
77
        ((ASSOC SLOT-NAME (SLOTS TYPE)))
 
78
        (T
 
79
         (SLOT-USED-P SLOT-NAME (PARENT-TYPE TYPE)))))
 
80
 
 
81
);NEHW-LAVE
 
82
 
 
83
(DEFMACRO DEFINE-CONDITION (NAME (PARENT-TYPE) SLOT-SPECS &REST OPTIONS)
 
84
  (LET ((CONSTRUCTOR (LET ((*PACKAGE* *THIS-PACKAGE*)) ;Bind for the INTERN -and- the FORMAT
 
85
                       (INTERN (FORMAT NIL "Constructor for ~S" NAME)))))
 
86
    (LET ((SLOTS (MAPCAR #'(LAMBDA (SLOT-SPEC)
 
87
                             (IF (ATOM SLOT-SPEC) (LIST SLOT-SPEC) SLOT-SPEC))
 
88
                         SLOT-SPECS)))
 
89
      (MULTIPLE-VALUE-BIND (NEW-SLOTS USED-SLOTS)
 
90
          (PARSE-NEW-AND-USED-SLOTS SLOTS PARENT-TYPE)
 
91
        (LET ((CONC-NAME-P     NIL)
 
92
              (CONC-NAME       NIL)
 
93
              (REPORT-FUNCTION NIL)
 
94
              (DOCUMENTATION   NIL))
 
95
          (DO ((O OPTIONS (CDR O)))
 
96
              ((NULL O))
 
97
            (LET ((OPTION (CAR O)))
 
98
              (CASE (CAR OPTION) ;Should be ECASE
 
99
                (:CONC-NAME (SETQ CONC-NAME-P T)
 
100
                            (SETQ CONC-NAME (CADR OPTION)))
 
101
                (:REPORT (SETQ REPORT-FUNCTION (IF (STRINGP (CADR OPTION))
 
102
                                                   `(LAMBDA (CONDITION STREAM)
 
103
                                                      (DECLARE (IGNORE CONDITION))
 
104
                                                      (WRITE-STRING ,(CADR OPTION) STREAM))
 
105
                                                   (CADR OPTION))))
 
106
                (:DOCUMENTATION (SETQ DOCUMENTATION (CADR OPTION)))
 
107
                (OTHERWISE (CERROR "Ignore this DEFINE-CONDITION option."
 
108
                                   "Invalid DEFINE-CONDITION option: ~S" OPTION)))))
 
109
          (IF (NOT CONC-NAME-P) (SETQ CONC-NAME (INTERN (FORMAT NIL "~A-" NAME) *PACKAGE*)))
 
110
          ;; The following three forms are compile-time side-effects. For now, they affect
 
111
          ;; the global environment, but with modified abstractions for PARENT-TYPE, SLOTS, 
 
112
          ;; and CONC-NAME, the compiler could easily make them local.
 
113
          (SETF (PARENT-TYPE NAME) PARENT-TYPE)
 
114
          (SETF (SLOTS NAME)       SLOTS)
 
115
          (SETF (CONC-NAME NAME)   CONC-NAME)
 
116
          ;; Finally, the expansion ...
 
117
          `(PROGN (DEFSTRUCT (,NAME
 
118
                              (:CONSTRUCTOR ,CONSTRUCTOR)
 
119
                              (:PREDICATE NIL)
 
120
                              (:COPIER NIL)
 
121
                              (:PRINT-FUNCTION CONDITION-PRINT)
 
122
                              (:INCLUDE ,PARENT-TYPE ,@USED-SLOTS)
 
123
                              (:CONC-NAME ,CONC-NAME))
 
124
                    ,@NEW-SLOTS)
 
125
                  (SETF (DOCUMENTATION ',NAME 'TYPE) ',DOCUMENTATION)
 
126
                  (SETF (PARENT-TYPE ',NAME) ',PARENT-TYPE)
 
127
                  (SETF (SLOTS ',NAME) ',SLOTS)
 
128
                  (SETF (CONC-NAME ',NAME) ',CONC-NAME)
 
129
                  (SETF (REPORT-FUNCTION ',NAME) ,(IF REPORT-FUNCTION `#',REPORT-FUNCTION))
 
130
                  (SETF (MAKE-FUNCTION ',NAME) ',CONSTRUCTOR)
 
131
                  ',NAME))))))
 
132
 
 
133
(defun conditionp (object)
 
134
  (typep object 'condition))
 
135
 
 
136
(defun condition-class-p (object)
 
137
  (and (symbolp object)
 
138
       (MAKE-FUNCTION object)))
 
139
 
 
140
)
 
141
 
 
142
 
 
143
 
 
144
#+(or clos pcl)
 
145
(progn
 
146
 
 
147
(eval-when (compile load eval)
 
148
(defvar *condition-class-list* nil) ; list of (class-name initarg1 type1...)
 
149
)
 
150
 
 
151
(DEFMACRO DEFINE-CONDITION (NAME PARENT-LIST SLOT-SPECS &REST OPTIONS)
 
152
  (unless (or parent-list (eq name 'condition))
 
153
          (setq parent-list (list 'condition)))
 
154
  (let* ((REPORT-FUNCTION nil)
 
155
         (DEFAULT-INITARGS nil)
 
156
         (DOCUMENTATION nil))
 
157
    (DO ((O OPTIONS (CDR O)))
 
158
        ((NULL O))
 
159
      (LET ((OPTION (CAR O)))
 
160
        (CASE (CAR OPTION)
 
161
          (:REPORT (SETQ REPORT-FUNCTION (IF (STRINGP (CADR OPTION))
 
162
                                             `(LAMBDA (CONDITION STREAM)
 
163
                                                (DECLARE (IGNORE CONDITION))
 
164
                                                (WRITE-STRING ,(CADR OPTION) STREAM))
 
165
                                             (CADR OPTION))))
 
166
          (:DEFAULT-INITARGS (SETQ DEFAULT-INITARGS OPTION)) 
 
167
          (:DOCUMENTATION (SETQ DOCUMENTATION (CADR OPTION)))
 
168
          (OTHERWISE (CERROR "Ignore this DEFINE-CONDITION option."
 
169
                             "Invalid DEFINE-CONDITION option: ~S" OPTION)))))
 
170
    `(progn
 
171
       (eval-when (compile)
 
172
         #+pcl (setq pcl::*defclass-times* '(compile load eval)))
 
173
       ,(if default-initargs
 
174
       `(defclass ,name ,parent-list ,slot-specs ,default-initargs)
 
175
       `(defclass ,name ,parent-list ,slot-specs))
 
176
       (eval-when (compile load eval)
 
177
         (pushnew '(,name ,parent-list
 
178
                    ,@(mapcan #'(lambda (slot-spec)
 
179
                                  (let* ((ia (getf (cdr slot-spec) ':initarg)))
 
180
                                    (when ia
 
181
                                      (list
 
182
                                       (cons ia
 
183
                                             (or (getf (cdr slot-spec) ':type)
 
184
                                                 t))))))
 
185
                       SLOT-SPECS))
 
186
                  *condition-class-list*)
 
187
         #+kcl (setf (get ',name #+akcl 'si::s-data #-akcl 'si::is-a-structure) nil)
 
188
;        (setf (get ',name 'documentation) ',documentation)
 
189
         )
 
190
      ,@(when REPORT-FUNCTION
 
191
           `((DEFMETHOD PRINT-OBJECT ((X ,NAME) STREAM)
 
192
               (IF *PRINT-ESCAPE*
 
193
                   (CALL-NEXT-METHOD)
 
194
                   (,REPORT-FUNCTION X STREAM)))))
 
195
      ',NAME)))
 
196
 
 
197
(eval-when (compile load eval)
 
198
(define-condition condition ()
 
199
  ())
 
200
 
 
201
#+pcl
 
202
(when (fboundp 'pcl::proclaim-incompatible-superclasses)
 
203
  (mapc
 
204
   #'pcl::proclaim-incompatible-superclasses
 
205
   '((condition pcl::metaobject))))
 
206
)
 
207
 
 
208
(defun conditionp (object)
 
209
  (typep object 'condition))
 
210
 
 
211
(DEFMETHOD PRINT-OBJECT ((X condition) STREAM)
 
212
  (IF *PRINT-ESCAPE* 
 
213
      (FORMAT STREAM "#<~S.~D>" (class-name (class-of x)) (UNIQUE-ID x))
 
214
      (FORMAT STREAM "The condition ~A occurred." (TYPE-OF x))))
 
215
 
 
216
(defvar *condition-class* (find-class 'condition))
 
217
 
 
218
(defun condition-class-p (TYPE)
 
219
  (when (symbolp TYPE)
 
220
    (setq TYPE (find-class TYPE)))
 
221
  (and (typep TYPE 'standard-class)
 
222
       (member *condition-class* 
 
223
               (#+pcl pcl::class-precedence-list
 
224
                #-pcl clos::class-precedence-list
 
225
                  type))))
 
226
 
 
227
(DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS)
 
228
  (unless (condition-class-p TYPE)
 
229
    (ERROR 'SIMPLE-TYPE-ERROR
 
230
           :DATUM TYPE
 
231
           :EXPECTED-TYPE '(SATISFIES condition-class-p)
 
232
           :FORMAT-STRING "Not a condition type: ~S"
 
233
           :FORMAT-ARGUMENTS (LIST TYPE)))
 
234
  (apply #'make-instance TYPE SLOT-INITIALIZATIONS))
 
235
 
 
236
)