Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 420 lines (347 sloc) 19.099 kb
cd16522 @hargettp Initial work on red-black trees
authored
1 (in-package :rb-tree)
2
3 ;; =====================================================================================================================
4 ;;
5 ;; persistent red-black tree
6 ;;
7 ;; ---------------------------------------------------------------------------------------------------------------------
8
9
10 ;; ---------------------------------------------------------------------------------------------------------------------
11 ;; types
12 ;; ---------------------------------------------------------------------------------------------------------------------
13
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
14 (defclass red-black-tree-storage ()
15 ())
16
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
17 (defclass red-black-tree-memory-storage (red-black-tree-storage)
18 ((objects :initform (make-array 0 :adjustable t) :accessor objects)
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
19 (root :accessor root)))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
20
21 (defclass red-black-tree-file-storage (red-black-tree-storage)
22 ((file-name :initarg :file-name :accessor file-name)))
23
cd16522 @hargettp Initial work on red-black trees
authored
24 (defclass persistent-red-black-node (red-black-node)
25 ())
26
27 (defclass persistent-red-black-tree (red-black-tree)
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
28 ((storage :initform (make-instance 'red-black-tree-memory-storage) :initarg :storage :accessor storage)
29 (root :initform 0 :accessor root)
30 ;; hard-coding it's value
31 (leaf :initform 0 :accessor leaf)))
cd16522 @hargettp Initial work on red-black trees
authored
32
33 (defclass red-black-tree-transaction ()
34 ((tree :initarg :tree :accessor tree)
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
35 (new-root :initform nil :accessor new-root)
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
36 (next-id :initform -1 :accessor next-id)
37 (next-location :initform nil :accessor next-location)
38 (object-to-id :initform (make-hash-table) :accessor object-to-id
39 :documentation "Maps objects to their temporary ids, which they have before transaction commit assigns a
40 permanent locationin storage")
d36af4b @hargettp Now storing data discretely in storage, separate from nodes themselves
authored
41 (id-to-object :initform (make-hash-table) :accessor id-to-object)
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
42 (object-to-location :initform (make-hash-table) :accessor object-to-location
43 :documentation "Maps objects to their permanent location in storage, which they have
44 if they already existed in storage, or after a commit")
45 (location-to-object :initform (make-hash-table) :accessor location-to-object)
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
46 (changes :initform (make-hash-table) :accessor changes)))
cd16522 @hargettp Initial work on red-black trees
authored
47
48 ;; ---------------------------------------------------------------------------------------------------------------------
49 ;; variables
50 ;; ---------------------------------------------------------------------------------------------------------------------
51
52 (defvar *rb-transaction* nil
53 "The currently active transaction on a red-black tree")
54
55 ;; ---------------------------------------------------------------------------------------------------------------------
56 ;; generics
57 ;; ---------------------------------------------------------------------------------------------------------------------
58
d36af4b @hargettp Now storing data discretely in storage, separate from nodes themselves
authored
59 (defgeneric allocate-id (transaction obj))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
60
d36af4b @hargettp Now storing data discretely in storage, separate from nodes themselves
authored
61 (defgeneric object-for-id (transaction id))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
62
d36af4b @hargettp Now storing data discretely in storage, separate from nodes themselves
authored
63 (defgeneric id-for-object (transaction obj))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
64
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
65 (defgeneric object-for-location (transaction location))
66
67 (defgeneric location-for-object (transaction obj))
68
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
69 (defgeneric add-new-object (transaction object))
366c1cb @hargettp Removed unecessary change to key when updating rather than inserting
authored
70
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
71 (defgeneric add-changed-object (transaction object))
72
73 (defgeneric add-opened-object (transaction object id))
366c1cb @hargettp Removed unecessary change to key when updating rather than inserting
authored
74
cd16522 @hargettp Initial work on red-black trees
authored
75 (defgeneric prb-open-storage (storage)
76 (:documentation "Prepare storage for use; after this call load & save operations should succeed"))
77
78 (defgeneric prb-close-storage (storage)
79 (:documentation "Release storage from use; further load & save operations cannot succeed without a subsequent open call"))
80
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
81 (defgeneric prb-location (storage)
82 (:documentation "Return the id immediately after the content in the storage"))
83
84 (defgeneric assign-location (storage *rb-transaction* object))
85
86 (defgeneric allocation-size (storage object)
87 (:documentation "Compute the amount of space in the storage to allocate"))
88
89 (defgeneric prb-load (storage location)
90 (:documentation "Load the object at the indicated id from storage (usually data or a node)"))
cd16522 @hargettp Initial work on red-black trees
authored
91
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
92 (defgeneric prb-get-root (storage)
93 (:documentation "Return the root according to storage"))
94
95 (defgeneric prb-set-root (storage root)
96 (:documentation "Set the root of storage"))
97
98 (defgeneric prb-save (storage object)
366c1cb @hargettp Removed unecessary change to key when updating rather than inserting
authored
99 (:documentation "Save the indicated object in storage (usually a node or tree);
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
100 return a reference to its id within the storage"))
cd16522 @hargettp Initial work on red-black trees
authored
101
366c1cb @hargettp Removed unecessary change to key when updating rather than inserting
authored
102 (defgeneric prb-commit (transaction-or-tree)
cd16522 @hargettp Initial work on red-black trees
authored
103 (:documentation "Orchestrate the persisting of all changes to a tree, including all changed nodes"))
104
366c1cb @hargettp Removed unecessary change to key when updating rather than inserting
authored
105 (defgeneric prb-abort (transaction-or-tree)
cd16522 @hargettp Initial work on red-black trees
authored
106 (:documentation "Abandon any changes in the tree; note that any nodes held should be reacquired after an abort"))
107
108 ;; ---------------------------------------------------------------------------------------------------------------------
109 ;; implementation
110 ;; ---------------------------------------------------------------------------------------------------------------------
111
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
112 (define-condition requires-red-black-transaction ()
113 ()
114 (:report (lambda (condition stream)
115 (declare (ignorable condition))
116 (format stream "Accessing a persistent red-black tree requires a transaction; wrap code in a with-rb-transaction form"))))
117
118 (defun require-rb-transaction ()
119 (unless *rb-transaction*
120 (error 'requires-red-black-transaction)))
121
122 (macrolet ((declare-slot-translation (slot)
123 `(progn
124 (defmethod ,slot :around ((node persistent-red-black-node))
125 (require-rb-transaction)
d36af4b @hargettp Now storing data discretely in storage, separate from nodes themselves
authored
126 (let ((id (call-next-method)))
127 (or (object-for-id *rb-transaction* id)
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
128 (let ((node (prb-load (storage (tree *rb-transaction*)) id)))
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
129 (add-opened-object *rb-transaction* node id)
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
130 node))))
131
132 (defmethod (setf ,slot) :around (value (node persistent-red-black-node))
133 (require-rb-transaction)
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
134 (add-changed-object *rb-transaction* node)
d36af4b @hargettp Now storing data discretely in storage, separate from nodes themselves
authored
135 (call-next-method (id-for-object *rb-transaction* value) node)))))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
136 (declare-slot-translation parent)
137 (declare-slot-translation left)
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
138 (declare-slot-translation right)
139 (declare-slot-translation data))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
140
141 (defmethod (setf color) (color (node persistent-red-black-node))
142 (require-rb-transaction)
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
143 (add-changed-object *rb-transaction* node)
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
144 (call-next-method))
145
146 (defmethod root :around ((tree persistent-red-black-tree))
147 (require-rb-transaction)
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
148 (let ((id (or (and *rb-transaction* (new-root *rb-transaction*))
149 (call-next-method) ;; could be nil, so get from storage
150 (setf (slot-value tree 'root) (prb-get-root (storage tree))))))
d36af4b @hargettp Now storing data discretely in storage, separate from nodes themselves
authored
151 (or (object-for-id *rb-transaction* id)
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
152 (let ((root (prb-load (storage tree) id)))
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
153 (add-opened-object *rb-transaction* root id)
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
154 root))))
155
156 (defmethod (setf root) (node (tree persistent-red-black-tree))
157 (require-rb-transaction)
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
158 (add-changed-object *rb-transaction* node)
d36af4b @hargettp Now storing data discretely in storage, separate from nodes themselves
authored
159 (setf (new-root *rb-transaction*) (id-for-object *rb-transaction* node)))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
160
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
161 (defmethod leaf :around ((tree persistent-red-black-tree))
162 (require-rb-transaction)
163 (let ((id (call-next-method)))
164 (or (object-for-id *rb-transaction* id)
165 (let ((leaf (prb-load (storage tree) id)))
166 (add-opened-object *rb-transaction* leaf id)
167 leaf))))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
168
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
169 (defmethod (setf leaf) (node (tree persistent-red-black-tree))
170 (require-rb-transaction)
171 (add-new-object *rb-transaction* node)
172 (add-changed-object *rb-transaction* node)
173 ;; note we're hard-coding the location
174 (setf (slot-value tree 'leaf) 0))
175
176
177 (defmethod allocate-id ((*rb-transaction* red-black-tree-transaction) obj)
178 (let ((next-id (next-id *rb-transaction*)))
179 ;; we use negative values to ensure no collision with existing, allocated
180 ;; locations in storage
181 (decf (next-id *rb-transaction*))
d36af4b @hargettp Now storing data discretely in storage, separate from nodes themselves
authored
182 next-id))
183
184 (defmethod object-for-id ((*rb-transaction* red-black-tree-transaction) id)
185 (gethash id (id-to-object *rb-transaction*)))
186
187 (defmethod id-for-object ((*rb-transaction* red-black-tree-transaction) obj)
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
188 (or (gethash obj (object-to-id *rb-transaction*))
189 (let ((new-id (allocate-id *rb-transaction* obj)))
190 (setf (gethash obj (object-to-id *rb-transaction*)) new-id)
191 (setf (gethash new-id (id-to-object *rb-transaction*)) obj)
192 new-id)))
193
194 (defmethod object-for-location ((*rb-transaction* red-black-tree-transaction) location)
195 (gethash location (location-to-object *rb-transaction*)))
196
197 (defmethod location-for-object ((*rb-transaction* red-black-tree-transaction) obj)
198 (gethash obj (object-to-location *rb-transaction*)))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
199
200 (defmethod rb-make-node :around ((tree persistent-red-black-tree) &key ((:key key) nil) ((:data data) nil))
201 (declare (ignorable key data))
202 (require-rb-transaction)
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
203 (when data (add-new-object *rb-transaction* data))
204 ;; hard-coding a zero here, on the expectation that the nil sentinel node is first...let's see if that works
205 ;; theoretically, no node other than the sentinel node ever has nil data (and now it should have itself as data)
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
206 (let ((node (call-next-method tree :key (or key 0) :data (if data (id-for-object *rb-transaction* data) 0))))
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
207 (add-new-object *rb-transaction* node)
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
208 node))
209
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
210 (defmethod add-new-object ((*rb-transaction* red-black-tree-transaction) object)
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
211 (let ((new-id (id-for-object *rb-transaction* object)))
212 (setf (gethash new-id (changes *rb-transaction*)) object))
213 ;; (format *standard-output* "Change count is ~s~%" (hash-table-count (changes *rb-transaction*)))
214 object)
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
215
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
216 (defmethod add-changed-object ((*rb-transaction* red-black-tree-transaction) object)
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
217 ;; (when (and (typep object 'persistent-red-black-node)
218 ;; (= 2 (slot-value object 'key)))
219 ;; (break))
220 (setf (gethash (id-for-object *rb-transaction* object) (changes *rb-transaction*))
221 object))
222
223 (defmethod add-opened-object ((*rb-transaction* red-black-tree-transaction) object id)
ca18172 @hargettp Transitional; now data is stored separately in storage, and partial prep...
authored
224 (setf (gethash object (object-to-id *rb-transaction*)) id)
225 (setf (gethash id (id-to-object *rb-transaction*)) object))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
226
227 (defmacro with-rb-transaction ((tree) &rest body)
228 `(let* ((existing-transaction *rb-transaction*)
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
229 (*rb-transaction* (or existing-transaction (make-instance 'red-black-tree-transaction))))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
230 (handler-bind ((error #'(lambda (e)
231 (declare (ignorable e))
232 (prb-abort *rb-transaction*))))
233 (let ((v (multiple-value-list (progn
234 (setf (tree *rb-transaction*) ,tree)
235 ,@body))))
236 (unless existing-transaction (prb-commit *rb-transaction*))
237 (values-list v)))))
238
239 (defmethod initialize-instance :before ((tree persistent-red-black-tree) &key)
240 (setf (tree *rb-transaction*) tree))
241
242 (defun make-persistent-red-black-tree (&key ((:storage storage) (make-instance 'red-black-tree-memory-storage)))
243 (with-rb-transaction ((make-instance 'persistent-red-black-tree :storage storage))))
cd16522 @hargettp Initial work on red-black trees
authored
244
245 (defmethod rb-node-class ((tree persistent-red-black-tree))
246 'persistent-red-black-node)
366c1cb @hargettp Removed unecessary change to key when updating rather than inserting
authored
247
248 (defmethod prb-open-storage ((storage red-black-tree-memory-storage))
249 )
250
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
251 (defmethod prb-location ((storage red-black-tree-memory-storage))
252 (length (objects storage)))
253
254 (defmethod assign-location ((storage red-black-tree-memory-storage) (*rb-transaction* red-black-tree-transaction) object)
255 (let ((location (or (next-location *rb-transaction*)
256 (setf (next-location *rb-transaction*) (prb-location storage)))))
257 (incf (next-location *rb-transaction*) (allocation-size storage object))
258 (setf (gethash location (location-to-object *rb-transaction*)) object)
259 (setf (gethash object (object-to-location *rb-transaction*)) location)
260 location))
261
262 (defmethod allocation-size ((storage red-black-tree-memory-storage) object)
263 (declare (ignorable storage object))
264 1)
265
266 (macrolet ((copy-node (dest-class source-node &rest slots)
267 `(let ((dest-node (make-instance ',dest-class :key (slot-value ,source-node 'key) :data (slot-value ,source-node 'data))))
268 (setf ,@(loop for slot in slots
269 append `( (slot-value dest-node ',slot)
270 (slot-value ,source-node ',slot) )))
271 dest-node)))
272
273 (defmethod prb-load ((storage red-black-tree-memory-storage) id)
274 (let ((stored-object (aref (objects storage) id)))
275 ;; (format *standard-output* "Loading from ~s object ~s~%" id stored-object)
276 (cond ((typep stored-object 'memory-red-black-node)
277 (copy-node persistent-red-black-node stored-object color parent left right))
278 (t ;; data
279 stored-object))))
280
281 (defmethod prb-save ((storage red-black-tree-memory-storage) object)
282 (with-slots (objects) storage
283 (let ((stored-object (cond ((typep object 'persistent-red-black-node)
284 (copy-node memory-red-black-node object color parent left right))
285 (t ;; data
286 object)))
287 (location (prb-location storage)))
288 (adjust-array objects (+ 1 location))
289 ;; (format *standard-output* "Saving to ~s object ~s~%" location stored-object)
290 (setf (aref objects location) stored-object)))))
291
292 (defmethod prb-get-root ((storage red-black-tree-memory-storage))
293 (root storage))
294
295 (defmethod prb-set-root ((storage red-black-tree-memory-storage) root)
296 (setf (root storage) root))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
297
298 (defmethod prb-abort ((*rb-transaction* red-black-tree-transaction))
299 (setf (new-root *rb-transaction*) nil)
d36af4b @hargettp Now storing data discretely in storage, separate from nodes themselves
authored
300 (clrhash (object-to-id *rb-transaction*))
301 (clrhash (id-to-object *rb-transaction*))
3eb82c9 @hargettp Finished basic implementation of a persistent tree, currently backed by ...
authored
302 (clrhash (changes *rb-transaction*)))
303
304 (defmethod prb-commit ((*rb-transaction* red-black-tree-transaction))
56e3899 @hargettp Persistent case is better, but still not working; core problem is that r...
authored
305 (let ((storage (storage (tree *rb-transaction*)))
306 (new-root-location nil)
307 (new-data-count 0)
308 (new-node-count 0))
309
310 ;; (format *standard-output* "Starting commit~%")
311
312 ;; Automatically add the root to the set of changes, because it must always change
313 ;; if there are any other changes
314 (when (> (hash-table-count (changes *rb-transaction*)) 0)
315 (add-changed-object *rb-transaction* (root (tree *rb-transaction*))))
316
317 ;; expand set of changed nodes to include all ancestors of any changed nodes,
318 ;; and repeat until unable to add more nodes to set
319 ;; but we only do this when storage isn't empty, to avoid issues
320 ;; during first initialization
321 (when (> (prb-location storage) 0)
322 (loop for new-changes = (make-hash-table)
323 with changes = (changes *rb-transaction*)
324 do (loop for id being the hash-keys of changes
325 for object = (object-for-id *rb-transaction* id)
326 when (typep object 'red-black-node)
327 do (let ((parent (parent object))
328 (tree (tree *rb-transaction*)))
329 (unless (eq (leaf tree) parent)
330 (let ((parent-id (id-for-object *rb-transaction* parent)))
331 (unless (gethash parent-id changes)
332 ;; (format *standard-output* "Id ~s for object ~s already in changes~%" parent-id object)
333 (setf (gethash parent-id new-changes) parent))))))
334 until (= 0 (hash-table-count new-changes))
335 do (loop for changed-id being the hash-keys of new-changes
336 for changed-object = (gethash changed-id new-changes)
337 ;; do (format *standard-output* "Adding parent id ~s to set of changes~%" changed-id)
338 do (setf (gethash changed-id changes) changed-object))))
339
340 ;; (format *standard-output* "Change count is ~s~%" (hash-table-count (changes *rb-transaction*)))
341 ;; allocate locations for data
342 (loop for id being the hash-keys of (changes *rb-transaction*)
343 for object = (object-for-id *rb-transaction* id)
344 ;; do (format *standard-output* "Reviewing for allocation ~s~%" object)
345 unless (typep object 'red-black-node)
346 do (progn
347 (assign-location storage *rb-transaction* object)
348 (incf new-data-count)))
349 ;; allocate locations for nodes
350 (loop for id being the hash-keys of (changes *rb-transaction*)
351 for object = (object-for-id *rb-transaction* id)
352 ;; do (format *standard-output* "Reviewing for allocation ~s~%" object)
353 when (typep object 'red-black-node)
354 do (progn
355 (assign-location storage *rb-transaction* object)
356 (incf new-node-count))
357 when (eq object (root (tree *rb-transaction*)))
358 do (let ((new-root (root (tree *rb-transaction*))))
359 (setf new-root-location (location-for-object *rb-transaction* new-root))
360 ;; (format *standard-output* "Found root; allocated location ~s~%" new-root-location)
361 ))
362 ;; allocate location for new root, if necessary
363 ;; (when (new-root *rb-transaction*)
364 ;; (let ((new-root (root (tree *rb-transaction*))))
365 ;; (setf new-root-location (or (location-for-object *rb-transaction* new-root)
366 ;; (assign-location storage *rb-transaction* new-root)))
367 ;; (format *standard-output* "Allocated location for root ~s at ~s~%" new-root new-root-location)))
368
369 ;; save data
370 (loop for i from 1 to new-data-count
371 for data = (object-for-location *rb-transaction* (prb-location storage))
372 unless data do (error "Current storage location does not map to data")
373 do (prb-save storage data))
374 ;; save nodes
375 (loop for i from 1 to new-node-count
376 for node = (object-for-location *rb-transaction* (prb-location storage))
377 unless node do (error "Current storage location does not map to a node")
378 ;; note that we are updating the in-memory nodes we've used
379 ;; it remains to be seen that that is the right choice
380 do (prb-save storage
381 (macrolet ((map-slot-to-location (slot)
382 `(when (and (slot-boundp node ',slot)
383 (slot-value node ',slot)
384 ;; only when the slot-value is negative, and thus an id
385 (not (= 0 (slot-value node ',slot))))
386 (let* ((mapped-id (slot-value node ',slot))
387 (mapped-object (object-for-id *rb-transaction* mapped-id))
388 (mapped-location (if (> 0 mapped-id)
389 ;; new object
390 (location-for-object *rb-transaction* mapped-object)
391 ;; old object--but did it move?
392 (or (location-for-object *rb-transaction* mapped-object) mapped-id))))
393 ;; (format *standard-output* "Mapped id ~s to location ~s for node ~s at ~s~%" mapped-id mapped-location node (prb-location storage))
394 (setf (slot-value node ',slot) mapped-location)))))
395 (map-slot-to-location parent)
396 (map-slot-to-location left)
397 (map-slot-to-location right)
398 (map-slot-to-location data)
399 node)))
400 ;; save root--if we haven't already saved it
401 (when (and new-root-location (equal new-root-location (prb-location storage)))
402 ;; (format *standard-output* "Saving root ~s~%" (root (tree *rb-transaction*)))
403 (prb-save storage (root (tree *rb-transaction*))))
404 ;; (format *standard-output* "Would set for new root ~s~%" new-root-location)
405 (when new-root-location
406 (prb-set-root storage new-root-location)
407 (setf (slot-value (tree *rb-transaction*) 'root) new-root-location))
408 ;; (format *standard-output* "Finished commit~%")
409 ))
410
411 ;; ---------------------------------------------------------------------------------------------------------------------
412 ;; printing
413
414 (defmethod print-object ((obj red-black-node) stream)
415 (with-slots (parent left right color key data) obj
416 (print-unreadable-object (obj stream :type t :identity t)
417 (with-slots (parent left right color key data) obj
418 (if (eq obj parent)
419 (format stream "T.nil")
420 (format stream "Color=~s Key=~s Data=~s ~_Parent=~<~s~> ~_Left=~<~s~> ~_Right=~<~s~>" color key data parent left right))))))
Something went wrong with that request. Please try again.