-
Notifications
You must be signed in to change notification settings - Fork 29
/
node-class.lisp
174 lines (151 loc) · 7.27 KB
/
node-class.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
(in-package :graph-db)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass node-class (standard-class) nil)
(defmethod validate-superclass ((class node-class) (super standard-class))
"Node classes may inherit from ordinary classes."
t)
(defclass node-slot-definition (standard-slot-definition)
((persistent :accessor persistent-p :initarg :persistent :initform t :allocation :instance)
(indexed :accessor indexed-p :initarg :index :initform nil :allocation :instance)
(ephemeral :accessor ephemeral-p :initarg :ephemeral :initform nil :allocation :instance)
(meta :accessor meta-p :initarg :meta :initform nil :allocation :instance)))
(defmethod persistent-p (slot-def)
nil)
(defmethod indexed-p (slot-def)
nil)
(defmethod ephemeral-p (slot-def)
nil)
(defmethod meta-p (slot-def)
nil)
(defclass node-direct-slot-definition
(standard-direct-slot-definition node-slot-definition)
())
(defclass node-effective-slot-definition
(standard-effective-slot-definition node-slot-definition)
())
(defmethod data-slots ((instance node-class))
"Return a list of managed slot names for an instance."
(map 'list 'slot-definition-name
(remove-if-not #'(lambda (i)
(or (persistent-p i) (ephemeral-p i)))
(class-slots instance))))
(defmethod meta-slot-names ((instance node-class))
"Return a list of metadata slot names for an instance."
;;(log:debug "meta-slot-names(~A)" instance)
(let ((names
(map 'list 'slot-definition-name
(remove-if-not #'(lambda (i)
(meta-p i))
(class-slots instance)))))
;;(log:debug "meta-slot-names(~A): ~A" instance names)
names))
(defmethod persistent-slot-names ((instance node-class))
"Return a list of persistent slot names for an instance."
;;(log:debug "persistent-slot-names(~A)" instance)
(let ((names
(map 'list 'slot-definition-name
(remove-if-not #'(lambda (i)
(persistent-p i))
(class-slots instance)))))
;;(log:debug "persistent-slot-names(~A): ~A" instance names)
names))
(defmethod ephemeral-slot-names ((instance node-class))
"Return a list of persistent slot names for an instance."
;;(log:debug "ephemeral-slot-names(~A)" instance)
(let ((names
(map 'list 'slot-definition-name
(remove-if-not #'(lambda (i)
(ephemeral-p i))
(class-slots instance)))))
;;(log:debug "ephemeral-slot-names(~A): ~A" instance names)
names))
(defmethod direct-slot-definition-class ((class node-class) &rest initargs)
(declare (ignore initargs))
(log:trace "direct-slot-definition-class for ~A" class)
(find-class 'node-direct-slot-definition))
(defmethod effective-slot-definition-class ((class node-class) &rest initargs)
(declare (ignore initargs))
(log:trace "effective-slot-definition-class for ~A" class)
(find-class 'node-effective-slot-definition))
(defmethod compute-effective-slot-definition :around
((class node-class) slot-name direct-slots)
"Ensure inheritance from direct slot definition of persistent, indexed,
and ephemeral properties."
(log:trace "compute-effective-slot-definition for ~A / ~A: ~A" class slot-name direct-slots)
(let ((slot (call-next-method)))
;;(log:debug " SLOT: ~A" slot)
(cond ((or (meta-p slot) (some 'meta-p direct-slots))
(setf (slot-value slot 'meta) t)
(setf (slot-value slot 'persistent) nil))
((or (persistent-p slot) (some 'persistent-p direct-slots))
(setf (slot-value slot 'persistent) t))
(t
(setf (slot-value slot 'persistent) nil)
(setf (slot-value slot 'ephemeral) t)))
(when (or (indexed-p slot) (some 'indexed-p direct-slots))
(setf (slot-value slot 'indexed) t)
;; FIXME: Generate index if needed
)
slot))
(defmethod find-all-subclasses ((class class))
;;(log:debug "Finding subclasses for ~A" class)
(let ((result nil))
(labels ((find-them (class)
(let ((subclasses (class-direct-subclasses class)))
;;(log:debug "Found subclasses for ~A: ~A" class subclasses)
(dolist (subclass subclasses)
(unless (find subclass result)
(push subclass result)
(find-them subclass))))))
(find-them class)
result)))
(defmethod find-all-subclass-names ((class class))
(mapcar 'class-name (find-all-subclasses class)))
(defmethod find-ancestor-classes ((class-name symbol))
(find-ancestor-classes (find-class class-name)))
(defmethod find-ancestor-classes ((class node-class))
(delete-if (lambda (class)
(find (class-name class)
#+sbcl '(edge vertex node STANDARD-OBJECT SB-PCL::SLOT-OBJECT T)
#+lispworks '(edge vertex node standard-object T)
#+ccl '(edge vertex node STANDARD-OBJECT T)))
(compute-class-precedence-list class)))
(defmethod find-graph-parent-classes ((class node-class))
(let ((classes
(remove-if (lambda (class)
(or (eq (class-name class) 'vertex)
(eq (class-name class) 'edge)
(eq (class-name class) 'primitive-node)))
(class-direct-superclasses class))))
(remove-duplicates
(nconc classes
(mapcan 'find-graph-parent-classes classes)))))
)
(defclass node ()
((id :accessor id :initform +null-key+ :initarg :id :meta t
:type (simple-array (unsigned-byte 8) (16)) :persistent nil)
(type-id :accessor type-id :initform 1 :initarg :type-id :meta t
:type (unsigned-byte 16) :persistent nil)
(revision :accessor revision :initform 0 :initarg :revision :meta t
:type (unsigned-byte 32) :persistent nil)
(%revision-table :accessor %revision-table :initform (make-hash-table :test 'eq)
:initarg :revision-table :meta t :persistent nil)
(heap-written-p :accessor heap-written-p :initform nil :initarg :heap-written-p
:type boolean :meta t :persistent nil)
(type-idx-written-p :accessor type-idx-written-p :initform nil :meta t
:initarg :type-idx-written-p :type boolean :persistent nil)
(ve-written-p :accessor ve-written-p :initform nil :initarg :ve-written-p
:type boolean :meta t :persistent nil)
(vev-written-p :accessor vev-written-p :initform nil :initarg :vev-written-p
:type boolean :meta t :persistent nil)
(views-written-p :accessor views-written-p :initform nil :meta t
:initarg :views-written-p :type boolean :persistent nil)
(written-p :accessor written-p :initform nil :initarg :written-p :type boolean
:meta t :persistent nil)
(data-pointer :accessor data-pointer :initform 0 :initarg :data-pointer
:type (unsigned-byte 64) :meta t :persistent nil)
(deleted-p :accessor deleted-p :initform nil :initarg :deleted-p :type boolean
:meta t :persistent nil)
(data :accessor data :initarg :data :initform nil :meta t :persistent nil)
(bytes :accessor bytes :initform :init :initarg :bytes :meta t :persistent nil))
(:metaclass node-class))