Commit 6a7debb8 authored by Stas Boukarev's avatar Stas Boukarev
Browse files

Optimize interlinking a bit.

parent 5868d371
......@@ -107,23 +107,33 @@
(defun interlink-all-objects-first-time ()
(lambda (class objects)
(declare (ignore class))
(loop for object in objects
do (interlink-objects-first-time object)))))
(let ((relations (class-relations class)))
(when relations
(loop for object in objects
do (interlink-objects-first-time object relations)))))))
(declaim (inline set-relations))
(defun set-relations (relation object target-object)
(let* ((relations (relations target-object))
(list (getf relations relation)))
(if list
(psetf (car list) object
(cdr list) (cons (car list) (cdr list)))
(setf (relations target-object)
(list* relation (list object) relations)))))
(defun link-slot-first-time (relation object target-object)
(if (and (consp relation)
(eql (car relation) :slot))
(push object (slot-value target-object (cadr relation)))
(push object (getf (relations target-object) relation))))
(set-relations relation object target-object)))
(defun interlink-slots-first-time (object slot-value relation)
(do-maybe-list (target slot-value)
(when (typep target 'identifiable)
(link-slot-first-time relation object target))))
(link-slot-first-time relation object target)))
(defun interlink-objects-first-time (object)
(loop for (loc . relation) in (class-relations (class-of object))
(defun interlink-objects-first-time (object relations)
(loop for (loc . relation) in relations
(interlink-slots-first-time object
(standard-instance-access object loc)
......@@ -143,7 +153,7 @@
(defmethod add ((object identifiable) &key)
(store-object object)
(storage:interlink-objects object)
(interlink-objects object)
(defun where (&rest clauses)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment