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

3
4
5
6
7
;; Some internal utility functions.

#+cmu
(define-modify-macro nconcf (&rest lists) nconc)

8
;; Some utility functions.
9
10
11
12
13
14

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

15
16
17
18
19
20
21
(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)

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
(defun subclassp (class superclass)
  (flet ((get-class (class) (etypecase class
                              (class class)
                              (symbol (find-class class)))))
    
      (loop with class = (get-class class)
            with superclass = (get-class superclass)
            
            for superclasses = (list class)
            then (set-difference 
                  (union (class-direct-superclasses current-class) superclasses)
                  seen)

            for current-class = (first superclasses)

            while current-class
            
            if (eq current-class superclass) return t
            else collect current-class into seen
            
            finally (return nil))))

Pascal Costanza's avatar
Pascal Costanza committed
44

45
;; In CMUCL, reader-method-class and writer-method-class are
46
;; not used during class initialization. The following definitions
Pascal Costanza's avatar
Pascal Costanza committed
47
48
;; correct this.

49
#-sbcl
Pascal Costanza's avatar
Pascal Costanza committed
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
(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)))))

77
;; The following methods additionally create a gensym for the class name
Pascal Costanza's avatar
Pascal Costanza committed
78
79
80
;; unless a name is explicitly provided. AMOP requires classes to be
;; potentially anonymous.

81
#-sbcl
Pascal Costanza's avatar
Pascal Costanza committed
82
(cl:defmethod initialize-instance :around
83
84
  ((class standard-class) &rest initargs
   &key (name (gensym)))
Pascal Costanza's avatar
Pascal Costanza committed
85
86
87
88
  (declare (dynamic-extent initargs))
  (prog1 (apply #'call-next-method class :name name initargs)
    (modify-accessors class)))

89
#-sbcl
90
91
92
93
94
95
96
(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)))

97
#-sbcl
98
99
100
(cl:defmethod reinitialize-instance :after
  ((class standard-class) &key)
  (modify-accessors class))
Pascal Costanza's avatar
Pascal Costanza committed
101

102
#-sbcl
103
104
105
106
(cl:defmethod reinitialize-instance :after
  ((class funcallable-standard-class) &key)
  (modify-accessors class))

Pascal Costanza's avatar
Pascal Costanza committed
107
108
109
110
111
112
;;; The following three methods ensure that the dependent protocol
;;; for generic function works.

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

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

119
#-sbcl
Pascal Costanza's avatar
Pascal Costanza committed
120
121
122
123
(cl:defmethod reinitialize-instance :after
  ((gf standard-generic-function) &rest initargs)
  (declare (dynamic-extent initargs))
  (set-funcallable-instance-function
124
   gf (compute-discriminating-function gf))
125
  #-cmu
Pascal Costanza's avatar
Pascal Costanza committed
126
127
128
  (map-dependents
   gf (lambda (dep) (apply #'update-dependent gf dep initargs))))

129
#-(or cmu sbcl)
Pascal Costanza's avatar
Pascal Costanza committed
130
131
132
133
134
(cl:defmethod add-method :after
  ((gf standard-generic-function) method)
  (map-dependents
   gf (lambda (dep) (update-dependent gf dep 'add-method method))))

135
#-(or cmu sbcl)
Pascal Costanza's avatar
Pascal Costanza committed
136
137
138
139
140
(cl:defmethod remove-method :after
  ((gf standard-generic-function) method)
  (map-dependents
   gf (lambda (dep) (update-dependent gf dep 'remove-method method))))

141
142
143
144
145
146
147
148
149
150
151
152
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
202
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
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
#+sbcl
(progn
  (declaim (inline m-function))

  (defun m-function (m)
    (method-function m))

  (define-compiler-macro m-function (m)
    (handler-case (method-function m)
      (error () `(the function (method-function (the method ,m))))))
  
  (defclass standard-generic-function (cl:standard-generic-function)
    ((argument-order :accessor argument-order))
    (:metaclass funcallable-standard-class))

  (defun compute-argument-order (gf nof-required-args)
    (loop with specialized-count = (make-array nof-required-args :initial-element 0)
          
          for method in (generic-function-methods gf) do
          (loop for specializer in (method-specializers method)
                for index from 0
                unless (eq specializer (find-class 't))
                do (incf (svref specialized-count index)))
          
          finally
          
          (loop for arg in (generic-function-argument-precedence-order gf)
                for pos = (position arg (generic-function-lambda-list gf))
                when (> (svref specialized-count pos) 0)
                collect pos into argument-order
                finally (setf (argument-order gf) (coerce argument-order 'simple-vector)))))
  
  (cl:defmethod make-method-lambda ((gf standard-generic-function) (method standard-method)
                                    lambda-expression environment)
    (declare (ignore environment) (optimize (speed 3) (space 0) (compilation-speed 0)))
    (when (only-standard-methods gf)
      (return-from make-method-lambda (call-next-method)))
    (let ((args (gensym)) (next-methods (gensym))
          (more-args (gensym)) (method-function (gensym)))
      (values
       `(lambda (,args ,next-methods &rest ,more-args)
          (declare (dynamic-extent ,more-args)
                   (ignorable ,args ,next-methods ,more-args))
          (flet ((call-next-method (&rest args)
                   (declare (dynamic-extent args))
                   (if ,next-methods
                     (apply (method-function (first ,next-methods))
                            (if args args ,args) (rest ,next-methods) ,more-args)
                     (apply #'no-next-method
                            (getf ,more-args :generic-function)
                            (getf ,more-args :method)
                            (if args args ,args))))
                 (next-method-p () (not (null ,next-methods))))
            (declare (inline call-next-method next-method-p)
                     (ignorable #'call-next-method #'next-method-p))
            (flet ((,method-function ,@(rest lambda-expression)))
              (declare (inline ,method-function))
              (apply #',method-function ,args))))
       '())))

  (cl:defgeneric compute-effective-method-function (gf effective-method options)
    (:method ((gf 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))
     (let ((all-t-specializers (required-args (generic-function-lambda-list gf)
                                              (constantly (find-class 't))))
           (args (gensym)))
       (labels ((transform-effective-method (form)
                  (if (atom form) form
                    (case (car form)
                      (call-method (transform-effective-method
                                    (let ((the-method (transform-effective-method (cadr form)))
                                          (method-var (gensym)))
                                      `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
                                         (let ((,method-var ,the-method))
                                           (declare (ignorable ,method-var))
                                           (funcall (m-function ,(if (typep the-method 'method)
                                                                   the-method method-var))
                                                    ,args
                                                    ,@(let ((subforms
                                                             (loop for subform in (the list (cddr form))
                                                                   collect `',subform)))
                                                        (if subforms subforms '(())))
                                                    :generic-function ,gf
                                                    :method ,(if (typep the-method 'method)
                                                               the-method method-var)))))))
                      (make-method (when (cddr form)
                                     (error "Incorrect make-method form: ~S." form))
                                   (multiple-value-bind
                                       (method-lambda method-options)
                                       (make-method-lambda
                                        gf (class-prototype (generic-function-method-class gf))
                                        `(lambda (&rest ,args)
                                           (declare (dynamic-extent ,args) (ignorable ,args))
                                           ,(transform-effective-method (cadr form))) nil)
                                     (apply #'make-instance
                                            (generic-function-method-class gf)
                                            :qualifiers '()
                                            :specializers all-t-specializers
                                            :lambda-list (generic-function-lambda-list gf)
                                            :function (compile nil method-lambda)
                                            method-options)))
                      (t (mapcar #'transform-effective-method (the list form)))))))
         (let ((emf-lambda `(lambda (&rest ,args)
                              (declare (dynamic-extent ,args) (ignorable ,args))
                              ,(transform-effective-method effective-method))))
           (multiple-value-bind (function warnings failure)
               (compile nil emf-lambda)
             (declare (ignore warnings))
             (assert (not failure))
             function))))))

  (defun get-emf (gf args nof-required-args)
    (declare (optimize (speed 3) (space 0) (compilation-speed 0)))
    (let ((applicable-methods (compute-applicable-methods gf (subseq args 0 nof-required-args))))
      (if applicable-methods
        (multiple-value-bind
            (effective-method options)
            (compute-effective-method
             gf (generic-function-method-combination gf)
             applicable-methods)
          (compute-effective-method-function gf effective-method options))
        (lambda (&rest args)
          (declare (dynamic-extent args))
          (apply #'no-applicable-method gf args)))))

  (defun get-emf-using-classes (gf args classes nof-required-args)
    (declare (type generic-function gf) (type list args classes)
             (optimize (speed 3) (space 0) (compilation-speed 0)))
    (multiple-value-bind
        (applicable-methods validp)
        (compute-applicable-methods-using-classes gf classes)
      (unless validp
        (setq applicable-methods
              (compute-applicable-methods gf (subseq args 0 nof-required-args))))
      (values
       (if applicable-methods
         (multiple-value-bind
             (effective-method options)
             (compute-effective-method
              gf (generic-function-method-combination gf)
              applicable-methods)
           (compute-effective-method-function gf effective-method options))
         (lambda (&rest args)
           (declare (dynamic-extent args))
           (apply #'no-applicable-method gf args)))
       validp)))

  (defvar *standard-gfs*
    (list #'compute-applicable-methods #'compute-applicable-methods-using-classes
          #'compute-effective-method #'compute-effective-method-function))

  (defun only-standard-methods (gf &rest other-gfs)
    (declare (dynamic-extent other-gfs) (optimize (speed 3) (space 0) (compilation-speed 0)))
    (loop for other-gf in (or other-gfs *standard-gfs*)
          always (loop for method in (generic-function-methods other-gf)
                       for specializer = (first (method-specializers method))
                       if (and (typep specializer 'class)
                               (subclassp specializer (find-class 'standard-generic-function))
                               (not (eq specializer (find-class 'standard-generic-function)))
                               (typep gf specializer))
                       return nil
                       else if (and (typep specializer 'eql-specializer)
                                    (eql (eql-specializer-object specializer) gf))
                       return nil
                       finally (return t))))

  (defun methods-all-the-same-specializers (gf)
    (declare (optimize (speed 3) (space 0) (compilation-speed 0)))
    (loop with template = (first (generic-function-methods gf))
          for method in (rest (generic-function-methods gf))
          always (loop for spec1 in (method-specializers template)
                       for spec2 in (method-specializers method)
                       always (etypecase spec1
                                (class (etypecase spec2
                                         (class (eq spec1 spec2))
                                         (eql-specializer nil)))
                                (eql-specializer
                                 (etypecase spec2
                                   (class nil)
                                   (eql-specializer
                                    (eql (eql-specializer-object spec1)
                                         (eql-specializer-object spec2)))))))))

  (cl:defmethod compute-discriminating-function ((gf standard-generic-function))
    (declare (optimize (speed 3) (space 0) (compilation-speed 0)))
    (let ((nof-required-args (length (required-args (generic-function-lambda-list gf))))
          discriminator)
      (compute-argument-order gf nof-required-args)
      (flet ((discriminate (emf-setter args &optional (classes (loop for arg in args
                                                                     repeat nof-required-args
                                                                     collect (class-of arg))))
               (declare (type list args classes) (type function emf-setter))
               (multiple-value-bind (emf validp) (get-emf-using-classes gf args classes nof-required-args)
                 (funcall emf-setter (if validp emf (lambda (&rest args)
                                                      (declare (dynamic-extent args))
                                                      (apply (the function (get-emf gf args nof-required-args)) args))))
                 (apply (the function emf) args))))
        (when (only-standard-methods gf #'compute-applicable-methods #'compute-applicable-methods-using-classes)
          (setq discriminator
                (if (only-standard-methods gf #'compute-effective-method #'compute-effective-method-function)
                  (call-next-method)
                  (cond ((null (generic-function-methods gf))
                         (lambda (&rest args)
                           (declare (dynamic-extent args))
                           (apply #'no-applicable-method gf args)))
                        ((methods-all-the-same-specializers gf)
                         (let ((specializers (method-specializers (first (generic-function-methods gf))))
                               (effective-method-function nil))
                           (declare (type list specializers))
                           (lambda (&rest args)
                             (declare (dynamic-extent args) (optimize (speed 3) (safety 0) (debug 0)
                                                                      (compilation-speed 0)))
                             (cond ((loop for arg in args
                                          for spec in specializers
                                          always (etypecase spec
                                                   (class (typep arg spec))
                                                   (eql-specializer (eql arg (eql-specializer-object spec)))))
                                    (if effective-method-function
                                      (apply (the function effective-method-function) args)
                                      (discriminate (lambda (emf) (setq effective-method-function emf)) args)))
                                   (t (apply #'no-applicable-method gf args))))))
                        ((= (length (argument-order gf)) 1)
                         (let ((dispatch-argument-index (svref (argument-order gf) 0))
                               (emfs (make-hash-table :test #'eq)))
                           (declare (type hash-table emfs) (type fixnum dispatch-argument-index))
                           (lambda (&rest args)
                             (declare (dynamic-extent args) (optimize (speed 3) (safety 0) (debug 0)
                                                                      (compilation-speed 0)))
                             (let* ((dispatch-class (class-of (nth dispatch-argument-index args)))
                                    (effective-method-function (gethash dispatch-class emfs)))
                               (if effective-method-function
                                 (apply (the function effective-method-function) args)
                                 (discriminate (lambda (emf) (setf (gethash dispatch-class emfs) emf)) args))))))))))
        (if discriminator discriminator
          (let ((emfs (make-hash-table :test #'equal)))
            (declare (type hash-table emfs))
            (lambda (&rest args)
              (declare (dynamic-extent args) (optimize (speed 3) (safety 0) (debug 0)
                                                       (compilation-speed 0)))
              (let* ((classes (loop for arg in args
                                    repeat nof-required-args
                                    collect (class-of arg)))
                     (effective-method-function (gethash (the list classes) emfs)))
                (if effective-method-function
                  (apply (the function effective-method-function) args)
                  (discriminate (lambda (emf) (setf (gethash (the list classes) emfs) emf)) args classes)))))))))

  (defmacro defgeneric (&whole form name (&rest args) &body options)
    (unless (every #'consp options)
      (error "Illegal generic function options in defgeneric form ~S." form))
    (let ((options-without-methods (remove :method options :key #'car :test #'eq)))
      `(progn
         (eval-when (:compile-toplevel)
           (cl:defgeneric ,name ,args ,@options-without-methods))
         (eval-when (:load-toplevel :execute)
           (cl:defgeneric ,name ,args ,@options)))))

  (defmacro defmethod (&whole form name &body body)
    (declare (ignore body))
    (let ((generic-function (when (fboundp name) (fdefinition name))))
      (unless generic-function
        (warn "No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function." name))
      `(cl:defmethod ,@(cdr form)))))

409
#+sbcl
Pascal Costanza's avatar
Pascal Costanza committed
410
411
412
413
(defun ensure-method (gf lambda-expression 
                         &key (method-class (generic-function-method-class gf))
                         (qualifiers ())
                         (lambda-list (cadr lambda-expression))
414
                         (specializers (required-args lambda-list (constantly (find-class 't)))))
Pascal Costanza's avatar
Pascal Costanza committed
415
416
417
418
419
  (multiple-value-bind
      (method-lambda method-args)
      (make-method-lambda
       gf (class-prototype method-class)
       lambda-expression ())
420
421
422
423
424
    (let ((method (apply #'make-instance
                         method-class
                         :qualifiers qualifiers
                         :lambda-list lambda-list
                         :specializers specializers
425
                         :function (compile nil method-lambda)
426
                         method-args)))
Pascal Costanza's avatar
Pascal Costanza committed
427
428
      (add-method gf method)
      method)))
429
430


431
#-sbcl
432
433
434
(defun ensure-method (gf lambda-expression 
                         &key (qualifiers ())
                         (lambda-list (cadr lambda-expression))
435
                         (specializers (required-args lambda-list (constantly 't))))
436
437
438
439
  (funcall (compile nil `(lambda ()
                           (defmethod ,(generic-function-name gf) ,@qualifiers
                             ,(loop for specializer in specializers
                                    for (arg . rest) on lambda-list
440
                                    collect `(,arg ,specializer) into args
441
442
                                    finally (return (nconc args rest)))
                             ,@(cddr lambda-expression))))))
Pascal Costanza's avatar
Pascal Costanza committed
443

444
445
446
447
448
449
450
451
452
453
454
455
456
;; 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
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
;; 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
Pascal Costanza's avatar
Pascal Costanza committed
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
  #+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
            (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)))))
            initargs)))
Pascal Costanza's avatar
Pascal Costanza committed
494

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

498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
#-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
516
517
518

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