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
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
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
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
|
(in-package :closer-mop)
;; In CMUCL, reader-method-class and writer-method-class are
;; not used during class initialization. The following definitions
;; correct this.
(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)))))
;; The following methods additionally create a gensym for the class name
;; unless a name is explicitly provided. AMOP requires classes to be
;; potentially anonymous.
(defmethod initialize-instance :around
((class standard-class) &rest initargs
&key (name (gensym)))
(prog1 (apply #'call-next-method class :name name initargs)
(modify-accessors class)))
(defmethod initialize-instance :around
((class funcallable-standard-class) &rest initargs
&key (name (gensym)))
(prog1 (apply #'call-next-method class :name name initargs)
(modify-accessors class)))
(defmethod reinitialize-instance :after
((class standard-class) &key)
(modify-accessors class))
(defmethod reinitialize-instance :after
((class funcallable-standard-class) &key)
(modify-accessors class))
;;; The following three methods ensure that the dependent protocol
;;; for generic function works.
;; The following method additionally ensures that
;; compute-discriminating-function is triggered.
; Note that for CMUCL, these methods violate the AMOP specification
; by specializing on the original standard-generic-function metaclass. However,
; this is necassary because in CMUCL, only one subclass of
; standard-generic-function can be created, and taking away that option from user
; code doesn't make a lot of sense in our context.
(defmethod reinitialize-instance :after
((gf standard-generic-function) &rest initargs)
(set-funcallable-instance-function gf (compute-discriminating-function gf)))
;; The following ensures that effective slot definitions have a documentation in CMUCL.
(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))
;; In CMUCL, TYPEP and SUBTYPEP don't work as expected
;; in conjunction with class metaobjects.
(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))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :closer-mop *features*))
|
