/
mop.lisp
175 lines (152 loc) · 5.98 KB
/
mop.lisp
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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
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
;;; -*- Mode: Lisp -*-
;;; This software is in the public domain and is
;;; provided with absolutely no warranty.
(in-package #:storage)
(defclass storage ()
((modified :initform nil
:accessor modified)
(data :initform nil
:accessor storage-data)
(file :initarg :file
:initform nil
:accessor storage-file)))
(defclass storable-class (standard-class)
((slots-to-store :initform nil
:accessor slots-to-store)
(slot-locations-and-initforms
:initform nil
:accessor slot-locations-and-initforms)
(slot-locations-and-initforms-read
:initform nil
:accessor slot-locations-and-initforms-read)
(all-slot-locations-and-initforms
:initform nil
:accessor all-slot-locations-and-initforms)
(number-of-bytes-for-slots
:initform nil
:accessor number-of-bytes-for-slots)
(relations :initform nil
:accessor class-relations)
(initforms :initform nil
:accessor class-initforms)
(objects :initform nil
:accessor objects-of-class)
(storage :initarg :storage
:initform nil
:accessor class-storage)
(search-key :initarg :search-key
:initform nil
:accessor search-key)))
(defun initialize-storable-class (next-method class &rest args
&key direct-superclasses &allow-other-keys)
(apply next-method class
(if direct-superclasses
args
(list* :direct-superclasses (list (find-class 'identifiable))
args))))
(defmethod initialize-instance :around ((class storable-class) &rest args)
(apply #'initialize-storable-class #'call-next-method class args))
(defmethod reinitialize-instance :around ((class storable-class) &rest args)
(apply #'initialize-storable-class #'call-next-method class args))
;;;
(defmethod validate-superclass
((class standard-class) (superclass storable-class))
t)
(defmethod validate-superclass
((class storable-class) (superclass standard-class))
t)
(defclass storable-slot-mixin ()
((storep :initarg :storep
:initform t
:reader store-slot-p)
(relation :initarg :relation
:initform nil
:reader slot-relation)
(db-type :initarg :db-type
:initform nil
:reader slot-db-type)
(read-only-p :initarg :read-only-p
:initform nil
:reader slot-read-only-p)
(unit :initarg :unit
:initform nil
:reader slot-unit)))
(defclass storable-direct-slot-definition
(storable-slot-mixin standard-direct-slot-definition)
())
(defclass storable-effective-slot-definition
(storable-slot-mixin standard-effective-slot-definition)
())
(defmethod direct-slot-definition-class ((class storable-class) &key)
(find-class 'storable-direct-slot-definition))
(defmethod effective-slot-definition-class ((class storable-class) &key)
(find-class 'storable-effective-slot-definition))
(defmethod compute-effective-slot-definition
((class storable-class) slot-name direct-definitions)
(declare (ignore slot-name))
(let ((effective-definition (call-next-method))
(direct-definition (car direct-definitions)))
(with-slots (storep relation db-type
read-only-p unit)
effective-definition
(setf storep (store-slot-p direct-definition)
relation (slot-relation direct-definition)
db-type (slot-db-type direct-definition)
read-only-p (slot-read-only-p direct-definition)
unit (slot-unit direct-definition)))
effective-definition))
(defun slots-with-relations (class)
(loop for slot across (slots-to-store class)
for relation = (slot-relation slot)
when relation
collect (cons (slot-definition-location slot)
relation)))
(defun make-slots-cache (slot-definitions)
(map 'vector
(lambda (slot-definition)
(cons (slot-definition-location slot-definition)
(slot-definition-initform slot-definition)))
slot-definitions))
(defun initialize-class-slots (class slots)
(let* ((slots-to-store (coerce (remove-if-not #'store-slot-p slots)
'simple-vector)))
(when (> (length slots-to-store) 32)
(error "Can't have classes with more than 32 storable slots."))
(setf (slots-to-store class)
slots-to-store)
(setf (number-of-bytes-for-slots class)
(ceiling (length slots-to-store) 8))
(setf (slot-locations-and-initforms class)
(make-slots-cache slots-to-store))
(setf (slot-locations-and-initforms-read class)
(copy-seq (slot-locations-and-initforms class)))
(setf (all-slot-locations-and-initforms class)
(make-slots-cache slots))
(setf (class-initforms class)
(map 'vector #'slot-definition-initform slots))
(setf (class-relations class)
(slots-with-relations class))
(compute-search-key class)))
(defmethod finalize-inheritance :after ((class storable-class))
(initialize-class-slots class (class-slots class)))
(defun find-slot (slot-name class)
(find slot-name (class-slots class)
:key #'slot-definition-name))
(defun compute-search-key (class)
(with-slots (search-key) class
(let* ((key (or search-key
(loop for superclass in (class-direct-superclasses class)
thereis (and (typep superclass 'storable-class)
(search-key superclass)))))
(slot-name (typecase key
(cons (car key))
(symbol key))))
(setf search-key slot-name)
(when slot-name
(unless (find-slot slot-name class)
(setf search-key nil)
(error "Search key ~a for an uknown slot in class ~a"
slot-name class))))))
(defmethod initialize-instance :after ((class storable-class) &key)
(when (class-storage class)
(pushnew class (storage-data (class-storage class)))))