Coverage report: /home/ati/workspace/perec/persistence/mop.lisp

KindCoveredAll%
expression362374 96.8
branch3940 97.5
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
2
 ;;;
3
 ;;; Copyright (c) 2006 by the authors.
4
 ;;;
5
 ;;; See LICENCE for details.
6
 
7
 (in-package :cl-perec)
8
 
9
 ;;;;;;;;;;;;;;;
10
 ;;; MOP methods 
11
 
12
 ;; allows persistent keyword argument for persistent-direct-slot-definitions according to CLOS mop
13
 ;; even though there is no such slot in the class
14
 (defmethod shared-initialize :around ((slot persistent-direct-slot-definition) slot-names
15
                                       &rest args &key persistent &allow-other-keys)
16
   (declare (ignore persistent))
17
   (apply #'call-next-method slot slot-names args))
18
 
19
 (defmethod make-instance ((object identity-preserving-class) &key instance &allow-other-keys)
20
   ;; used in class finalization protocol when instantiating direct slot definitions
21
   ;; this allows associations to be defined independently of direct slot definitions
22
   ;; and ensure-class to be called without loosing the old non association direct slot definitions
23
   (aif instance
24
        it
25
        (call-next-method)))
26
 
27
 (defmethod initialize-instance :around ((class persistent-class) &rest args)
28
   (apply #'shared-ininitialize-around-persistent-class class #'call-next-method args))
29
 
30
 (defmethod reinitialize-instance :around ((class persistent-class) &rest args)
31
   ;; update type dependencies first
32
   (mapc #L(delete! class (depends-on-of !1))
33
         (depends-on-me-of class))
34
   (setf (depends-on-me-of class) nil)
35
   ;; emulate shared initialize which is not allowed to be overridden
36
   (apply #'shared-ininitialize-around-persistent-class class #'call-next-method :name (class-name class) args))
37
 
38
 (defmethod reinitialize-instance :before ((association persistent-association) &key &allow-other-keys)
39
   (mapc #L(delete! association (depends-on-of !1))
40
         (associated-classes-of association)))
41
 
42
 (defmethod shared-initialize :after ((association persistent-association) slot-names &key &allow-other-keys)
43
   (mapc #L(pushnew association (depends-on-of !1))
44
         (associated-classes-of association)))
45
 
46
 (defmethod validate-superclass ((class standard-class)
47
                                 (superclass persistent-class))
48
   t)
49
 
50
 (defmethod validate-superclass ((class persistent-class)
51
                                 (superclass standard-class))
52
   t)
53
 
54
 (defmethod direct-slot-definition-class ((class persistent-class)
55
                                          &key instance persistent association &allow-other-keys)
56
   (cond (instance
57
          (class-of instance))
58
         (association
59
          (find-class 'persistent-association-end-direct-slot-definition))
60
         (persistent
61
          (find-class 'persistent-direct-slot-definition))
62
         (t
63
          (call-next-method))))
64
 
65
 (defmethod effective-slot-definition-class ((class persistent-class)
66
                                             &key instance persistent association &allow-other-keys)
67
   (cond (instance
68
          (class-of instance))
69
         (association
70
          (find-class 'persistent-association-end-effective-slot-definition))
71
         (persistent
72
          (find-class 'persistent-effective-slot-definition))
73
         (t
74
          (call-next-method))))
75
 
76
 (defmethod compute-effective-slot-definition ((class persistent-class)
77
                                               slot-name
78
                                               direct-slot-definitions)
79
   (if (some (lambda (slot)
80
               (typep slot 'persistent-direct-slot-definition))
81
             direct-slot-definitions)
82
       (bind ((standard-initargs (compute-standard-effective-slot-definition-initargs class direct-slot-definitions))
83
              (slot-initargs (compute-persistent-effective-slot-definition-initargs class direct-slot-definitions))
84
              (initargs (append slot-initargs standard-initargs))
85
              (effective-slot-class (apply #'effective-slot-definition-class class :persistent #t initargs)))
86
         (prog1-bind effective-slot-definition
87
             (apply #'make-instance effective-slot-class :direct-slots direct-slot-definitions initargs)
88
           (bind ((type (slot-definition-type effective-slot-definition))
89
                  (normalized-type (normalized-type-for type))
90
                  (mapped-type (mapped-type-for normalized-type))
91
                  (unbound-subtype-p (and (not (unbound-subtype-p mapped-type))
92
                                          (unbound-subtype-p type)))
93
                  (null-subtype-p (and (not (null-subtype-p mapped-type))
94
                                       (null-subtype-p type)))
95
                  (initfunction (slot-definition-initfunction effective-slot-definition)))
96
             (when (and (or null-subtype-p
97
                            (set-type-p type))
98
                        (not unbound-subtype-p)
99
                        (not initfunction))
100
               (setf (slot-definition-initfunction effective-slot-definition)
101
                     (constantly nil))))))
102
       (call-next-method)))
103
 
104
 (defun compute-standard-effective-slot-definition-initargs (class direct-slot-definitions)
105
   #+sbcl(sb-pcl::compute-effective-slot-definition-initargs class direct-slot-definitions)
106
   #-sbcl(not-yet-implemented))
107
 
108
 (defun compute-persistent-effective-slot-definition-initargs (class direct-slot-definitions)
109
   (iter (for slot-option-name in (delete-duplicates
110
                                   (collect-if #L(not (eq (symbol-package !1) (find-package :common-lisp)))
111
                                               (mapcan #L(mapcar #'slot-definition-name
112
                                                                 (class-slots (class-of !1)))
113
                                                       direct-slot-definitions))))
114
         (bind ((specific-direct-slot-definitions
115
                 (collect-if #L(find slot-option-name (class-slots (class-of !1)) :key 'slot-definition-name)
116
                             direct-slot-definitions)))
117
           (appending
118
            (compute-persistent-effective-slot-definition-option class
119
                                                                 (first (sort (copy-list specific-direct-slot-definitions)
120
                                                                              #L(subtypep (class-of !1) (class-of !2))))
121
                                                                 slot-option-name
122
                                                                 specific-direct-slot-definitions)))))
123
 
124
 (defgeneric compute-persistent-effective-slot-definition-option (class direct-slot slot-option-name direct-slot-definitions)
125
   (:method ((class persistent-class)
126
             (direct-slot persistent-direct-slot-definition)
127
             slot-option-name
128
             direct-slot-definitions)
129
            (when (member slot-option-name '(cache prefetch index unique type-check))
130
              (some #L(slot-initarg-and-value !1 slot-option-name) direct-slot-definitions)))
131
 
132
   (:method ((class persistent-class)
133
             (direct-slot persistent-association-end-direct-slot-definition)
134
             slot-option-name
135
             direct-slot-definitions)
136
            (if (member slot-option-name '(min-cardinality max-cardinality association))
137
                (some #L(slot-initarg-and-value !1 slot-option-name) direct-slot-definitions)
138
                (call-next-method))))
139
 
140
 (defmethod finalize-inheritance :after ((class persistent-class))
141
   (invalidate-computed-slot class 'persistent-direct-super-classes)
142
   (invalidate-computed-slot class 'persistent-effective-super-classes)
143
   (invalidate-computed-slot class 'persistent-direct-sub-classes)
144
   (invalidate-computed-slot class 'persistent-effective-sub-classes)
145
   (mapc #L(ensure-slot-reader* class !1)
146
         (collect-if #L(set-type-p (normalized-type-of !1))
147
                     (persistent-effective-slots-of class))))
148
 
149
 (defmethod compute-slots :after ((class persistent-class))
150
   "Invalidates the cached slot value of persistent-effective-slots whenever the effective slots are recomputed, so that all dependent computed state will be invalidated and recomputed when requested."
151
   (invalidate-computed-slot class 'persistent-effective-slots))
152
 
153
 ;;;;;;;;;;;
154
 ;;; Utility
155
 
156
 (defun ensure-persistent-object-class (name direct-superclasses)
157
   (if (eq 'persistent-object name)
158
       direct-superclasses
159
       (let ((persistent-object (find-class 'persistent-object))
160
             (persistent-class (find-class 'persistent-class)))
161
         (if (find-if (lambda (direct-superclass)
162
                        (member persistent-class
163
                                (compute-class-precedence-list
164
                                 (class-of direct-superclass))))
165
                      direct-superclasses)
166
             direct-superclasses
167
             (append direct-superclasses (list persistent-object))))))
168
 
169
 (defun process-direct-slot-definitions (direct-slots)
170
   (loop for direct-slot :in direct-slots
171
         collect (if (or (getf direct-slot :instance)
172
                         (getf direct-slot :persistent))
173
                     direct-slot
174
                     (if (hasf direct-slot :persistent)
175
                         ;; remove :persistent nil
176
                         (remove-keywords direct-slot :persistent)
177
                         ;; add default :persistent t
178
                         (append direct-slot '(:persistent t))))))
179
 
180
 (defun association-direct-slot-definitions (class)
181
   (when (slot-boundp class 'depends-on)
182
     (let ((depends-on-associations
183
            (collect-if #L(typep !1 'persistent-association)
184
                        (depends-on-of class))))
185
       (mappend (lambda (association)
186
                  (let ((association-end-definitions
187
                        (collect-if #L(eq (class-name class) (getf !1 :class))
188
                                    (association-end-definitions-of association))))
189
                   (mapcar #L(append (list :name (getf !1 :slot)
190
                                           :association association
191
                                           :persistent #t)
192
                                     (remove-keywords !1 :slot :class :accessor))
193
                           association-end-definitions)))
194
                depends-on-associations))))
195
 
196
 ;; this is not the real shared-initialize because portable programs are not allowed to override that
197
 ;; so we are somewhat emulating it by calling this function from both initialize-instance and reinitialize-instance
198
 (defun shared-ininitialize-around-persistent-class (class call-next-method &rest args
199
                                                     &key name direct-slots direct-superclasses &allow-other-keys)
200
   ;; call initialize-instance or reinitialize-instance next method
201
   (prog1
202
       (apply call-next-method
203
              class
204
              :direct-slots (append (process-direct-slot-definitions direct-slots)
205
                                    (association-direct-slot-definitions class))
206
              :direct-superclasses (ensure-persistent-object-class name direct-superclasses)
207
              :abstract (first (getf args :abstract))
208
              (remove-keywords args :direct-slots :direct-superclasses :abstract))
209
     (setf (find-persistent-class name) class)
210
     (invalidate-computed-slot class 'persistent-direct-slots)
211
     ;; update type specific class dependencies
212
     (mapc #L(bind ((type (normalized-type-for (slot-definition-type !1))))
213
               (when (set-type-p type)
214
                 (bind ((associated-class (find-class (set-type-class-for type))))
215
                   (pushnew class (depends-on-of associated-class))
216
                   (pushnew associated-class (depends-on-me-of class)))))
217
           (persistent-direct-slots-of class))
218
     (mapc #L(bind ((association (association-of !1))
219
                    (association-end-position
220
                     (position (slot-definition-name !1) (association-end-definitions-of association)
221
                               :key #L(getf !1 :slot))))
222
               (if (= 0 association-end-position)
223
                   (setf (primary-association-end-of association) !1)
224
                   (setf (secondary-association-end-of association) !1)))
225
           (collect-if #L (typep !1 'persistent-association-end-direct-slot-definition)
226
                       (class-direct-slots class)))))
227
 
228
 (defun ensure-slot-reader* (class slot)
229
   (bind ((reader (concatenate-symbol (first (some #'slot-definition-readers (direct-slots-of slot))) "*"))
230
          (reader-gf (ensure-generic-function reader :lambda-list '(object))))
231
     (ensure-method reader-gf
232
                    `(lambda (object)
233
                      (with-lazy-collections
234
                        (slot-value-using-class ,class object ,slot)))
235
                    :specializers (list class))))
236
 
237
 (defun slot-initarg-and-value (object slot-name)
238
   (when (slot-boundp object slot-name)
239
     (list (first (slot-definition-initargs (find-slot (class-of object) slot-name)))
240
           (slot-value object slot-name))))