closer-ecl.lisp 14.2 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
(in-package :closer-mop)

(defmacro removef (place item)
  `(setf ,place (remove ,item ,place)))

(defun extract-lambda-list (lambda-list)
  (loop for (arg . rest) on lambda-list
        for keyp = (member arg lambda-list-keywords)
        until keyp
        if (consp arg)
        collect (car arg) into args
        else collect arg into args
        finally (return (if keyp
                          (nconc args (cons arg rest))
                          args))))

(defun extract-specializer-names (lambda-list)
  (loop for arg in lambda-list
        until (member arg lambda-list-keywords)
        if (consp arg)
        collect (cadr arg)
        else collect 't))

(cl:defgeneric generic-function-method-class (object)
  (:method ((gf generic-function))
   (clos:generic-function-method-class gf)))

28
29
30
(cl:defmethod compute-discriminating-function ((gf generic-function)) 
  (declare (ignore gf))
  t)
31
32
33

(cl:defmethod make-method-lambda ((gf generic-function) (method method)
                                  lambda-expression environment)
34
  (declare (ignore environment method gf))
35
36
37
38
  (destructuring-bind
      (lambda (&rest args) &body body)
      lambda-expression
    (assert (eq lambda 'lambda))
39
40
41
42
    (when (and (member '&key args :test #'eq)
               (not (member '&allow-other-keys args :test #'eq)))
      (let ((tail (member '&aux args :test #'eq)))
        (setq lambda-expression
43
              `(lambda (,.(ldiff args tail) &allow-other-keys ,@tail) ,@body))))
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
    (values
     lambda-expression
     (let ((documentation (parse-method-body body lambda-expression)))
       (when documentation
         (list 'documentation documentation))))))

(cl:defmethod compute-effective-method-function ((gf standard-generic-function) effective-method options)
  (declare (optimize (speed 3) (space 0) (compilation-speed 0)))
  (when options
    (cerror "Ignore these options."
            "This version of compute-effective-method-function does not support method combination options: ~S"
            options))
  (if (only-standard-methods gf)
    effective-method
    (lambda (&rest args)
      (funcall effective-method args nil))))

(cl:defgeneric find-method-combination (generic-function type options)
  (:method ((gf generic-function) type options)
63
   (declare (ignore gf))
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
   (cons type options)))

(defclass standard-class (cl:standard-class)
  ((direct-methods :initform '() :reader specializer-direct-methods)))

(defun optimize-slot-access-p (class)
  (flet ((applicablep (specializer)
           (if (consp specializer)
             (eql class (eql-specializer-object specializer))
             (subclassp (class-of class) specializer))))
    (when (and (loop for method in (generic-function-methods #'slot-value-using-class)
                     never (applicablep (first (method-specializers method))))
               (loop for method in (generic-function-methods #'(setf slot-value-using-class))
                     never (applicablep (second (method-specializers method)))))
      '(t))))

(cl:defmethod initialize-instance :around ((class standard-class) &rest initargs)
  (apply #'call-next-method class
         :optimize-slot-access
         (optimize-slot-access-p class)
         initargs))

(cl:defmethod reinitialize-instance :around ((class standard-class) &rest initargs)
  (apply #'call-next-method class
         :optimize-slot-access
         (optimize-slot-access-p class)
         initargs))

(cl:defmethod initialize-instance :around ((class funcallable-standard-class) &rest initargs)
  (apply #'call-next-method class
         :optimize-slot-access
         (optimize-slot-access-p class)
         initargs))

(cl:defmethod reinitialize-instance :around ((class funcallable-standard-class) &rest initargs)
  (apply #'call-next-method class
         :optimize-slot-access
         (optimize-slot-access-p class)
         initargs))

(cl:defmethod initialize-instance :before ((class standard-class) &key direct-superclasses)
  (assert (loop for superclass in direct-superclasses
                always (validate-superclass class superclass))))

(cl:defmethod reinitialize-instance :before ((class standard-class) &key (direct-superclasses '() direct-superclasses-p))
  (when direct-superclasses-p
    (assert (loop for superclass in direct-superclasses
                  always (validate-superclass class superclass)))
    (loop for superclass in (class-direct-superclasses class)
          unless (member superclass direct-superclasses)
          do (remove-direct-subclass superclass class))))

(cl:defmethod initialize-instance :before ((class funcallable-standard-class) &key direct-superclasses)
  (assert (loop for superclass in direct-superclasses
                always (validate-superclass class superclass))))

(cl:defmethod initialize-instance :before ((class funcallable-standard-class) &key direct-superclasses)
  (assert (loop for superclass in direct-superclasses
                always (validate-superclass class superclass))))

(cl:defmethod (setf class-name) (new-value (class standard-class))
  (reinitialize-instance class :name new-value)
  new-value)

(cl:defmethod (setf generic-function-name) (new-value (gf standard-generic-function))
  (reinitialize-instance gf :name new-value)
  new-value)

132
133
134
135
136
(declaim (inline set-generic-function-name))
(defun set-generic-function-name (gf new-value)
  (funcall (load-time-value (fdefinition '(setf generic-function-name))) new-value gf))
(defsetf generic-function-name set-generic-function-name)

137
138
139
140
(defvar *direct-methods-for-built-in-classes*
  (make-hash-table :test #'eq))

(cl:defgeneric add-direct-method (specializer method)
141
142
  (:method ((specializer class) (method method))
   (declare (ignore specializer method)))
143
144
145
146
147
148
149
150
  (:method ((specializer built-in-class) (method method))
   (pushnew method (gethash specializer *direct-methods-for-built-in-classes*)))
  (:method ((specializer standard-class) (method method))
   (pushnew method (slot-value specializer 'direct-methods)))
  (:method ((specializer funcallable-standard-class) (method method))
   (pushnew method (slot-value specializer 'direct-methods))))

(cl:defgeneric remove-direct-method (specializer method)
151
152
  (:method ((specializer class) (method method))
   (declare (ignore specializer method)))
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
  (:method ((specializer built-in-class) (method method))
   (removef (gethash specializer *direct-methods-for-built-in-classes*) method))
  (:method ((specializer standard-class) (method method))
   (removef (slot-value specializer 'direct-methods) method))
  (:method ((specializer funcallable-standard-class) (method method))
   (removef (slot-value specializer 'direct-methods) method)))

(defvar *dependents* (make-hash-table :test #'eq))

(cl:defgeneric add-dependent (metaobject dependent)
  (:method ((metaobject standard-class) dependent)
    (pushnew dependent (gethash metaobject *dependents*)))
  (:method ((metaobject funcallable-standard-class) dependent)
    (pushnew dependent (gethash metaobject *dependents*)))
  (:method ((metaobject standard-generic-function) dependent)
    (pushnew dependent (gethash metaobject *dependents*))))

(cl:defgeneric remove-dependent (metaobject dependent)
  (:method ((metaobject standard-class) dependent)
    (setf (gethash metaobject *dependents*)
	  (delete dependent (gethash metaobject *dependents*))))
  (:method ((metaobject funcallable-standard-class) dependent)
    (setf (gethash metaobject *dependents*)
	  (delete dependent (gethash metaobject *dependents*))))
  (:method ((metaobject standard-generic-function) dependent)
    (setf (gethash metaobject *dependents*)
	  (delete dependent (gethash metaobject *dependents*)))))

(cl:defgeneric map-dependents (metaobject function)
  (:method ((metaobject standard-class) function)
    (mapc function (gethash metaobject *dependents*)))
  (:method ((metaobject funcallable-standard-class) function)
    (mapc function (gethash metaobject *dependents*)))
  (:method ((metaobject standard-generic-function) function)
    (mapc function (gethash metaobject *dependents*))))

(cl:defgeneric update-dependent (metaobject dependent &rest initargs))

(cl:defmethod reinitialize-instance :after ((metaobject standard-class) &rest initargs)
  (map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs))))

(cl:defmethod reinitialize-instance :after ((metaobject funcallable-standard-class) &rest initargs)
  (map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs))))

(cl:defmethod initialize-instance :after ((gf standard-generic-function) &rest initargs)
  (declare (ignore initargs))
  (set-funcallable-instance-function gf (compute-discriminating-function gf)))

(cl:defmethod ensure-generic-function-using-class :around ((gf null) name &rest initargs)
202
  (declare (ignore name initargs gf))
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
  (let ((new-gf (call-next-method)))
    (if (typep new-gf 'standard-generic-function)
      (set-funcallable-instance-function new-gf (compute-discriminating-function new-gf))
      new-gf)))

(cl:defmethod reinitialize-instance :after ((gf standard-generic-function) &rest initargs)
  (set-funcallable-instance-function gf (compute-discriminating-function gf))
  (map-dependents gf (lambda (dep) (apply #'update-dependent gf dep initargs))))

(cl:defgeneric remove-method (gf method)
  (:method ((gf generic-function) (method method))
   (cl:remove-method gf method)))

(cl:defmethod remove-method :after ((gf standard-generic-function) (method method))
  (set-funcallable-instance-function gf (compute-discriminating-function gf))
  (loop for specializer in (method-specializers method)
        if (consp specializer) do (remove-direct-method (intern-eql-specializer*
                                                         (eql-specializer-object specializer))
                                                        method)
        else do (remove-direct-method specializer method))
  (map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method))))

(cl:defgeneric find-method (gf qualifiers specializers &optional errorp)
  (:method ((gf generic-function) qualifiers specializers &optional (errorp t))
   (cl:find-method gf qualifiers specializers errorp)))

(cl:defmethod add-method :before ((gf standard-generic-function) (method method))
  (let ((other-gf (method-generic-function method)))
    (unless (or (null other-gf) (eq other-gf gf))
      (error "The method ~S belongs to the generic function ~S and cannot be added to ~S."
             method other-gf gf)))
  (let ((old-method (find-method gf
                                 (method-qualifiers method)
                                 (method-specializers method)
                                 nil)))
    (when old-method
      (remove-method gf old-method))))

(cl:defmethod add-method :after ((gf standard-generic-function) (method method))
  (set-funcallable-instance-function gf (compute-discriminating-function gf))
  (loop for specializer in (method-specializers method)
        if (consp specializer) do (add-direct-method (intern-eql-specializer*
                                                      (eql-specializer-object specializer))
                                                     method)
        else do (add-direct-method specializer method))
  (map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method))))

(defun eql-specializer-p (thing)
  (and (consp thing)
       (eq (car thing) 'eql)
       (null (cddr thing))))

(deftype eql-specializer ()
  '(or eql-specializer* (satisfies eql-specializer-p)))

(cl:defgeneric eql-specializer-object (eql-specializer)
  (:method ((cons cons))
   (if (eql-specializer-p cons)
     (cadr cons)
     (error "~S is not an eql-specializer." cons))))

(defun intern-eql-specializer (object)
  `(eql ,object))

(cl:defmethod specializer-direct-methods ((cons cons))
  (specializer-direct-methods (eql-specializer-object cons)))

(defclass eql-specializer* ()
  ((obj :reader eql-specializer-object
        :initarg eso
        :initform (error "Use intern-eql-specializer to create eql-specializers."))
   (direct-methods :reader specializer-direct-methods
                   :accessor es-direct-methods
                   :initform ())))

(defvar *eql-specializers* (make-hash-table))

#+threads
(defvar *eql-specializers-lock* (mp:make-lock :name 'eql-specializers))

(defmacro with-eql-specializers-lock (&body body)
  #+threads `(mp:with-lock (*eql-specializers-lock*) ,@body)
  #-threads `(progn ,@body))

(defun intern-eql-specializer* (object)
  (or #+threads (gethash object *eql-specializers*)
      (with-eql-specializers-lock
       (or (gethash object *eql-specializers*)
           (setf (gethash object *eql-specializers*)
                 (make-instance 'eql-specializer* 'eso object))))))

(cl:defmethod add-direct-method ((specializer eql-specializer*) (method method))
  (pushnew method (es-direct-methods specializer)))

(cl:defmethod remove-direct-method ((specializer eql-specializer*) (method method))
  (removef (es-direct-methods specializer) method))

(cl:defgeneric specializer-direct-generic-functions (specializer)
  (:method ((class class))
   (remove-duplicates
    (mapcar #'method-generic-function
            (specializer-direct-methods class))))
  (:method ((eql-specializer eql-specializer*))
   (remove-duplicates
    (mapcar #'method-generic-function
            (specializer-direct-methods eql-specializer))))
  (:method ((cons cons))
   (specializer-direct-generic-functions
    (intern-eql-specializer*
     (eql-specializer-object cons)))))

(cl:defgeneric validate-superclass (class superclass)
  (:method (class superclass)
   (or (eq superclass (find-class 't))
       (typep superclass (find-class 'forward-referenced-class))
       (eq (class-of class) (class-of superclass))
       (let ((compatible-classes (list (find-class 'cl:standard-class)
                                       (find-class 'standard-class)
                                       (find-class 'clos:funcallable-standard-class)
                                       (find-class 'funcallable-standard-class))))
         (and (member (class-of class) compatible-classes)
              (member (class-of superclass) compatible-classes))))))

(define-validate-superclass-method standard-class cl:standard-class)
(define-validate-superclass-method funcallable-standard-class clos:funcallable-standard-class)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (pushnew :closer-mop *features*))