← Back to branch summary

~ubuntu-branches/ubuntu/maverick/cl-closer-mop/maverick

« back to all changes in this revision

Viewing changes to closer-ecl.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2009-12-31 15:09:51 UTC
  • mfrom: (1.1.6 upstream) (2.1.4 sid)
  • Revision ID: james.westby@ubuntu.com-20091231150951-gr3ve65254n7zmqd
Tags: 2:0.6-1
* Move Secton to lisp 
* New upstream which is a major redesign.

Show diffs side-by-side

added added

removed removed

Lines of Context:
closer-ecl.lisp
 
1
(in-package :closer-mop)
 
2
 
 
3
(defmacro removef (place item)
 
4
  `(setf ,place (remove ,item ,place)))
 
5
 
 
6
(defun extract-lambda-list (lambda-list)
 
7
  (loop for (arg . rest) on lambda-list
 
8
        for keyp = (member arg lambda-list-keywords)
 
9
        until keyp
 
10
        if (consp arg)
 
11
        collect (car arg) into args
 
12
        else collect arg into args
 
13
        finally (return (if keyp
 
14
                          (nconc args (cons arg rest))
 
15
                          args))))
 
16
 
 
17
(defun extract-specializer-names (lambda-list)
 
18
  (loop for arg in lambda-list
 
19
        until (member arg lambda-list-keywords)
 
20
        if (consp arg)
 
21
        collect (cadr arg)
 
22
        else collect 't))
 
23
 
 
24
(cl:defgeneric generic-function-method-class (object)
 
25
  (:method ((gf generic-function))
 
26
   (clos:generic-function-method-class gf)))
 
27
 
 
28
(cl:defmethod compute-discriminating-function ((gf generic-function)) t)
 
29
 
 
30
(cl:defmethod make-method-lambda ((gf generic-function) (method method)
 
31
                                  lambda-expression environment)
 
32
  (declare (ignore environment))
 
33
  (destructuring-bind
 
34
      (lambda (&rest args) &body body)
 
35
      lambda-expression
 
36
    (declare (ignore args))
 
37
    (assert (eq lambda 'lambda))
 
38
    (values
 
39
     lambda-expression
 
40
     (let ((documentation (parse-method-body body lambda-expression)))
 
41
       (when documentation
 
42
         (list 'documentation documentation))))))
 
43
 
 
44
(cl:defmethod compute-effective-method-function ((gf standard-generic-function) effective-method options)
 
45
  (declare (optimize (speed 3) (space 0) (compilation-speed 0)))
 
46
  (when options
 
47
    (cerror "Ignore these options."
 
48
            "This version of compute-effective-method-function does not support method combination options: ~S"
 
49
            options))
 
50
  (if (only-standard-methods gf)
 
51
    effective-method
 
52
    (lambda (&rest args)
 
53
      (declare (dynamic-extent args))
 
54
      (funcall effective-method args nil))))
 
55
 
 
56
(cl:defgeneric find-method-combination (generic-function type options)
 
57
  (:method ((gf generic-function) type options)
 
58
   (cons type options)))
 
59
 
 
60
(defclass standard-class (cl:standard-class)
 
61
  ((direct-methods :initform '() :reader specializer-direct-methods)))
 
62
 
 
63
(defun optimize-slot-access-p (class)
 
64
  (flet ((applicablep (specializer)
 
65
           (if (consp specializer)
 
66
             (eql class (eql-specializer-object specializer))
 
67
             (subclassp (class-of class) specializer))))
 
68
    (when (and (loop for method in (generic-function-methods #'slot-value-using-class)
 
69
                     never (applicablep (first (method-specializers method))))
 
70
               (loop for method in (generic-function-methods #'(setf slot-value-using-class))
 
71
                     never (applicablep (second (method-specializers method)))))
 
72
      '(t))))
 
73
 
 
74
(cl:defmethod initialize-instance :around ((class standard-class) &rest initargs)
 
75
  (declare (dynamic-extent initargs))
 
76
  (apply #'call-next-method class
 
77
         :optimize-slot-access
 
78
         (optimize-slot-access-p class)
 
79
         initargs))
 
80
 
 
81
(cl:defmethod reinitialize-instance :around ((class standard-class) &rest initargs)
 
82
  (declare (dynamic-extent initargs))
 
83
  (apply #'call-next-method class
 
84
         :optimize-slot-access
 
85
         (optimize-slot-access-p class)
 
86
         initargs))
 
87
 
 
88
(cl:defmethod initialize-instance :around ((class funcallable-standard-class) &rest initargs)
 
89
  (declare (dynamic-extent initargs))
 
90
  (apply #'call-next-method class
 
91
         :optimize-slot-access
 
92
         (optimize-slot-access-p class)
 
93
         initargs))
 
94
 
 
95
(cl:defmethod reinitialize-instance :around ((class funcallable-standard-class) &rest initargs)
 
96
  (declare (dynamic-extent initargs))
 
97
  (apply #'call-next-method class
 
98
         :optimize-slot-access
 
99
         (optimize-slot-access-p class)
 
100
         initargs))
 
101
 
 
102
(cl:defmethod initialize-instance :before ((class standard-class) &key direct-superclasses)
 
103
  (assert (loop for superclass in direct-superclasses
 
104
                always (validate-superclass class superclass))))
 
105
 
 
106
(cl:defmethod reinitialize-instance :before ((class standard-class) &key (direct-superclasses '() direct-superclasses-p))
 
107
  (when direct-superclasses-p
 
108
    (assert (loop for superclass in direct-superclasses
 
109
                  always (validate-superclass class superclass)))
 
110
    (loop for superclass in (class-direct-superclasses class)
 
111
          unless (member superclass direct-superclasses)
 
112
          do (remove-direct-subclass superclass class))))
 
113
 
 
114
(cl:defmethod initialize-instance :before ((class funcallable-standard-class) &key direct-superclasses)
 
115
  (assert (loop for superclass in direct-superclasses
 
116
                always (validate-superclass class superclass))))
 
117
 
 
118
(cl:defmethod initialize-instance :before ((class funcallable-standard-class) &key direct-superclasses)
 
119
  (assert (loop for superclass in direct-superclasses
 
120
                always (validate-superclass class superclass))))
 
121
 
 
122
(cl:defmethod (setf class-name) (new-value (class standard-class))
 
123
  (reinitialize-instance class :name new-value)
 
124
  new-value)
 
125
 
 
126
(cl:defmethod (setf generic-function-name) (new-value (gf standard-generic-function))
 
127
  (reinitialize-instance gf :name new-value)
 
128
  new-value)
 
129
 
 
130
(defvar *direct-methods-for-built-in-classes*
 
131
  (make-hash-table :test #'eq))
 
132
 
 
133
(cl:defgeneric add-direct-method (specializer method)
 
134
  (:method ((specializer class) (method method)))
 
135
  (:method ((specializer built-in-class) (method method))
 
136
   (pushnew method (gethash specializer *direct-methods-for-built-in-classes*)))
 
137
  (:method ((specializer standard-class) (method method))
 
138
   (pushnew method (slot-value specializer 'direct-methods)))
 
139
  (:method ((specializer funcallable-standard-class) (method method))
 
140
   (pushnew method (slot-value specializer 'direct-methods))))
 
141
 
 
142
(cl:defgeneric remove-direct-method (specializer method)
 
143
  (:method ((specializer class) (method method)))
 
144
  (:method ((specializer built-in-class) (method method))
 
145
   (removef (gethash specializer *direct-methods-for-built-in-classes*) method))
 
146
  (:method ((specializer standard-class) (method method))
 
147
   (removef (slot-value specializer 'direct-methods) method))
 
148
  (:method ((specializer funcallable-standard-class) (method method))
 
149
   (removef (slot-value specializer 'direct-methods) method)))
 
150
 
 
151
(defvar *dependents* (make-hash-table :test #'eq))
 
152
 
 
153
(cl:defgeneric add-dependent (metaobject dependent)
 
154
  (:method ((metaobject standard-class) dependent)
 
155
    (pushnew dependent (gethash metaobject *dependents*)))
 
156
  (:method ((metaobject funcallable-standard-class) dependent)
 
157
    (pushnew dependent (gethash metaobject *dependents*)))
 
158
  (:method ((metaobject standard-generic-function) dependent)
 
159
    (pushnew dependent (gethash metaobject *dependents*))))
 
160
 
 
161
(cl:defgeneric remove-dependent (metaobject dependent)
 
162
  (:method ((metaobject standard-class) dependent)
 
163
    (setf (gethash metaobject *dependents*)
 
164
          (delete dependent (gethash metaobject *dependents*))))
 
165
  (:method ((metaobject funcallable-standard-class) dependent)
 
166
    (setf (gethash metaobject *dependents*)
 
167
          (delete dependent (gethash metaobject *dependents*))))
 
168
  (:method ((metaobject standard-generic-function) dependent)
 
169
    (setf (gethash metaobject *dependents*)
 
170
          (delete dependent (gethash metaobject *dependents*)))))
 
171
 
 
172
(cl:defgeneric map-dependents (metaobject function)
 
173
  (:method ((metaobject standard-class) function)
 
174
    (mapc function (gethash metaobject *dependents*)))
 
175
  (:method ((metaobject funcallable-standard-class) function)
 
176
    (mapc function (gethash metaobject *dependents*)))
 
177
  (:method ((metaobject standard-generic-function) function)
 
178
    (mapc function (gethash metaobject *dependents*))))
 
179
 
 
180
(cl:defgeneric update-dependent (metaobject dependent &rest initargs))
 
181
 
 
182
(cl:defmethod reinitialize-instance :after ((metaobject standard-class) &rest initargs)
 
183
  (declare (dynamic-extent initargs))
 
184
  (map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs))))
 
185
 
 
186
(cl:defmethod reinitialize-instance :after ((metaobject funcallable-standard-class) &rest initargs)
 
187
  (declare (dynamic-extent initargs))
 
188
  (map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs))))
 
189
 
 
190
(cl:defmethod initialize-instance :after ((gf standard-generic-function) &rest initargs)
 
191
  (declare (ignore initargs))
 
192
  (set-funcallable-instance-function gf (compute-discriminating-function gf)))
 
193
 
 
194
(cl:defmethod ensure-generic-function-using-class :around ((gf null) name &rest initargs)
 
195
  (declare (ignore name initargs))
 
196
  (let ((new-gf (call-next-method)))
 
197
    (if (typep new-gf 'standard-generic-function)
 
198
      (set-funcallable-instance-function new-gf (compute-discriminating-function new-gf))
 
199
      new-gf)))
 
200
 
 
201
(cl:defmethod reinitialize-instance :after ((gf standard-generic-function) &rest initargs)
 
202
  (declare (dynamic-extent initargs))
 
203
  (set-funcallable-instance-function gf (compute-discriminating-function gf))
 
204
  (map-dependents gf (lambda (dep) (apply #'update-dependent gf dep initargs))))
 
205
 
 
206
(cl:defgeneric remove-method (gf method)
 
207
  (:method ((gf generic-function) (method method))
 
208
   (cl:remove-method gf method)))
 
209
 
 
210
(cl:defmethod remove-method :after ((gf standard-generic-function) (method method))
 
211
  (set-funcallable-instance-function gf (compute-discriminating-function gf))
 
212
  (loop for specializer in (method-specializers method)
 
213
        if (consp specializer) do (remove-direct-method (intern-eql-specializer*
 
214
                                                         (eql-specializer-object specializer))
 
215
                                                        method)
 
216
        else do (remove-direct-method specializer method))
 
217
  (map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method))))
 
218
 
 
219
(cl:defgeneric find-method (gf qualifiers specializers &optional errorp)
 
220
  (:method ((gf generic-function) qualifiers specializers &optional (errorp t))
 
221
   (cl:find-method gf qualifiers specializers errorp)))
 
222
 
 
223
(cl:defmethod add-method :before ((gf standard-generic-function) (method method))
 
224
  (let ((other-gf (method-generic-function method)))
 
225
    (unless (or (null other-gf) (eq other-gf gf))
 
226
      (error "The method ~S belongs to the generic function ~S and cannot be added to ~S."
 
227
             method other-gf gf)))
 
228
  (let ((old-method (find-method gf
 
229
                                 (method-qualifiers method)
 
230
                                 (method-specializers method)
 
231
                                 nil)))
 
232
    (when old-method
 
233
      (remove-method gf old-method))))
 
234
 
 
235
(cl:defmethod add-method :after ((gf standard-generic-function) (method method))
 
236
  (set-funcallable-instance-function gf (compute-discriminating-function gf))
 
237
  (loop for specializer in (method-specializers method)
 
238
        if (consp specializer) do (add-direct-method (intern-eql-specializer*
 
239
                                                      (eql-specializer-object specializer))
 
240
                                                     method)
 
241
        else do (add-direct-method specializer method))
 
242
  (map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method))))
 
243
 
 
244
(defun eql-specializer-p (thing)
 
245
  (and (consp thing)
 
246
       (eq (car thing) 'eql)
 
247
       (null (cddr thing))))
 
248
 
 
249
(deftype eql-specializer ()
 
250
  '(or eql-specializer* (satisfies eql-specializer-p)))
 
251
 
 
252
(cl:defgeneric eql-specializer-object (eql-specializer)
 
253
  (:method ((cons cons))
 
254
   (if (eql-specializer-p cons)
 
255
     (cadr cons)
 
256
     (error "~S is not an eql-specializer." cons))))
 
257
 
 
258
(defun intern-eql-specializer (object)
 
259
  `(eql ,object))
 
260
 
 
261
(cl:defmethod specializer-direct-methods ((cons cons))
 
262
  (specializer-direct-methods (eql-specializer-object cons)))
 
263
 
 
264
(defclass eql-specializer* ()
 
265
  ((obj :reader eql-specializer-object
 
266
        :initarg eso
 
267
        :initform (error "Use intern-eql-specializer to create eql-specializers."))
 
268
   (direct-methods :reader specializer-direct-methods
 
269
                   :accessor es-direct-methods
 
270
                   :initform ())))
 
271
 
 
272
(defvar *eql-specializers* (make-hash-table))
 
273
 
 
274
#+threads
 
275
(defvar *eql-specializers-lock* (mp:make-lock :name 'eql-specializers))
 
276
 
 
277
(defmacro with-eql-specializers-lock (&body body)
 
278
  #+threads `(mp:with-lock (*eql-specializers-lock*) ,@body)
 
279
  #-threads `(progn ,@body))
 
280
 
 
281
(defun intern-eql-specializer* (object)
 
282
  (or #+threads (gethash object *eql-specializers*)
 
283
      (with-eql-specializers-lock
 
284
       (or (gethash object *eql-specializers*)
 
285
           (setf (gethash object *eql-specializers*)
 
286
                 (make-instance 'eql-specializer* 'eso object))))))
 
287
 
 
288
(cl:defmethod add-direct-method ((specializer eql-specializer*) (method method))
 
289
  (pushnew method (es-direct-methods specializer)))
 
290
 
 
291
(cl:defmethod remove-direct-method ((specializer eql-specializer*) (method method))
 
292
  (removef (es-direct-methods specializer) method))
 
293
 
 
294
(cl:defgeneric specializer-direct-generic-functions (specializer)
 
295
  (:method ((class class))
 
296
   (remove-duplicates
 
297
    (mapcar #'method-generic-function
 
298
            (specializer-direct-methods class))))
 
299
  (:method ((eql-specializer eql-specializer*))
 
300
   (remove-duplicates
 
301
    (mapcar #'method-generic-function
 
302
            (specializer-direct-methods eql-specializer))))
 
303
  (:method ((cons cons))
 
304
   (specializer-direct-generic-functions
 
305
    (intern-eql-specializer*
 
306
     (eql-specializer-object cons)))))
 
307
 
 
308
(cl:defgeneric validate-superclass (class superclass)
 
309
  (:method (class superclass)
 
310
   (or (eq superclass (find-class 't))
 
311
       (typep superclass (find-class 'forward-referenced-class))
 
312
       (eq (class-of class) (class-of superclass))
 
313
       (let ((compatible-classes (list (find-class 'cl:standard-class)
 
314
                                       (find-class 'standard-class)
 
315
                                       (find-class 'clos:funcallable-standard-class)
 
316
                                       (find-class 'funcallable-standard-class))))
 
317
         (and (member (class-of class) compatible-classes)
 
318
              (member (class-of superclass) compatible-classes))))))
 
319
 
 
320
(define-validate-superclass-method standard-class cl:standard-class)
 
321
(define-validate-superclass-method funcallable-standard-class clos:funcallable-standard-class)
 
322
 
 
323
(eval-when (:compile-toplevel :load-toplevel :execute)
 
324
  (pushnew :closer-mop *features*))