closer-mop.lisp 11.1 KB
Newer Older
Pascal Costanza's avatar
Pascal Costanza committed
1
2
(in-package :closer-mop)

3
;; Some utility functions.
4
5
6
7
8
9

(defun required-args (lambda-list &optional (collector #'identity))
  (loop for arg in lambda-list
        until (member arg lambda-list-keywords)
        collect (funcall collector arg)))

10
11
12
13
14
15
16
(defun ensure-finalized (class &optional (errorp t))
  (if (typep class 'class)
    (unless (class-finalized-p class)
      (finalize-inheritance class))
    (when errorp (error "~S is not a class." class)))
  class)

17
18
19
20
21
22
23
;; The following is commented out. SBCL now supports compatible standard-class and
;; funcallable-standard-class metaclasses, but this requires that we don't mess with
;; the class hierarchy anymore. So we will try the trick we have already used
;; for generic functions: We just add methods for the existing metaclasses.
;; This is not AMOP-compliant, but if it works it works.

#|
Pascal Costanza's avatar
Pascal Costanza committed
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
;; We need a new standard-class for various things.

(cl:defclass standard-class (cl:standard-class)
  ())

;; validate-superclass for metaclass classes is a little bit
;; more tricky than for class metaobject classes because
;; we don't want to make all standard-classes compatible to
;; each other.

;; Our validate-superclass may get passed a class-prototype
;; as its second argument, so don't expect its readers to
;; yield useful information. (In ANSI parlance, "the
;; consequences are undefined...")

(cl:defmethod validate-superclass
           ((class standard-class)
            (superclass cl:standard-class))
  (or (when (eq (class-of class) (find-class 'standard-class))
        (member (class-of superclass)
                (list (find-class 'cl:standard-class)
45
46
                      (find-class 'standard-class)
                      #+sbcl (find-class 'funcallable-standard-class))))
Pascal Costanza's avatar
Pascal Costanza committed
47
48
49
50
      (call-next-method)
      (when (eq (class-of superclass) (find-class 'cl:standard-class))
        (validate-superclass class (class-prototype (find-class 'standard-class))))))

51
52
53
54
55
56
57
#+sbcl
(cl:defmethod validate-superclass
           ((class funcallable-standard-class)
            (superclass standard-class))
  (and (eq (class-of class) (find-class 'funcallable-standard-class))
       (eq (class-of superclass) (find-class 'standard-class))))

Pascal Costanza's avatar
Pascal Costanza committed
58
59
60
61
62
63
64
65
66
67
68
69
;; The following macro ensures that the new standard-class is used
;; by default. It would have been useful to fix other deficiencies
;; in a complete redefinition of defclass, but there is no portable
;; way to ensure the necessary compile-time effects as specified
;; by ANSI Common Lisp. Therefore, we just expand to the original
;; cl:defclass.
    
(defmacro defclass (name (&rest supers) &body options)
  (if (member :metaclass options :key #'car)
      `(cl:defclass ,name ,supers ,@options)
    `(cl:defclass ,name ,supers ,@options
       (:metaclass standard-class))))
70
|#
Pascal Costanza's avatar
Pascal Costanza committed
71

72
;; In CMUCL, reader-method-class and writer-method-class are
73
;; not used during class initialization. The following definitions
Pascal Costanza's avatar
Pascal Costanza committed
74
75
;; correct this.

76
#-sbcl
Pascal Costanza's avatar
Pascal Costanza committed
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
(defun modify-accessors (class)
  (loop with reader-specializers = (list class)
        with writer-specializers = (list (find-class 't) class)
        for slotd in (class-direct-slots class) do
        (loop for reader in (slot-definition-readers slotd)
              for reader-function = (fdefinition reader)
              for reader-method = (find-method reader-function () reader-specializers)
              for initargs = (list :qualifiers ()
                                   :lambda-list '(object)
                                   :specializers reader-specializers
                                   :function (method-function reader-method)
                                   :slot-definition slotd)
              for method-class = (apply #'reader-method-class class slotd initargs)
              unless (eq method-class (class-of reader-method))
              do (add-method reader-function (apply #'make-instance method-class initargs)))
        (loop for writer in (slot-definition-writers slotd)
              for writer-function = (fdefinition writer)
              for writer-method = (find-method writer-function () writer-specializers)
              for initargs = (list :qualifiers ()
                                   :lambda-list '(new-value object)
                                   :specializers writer-specializers
                                   :function (method-function writer-method)
                                   :slot-definition slotd)
              for method-class = (apply #'writer-method-class class slotd initargs)
              unless (eq method-class (class-of writer-method))
              do (add-method writer-function (apply #'make-instance method-class initargs)))))

104
;; The following methods additionally create a gensym for the class name
Pascal Costanza's avatar
Pascal Costanza committed
105
106
107
;; unless a name is explicitly provided. AMOP requires classes to be
;; potentially anonymous.

108
#-sbcl
Pascal Costanza's avatar
Pascal Costanza committed
109
(cl:defmethod initialize-instance :around
110
111
  ((class standard-class) &rest initargs
   &key (name (gensym)))
Pascal Costanza's avatar
Pascal Costanza committed
112
113
114
115
  (declare (dynamic-extent initargs))
  (prog1 (apply #'call-next-method class :name name initargs)
    (modify-accessors class)))

116
#-sbcl
117
118
119
120
121
122
123
(cl:defmethod initialize-instance :around
  ((class funcallable-standard-class) &rest initargs
   &key (name (gensym)))
  (declare (dynamic-extent initargs))
  (prog1 (apply #'call-next-method class :name name initargs)
    (modify-accessors class)))

124
#-sbcl
125
126
127
(cl:defmethod reinitialize-instance :after
  ((class standard-class) &key)
  (modify-accessors class))
Pascal Costanza's avatar
Pascal Costanza committed
128

129
#-sbcl
130
131
132
133
(cl:defmethod reinitialize-instance :after
  ((class funcallable-standard-class) &key)
  (modify-accessors class))

Pascal Costanza's avatar
Pascal Costanza committed
134
135
136
137
138
139
;;; The following three methods ensure that the dependent protocol
;;; for generic function works.

;; The following method additionally ensures that
;; compute-discriminating-function is triggered.

140
; Note that for CMUCL, these methods violate the AMOP specification
Pascal Costanza's avatar
Pascal Costanza committed
141
; by specializing on the original standard-generic-function metaclass. However,
142
; this is necassary because in CMUCL, only one subclass of
Pascal Costanza's avatar
Pascal Costanza committed
143
144
145
; standard-generic-function can be created, and taking away that option from user
; code doesn't make a lot of sense in our context.

146
#-sbcl
Pascal Costanza's avatar
Pascal Costanza committed
147
148
149
150
(cl:defmethod reinitialize-instance :after
  ((gf standard-generic-function) &rest initargs)
  (declare (dynamic-extent initargs))
  (set-funcallable-instance-function
151
   gf (compute-discriminating-function gf))
152
  #-cmu
Pascal Costanza's avatar
Pascal Costanza committed
153
154
155
  (map-dependents
   gf (lambda (dep) (apply #'update-dependent gf dep initargs))))

156
#-(or cmu sbcl)
Pascal Costanza's avatar
Pascal Costanza committed
157
158
159
160
161
(cl:defmethod add-method :after
  ((gf standard-generic-function) method)
  (map-dependents
   gf (lambda (dep) (update-dependent gf dep 'add-method method))))

162
#-(or cmu sbcl)
Pascal Costanza's avatar
Pascal Costanza committed
163
164
165
166
167
(cl:defmethod remove-method :after
  ((gf standard-generic-function) method)
  (map-dependents
   gf (lambda (dep) (update-dependent gf dep 'remove-method method))))

168
#+sbcl
Pascal Costanza's avatar
Pascal Costanza committed
169
170
171
172
(defun ensure-method (gf lambda-expression 
                         &key (method-class (generic-function-method-class gf))
                         (qualifiers ())
                         (lambda-list (cadr lambda-expression))
173
                         (specializers (required-args lambda-list (constantly (find-class 't)))))
Pascal Costanza's avatar
Pascal Costanza committed
174
175
176
177
178
  (multiple-value-bind
      (method-lambda method-args)
      (make-method-lambda
       gf (class-prototype method-class)
       lambda-expression ())
179
180
181
182
183
    (let ((method (apply #'make-instance
                         method-class
                         :qualifiers qualifiers
                         :lambda-list lambda-list
                         :specializers specializers
184
                         :function (compile nil method-lambda)
185
                         method-args)))
Pascal Costanza's avatar
Pascal Costanza committed
186
187
      (add-method gf method)
      method)))
188

189
#|
190
191
192
193
194
195
(defgeneric transform-specializer (specializer)
  (:method (specializer) specializer)
  (:method ((specializer class))
   (class-name specializer))
  (:method ((specializer eql-specializer))
   `(eql ,(eql-specializer-object specializer))))
196
|#
197

198
#-sbcl
199
200
201
(defun ensure-method (gf lambda-expression 
                         &key (qualifiers ())
                         (lambda-list (cadr lambda-expression))
202
                         (specializers (required-args lambda-list (constantly 't))))
203
204
205
206
  (funcall (compile nil `(lambda ()
                           (defmethod ,(generic-function-name gf) ,@qualifiers
                             ,(loop for specializer in specializers
                                    for (arg . rest) on lambda-list
207
                                    collect `(,arg ,specializer) into args
208
209
                                    finally (return (nconc args rest)))
                             ,@(cddr lambda-expression))))))
Pascal Costanza's avatar
Pascal Costanza committed
210

211
212
213
214
215
216
217
218
219
220
221
222
223
;; The following ensures that effective slot definitions have a documentation in CMUCL.

#+cmu
(defmethod compute-effective-slot-definition :around
  ((class standard-class) name direct-slot-definitions)
  (let ((effective-slot (call-next-method)))
    (loop for direct-slot in direct-slot-definitions
          for documentation = (documentation direct-slot 't)
          when documentation do
          (setf (documentation effective-slot 't) documentation)
          (loop-finish))
    effective-slot))

Pascal Costanza's avatar
Pascal Costanza committed
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
;; The following can be used in direct-slot-definition-class to get the correct initargs
;; for a slot. Use it like this:
;;
;; (defmethod direct-slot-definition-class
;;            ((class my-standard-class) &rest initargs)
;;   (declare (dynamic-extent initargs))
;;   (destructuring-bind
;;       (&key key-of-interest &allow-other-keys)
;;       (fix-slot-initargs initargs)
;;     ...))

(defvar *standard-slot-keys*
  '(:name :documentation
    :initargs :initform :initfunction
    :readers :writers))

(defun fix-slot-initargs (initargs)
  #+sbcl initargs
  #+cmu
  (let* ((counts (loop with counts
                       for (key nil) on initargs by #'cddr
                       do (incf (getf counts key 0))
                       finally (return counts)))
         (keys-to-fix (loop for (key value) on counts by #'cddr
                            if (> value 1) collect key)))
    (if keys-to-fix
250
251
252
253
254
255
256
257
258
259
260
      (let ((multiple-standard-keys
             (intersection keys-to-fix *standard-slot-keys*)))
        (if multiple-standard-keys
          (error "Too many occurences of ~S in slot initargs ~S."
                 multiple-standard-keys initargs)
          (loop with fixed-keys
                for (key value) on initargs by #'cddr
                if (member key keys-to-fix)
                do (nconcf (getf fixed-keys key) (list value))
                else nconc (list key value) into fixed-initargs
                finally (return (nconc fixed-initargs fixed-keys)))))
Pascal Costanza's avatar
Pascal Costanza committed
261
262
      initargs)))

263
264
;; In CMUCL, TYPEP and SUBTYPEP don't work as expected
;; in conjunction with class metaobjects.
Pascal Costanza's avatar
Pascal Costanza committed
265

266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
#-sbcl
(progn
  (defgeneric typep (object type)
    (:method (object type)
     (cl:typep object type))
    (:method (object (type class))
     (cl:typep object (class-name type))))

  (defgeneric subtypep (type1 type2)
    (:method (type1 type2)
     (cl:subtypep type1 type2))
    (:method ((type1 class) type2)
     (cl:subtypep (class-name type1) type2))
    (:method (type1 (type2 class))
     (cl:subtypep type1 (class-name type2)))
    (:method ((type1 class) (type2 class))
     (cl:subtypep (class-name type1)
                  (class-name type2)))))
Pascal Costanza's avatar
Pascal Costanza committed
284
285
286

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