Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Reorder slots so that non-storable are at the front, ID is first

and RELATIONS second.
  • Loading branch information...
commit f39276e0fd4172e19c57a9298ff4c072166248ab 1 parent 426ac36
@stassats authored
View
43 mop.lisp
@@ -31,8 +31,6 @@
:accessor number-of-bytes-for-slots)
(relations :initform nil
:accessor class-relations)
- (relations-location :initform nil
- :accessor relations-location)
(initforms :initform nil
:accessor class-initforms)
(objects :initform nil
@@ -126,6 +124,22 @@
direct-definitions))
effective-definition))
+(defmethod compute-slots ((class storable-class))
+ (let* ((slots (call-next-method))
+ (other-slots (remove-if (lambda (x)
+ (or (eq x 'id)
+ (eq x 'relations)))
+ slots
+ :key #'slot-definition-name)))
+ (list* (or (find 'id slots :key #'slot-definition-name)
+ (error "No ~s slot in ~s" 'id class))
+ (or (find 'relations slots :key #'slot-definition-name)
+ (error "No ~s slot in ~s" 'relations class))
+ (stable-sort (copy-list other-slots)
+ (lambda (x y)
+ (and y (not x)))
+ :key #'store-slot-p))))
+
(defun slots-with-relations (class)
(loop for slot across (slots-to-store class)
for relation = (slot-relation slot)
@@ -140,6 +154,21 @@
(slot-definition-initform slot-definition)))
slot-definitions))
+(defconstant +id-location+ 0)
+(defconstant +relations-location+ 1)
+
+(declaim (inline fast-id))
+(defun fast-id (object)
+ (standard-instance-access object +id-location+))
+
+(declaim (inline fast-relations (setf fast-relations)))
+(defun fast-relations (object)
+ (standard-instance-access object +relations-location+))
+
+(defun (setf fast-relations) (value object)
+ (setf (standard-instance-access object +relations-location+)
+ value))
+
(defun initialize-class-slots (class slots)
(let* ((slots-to-store (coerce (remove-if-not #'store-slot-p slots)
'simple-vector)))
@@ -159,15 +188,15 @@
(map 'vector #'slot-definition-initform slots))
(setf (class-relations class)
(slots-with-relations class))
- (setf (relations-location class)
- (slot-definition-location
- (find-slot-or-error 'relations class)))
- #+(or sbcl ecl ccl)
+ (compute-search-key class)
(assert
(= (slot-definition-location
(find-slot-or-error 'id class))
+id-location+))
- (compute-search-key class)))
+ (assert
+ (= (slot-definition-location
+ (find-slot-or-error 'relations class))
+ +relations-location+))))
(defmethod finalize-inheritance :after ((class storable-class))
(initialize-class-slots class (class-slots class)))
View
2  storage.asd
@@ -4,7 +4,7 @@
:name "storage"
:serial t
:depends-on (alexandria
- closer-mop
+ #-abcl closer-mop
#-sbcl
ieee-floats)
:components ((:file "packages")
View
33 storage.lisp
@@ -125,10 +125,8 @@
(lambda (class objects)
(let ((relations (class-relations class)))
(when relations
- (loop with relations-slot-loc = (relations-location class)
- for object in objects
- do (interlink-objects-first-time object relations
- relations-slot-loc)))))))
+ (loop for object in objects
+ do (interlink-objects-first-time object relations)))))))
(declaim (inline prepend))
(defun prepend (item list)
@@ -141,10 +139,8 @@
when (eq key indicator) return value))
(declaim (inline set-relations))
-(defun set-relations (relation object target-object
- relations-slot-loc)
- (let* ((relations (standard-instance-access target-object
- relations-slot-loc))
+(defun set-relations (relation object target-object)
+ (let* ((relations (fast-relations target-object))
(list (fgetf relations relation)))
(cond (list
(prepend object list))
@@ -152,32 +148,25 @@
(prepend (list object) relations)
(prepend relation relations))
(t
- (setf (standard-instance-access target-object
- relations-slot-loc)
+ (setf (fast-relations target-object)
(list* relation (list object) relations))))))
-(defun link-slot-first-time (relation object target-object
- relations-slot-loc)
+(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)))
- (set-relations relation object target-object
- relations-slot-loc)))
+ (set-relations relation object target-object)))
-(defun interlink-slots-first-time (object slot-value relation
- relations-slot-loc)
+(defun interlink-slots-first-time (object slot-value relation)
(do-maybe-list (target slot-value)
- (link-slot-first-time relation object target
- relations-slot-loc)))
+ (link-slot-first-time relation object target)))
-(defun interlink-objects-first-time (object relations
- relations-slot-loc)
+(defun interlink-objects-first-time (object relations)
(loop for (loc . relation) in relations
do
(interlink-slots-first-time object
(standard-instance-access object loc)
- relation
- relations-slot-loc)))
+ relation)))
;;; Data manipulations
View
12 util-generic.lisp
@@ -19,15 +19,3 @@
do (initialize-slots instance slot-cache)
(setf (aref array index) instance)
(incf index)))))
-
-(defconstant +id-location+ 0)
-
-(declaim (inline fast-id))
-
-#+(or ccl ecl)
-(defun fast-id (object)
- (standard-instance-access object +id-location+))
-
-#-(or ccl ecl)
-(defun fast-id (object)
- (id object))
View
6 util-sbcl.lisp
@@ -24,9 +24,3 @@
do
(setf (aref array index) instance)
(incf index)))))
-
-(defconstant +id-location+ 0)
-
-(declaim (inline fast-id))
-(defun fast-id (object)
- (standard-instance-access object +id-location+))
Please sign in to comment.
Something went wrong with that request. Please try again.