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

Diff of /gcl/clcs/gcl_clcs_conditions.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" :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 (and (consp slot-spec) (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    )

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