Update of /project/elephant/cvsroot/elephant/src/elephant
In directory common-lisp:/tmp/cvs-serv18474/src/elephant
Modified Files:
classes.lisp metaclasses.lisp
Log Message:
Quick fix for config.lisp not having a package designator. Also my tweaks
to fix a BDB bug, adding transacctions to btree writes for increased safety
and various tweaks I made trying to fix the slot-boundp bug in indexing-redef-class
--- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/22 20:18:51 1.3
+++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/22 21:03:47 1.4
@@ -42,6 +42,10 @@
automatically inherited if you use the persistent-metaclass
metaclass."))
+;; ================================================
+;; METACLASS INITIALIZATION AND CHANGES
+;; ================================================
+
(defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses)
"Ensures we inherit from persistent-object."
(let* ((persistent-metaclass (find-class 'persistent-metaclass))
@@ -54,59 +58,8 @@
direct-superclasses) args)
(call-next-method))))
-#+allegro
-(defun make-persistent-reader (name slot-definition class class-name)
- (eval `(defmethod ,name ((instance ,class-name))
- (slot-value-using-class ,class instance ,slot-definition))))
-
-#+allegro
-(defun make-persistent-writer (name slot-definition class class-name)
- (let ((name (if (and (consp name)
- (eq (car name) 'setf))
- name
- `(setf ,name))))
- (eval `(defmethod ,name ((instance ,class-name) value)
- (setf (slot-value-using-class ,class instance ,slot-definition)
- value)))))
-
-#+allegro
-(defmethod initialize-accessors ((slot-definition persistent-slot-definition) class)
- (let ((readers (slot-definition-readers slot-definition))
- (writers (slot-definition-writers slot-definition))
- (class-name (class-name class)))
- (loop for reader in readers
- do (make-persistent-reader reader slot-definition class class-name))
- (loop for writer in writers
- do (make-persistent-writer writer slot-definition class class-name))))
-
-#+allegro
-(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys)
- (declare (ignore initargs))
- (prog1
- (call-next-method)
- (when (class-finalized-p instance)
- (update-persistent-slots instance (persistent-slot-names instance))
- (update-indexed-record instance (indexed-slot-names-from-defs instance))
- (set-db-synch instance :class)
- (loop with persistent-slots = (persistent-slots instance)
- for slot-def in (class-direct-slots instance)
- when (member (slot-definition-name slot-def) persistent-slots)
- do (initialize-accessors slot-def instance))
- (make-instances-obsolete instance))))
-
-#+(or cmu sbcl openmcl)
-(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys)
- (declare (ignore initargs))
- (prog1
- (call-next-method)
- (when (class-finalized-p instance)
- (update-persistent-slots instance (persistent-slot-names instance))
- (update-indexed-record instance (indexed-slot-names-from-defs instance))
- (set-db-synch instance :class)
- (make-instances-obsolete instance))))
-
-;; #+allegro
(defmethod finalize-inheritance :around ((instance persistent-metaclass))
+ "Update the persistent slot records in the metaclass"
(prog1
(call-next-method)
(when (not (slot-boundp instance '%persistent-slots))
@@ -115,13 +68,9 @@
(when (not (slot-boundp instance '%indexed-slots))
(update-indexed-record instance (indexed-slot-names-from-defs instance)))))
-;; #+(or cmu sbcl)
-;; (defmethod finalize-inheritance :around ((instance persistent-metaclass))
-;; (prog1
-;; (call-next-method)
-;; (if (not (slot-boundp instance '%persistent-slots))
-;; (setf (%persistent-slots instance)
-;; (cons (persistent-slot-names instance) nil)))))
+;; ================================================
+;; PERSISTENT OBJECT MAINTENANCE
+;; ================================================
(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key from-oid &allow-other-keys)
"Initializes the persistent slots via initargs or forms.
@@ -151,9 +100,10 @@
with slot-initargs = (slot-definition-initargs slot-def)
when (member initarg slot-initargs :test #'eq)
do
- (setf (slot-value-using-class class instance slot-def)
- (getf initargs initarg))
- (return t))))
+ (setf (slot-value-using-class class instance slot-def)
+ (getf initargs initarg))
+ (return t))))
+ (with-transaction (:store-controller (get-con instance))
(loop for slot-def in (class-slots class)
unless (initialize-from-initarg slot-def)
when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq)
@@ -162,7 +112,7 @@
(let ((initfun (slot-definition-initfunction slot-def)))
(when initfun
(setf (slot-value-using-class class instance slot-def)
- (funcall initfun)))))
+ (funcall initfun))))))
;; (format t "transient-slot-inits ~A~%" transient-slot-inits)
;; (format t "indices boundp ~A~%" (slot-boundp instance 'indices))
;; (format t "indices-caches boundp ~A~%" (slot-boundp instance 'indices-cache))
@@ -177,12 +127,12 @@
(when (and (indexed class) (not from-oid))
(let ((class-index (find-class-index class)))
(when class-index
- (with-transaction (:store-controller (get-con class-index))
- (setf (get-value oid class-index) instance)))))
+ (setf (get-value oid class-index) instance))))
))))
-(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys)
+(defmethod update-instance-for-redefined-class ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys)
;; NOTE: probably should delete discarded slots, but we'll worry about that later
+ ;; (also will want to delete discarded indices since we don't have a good GC)
(declare (ignore property-list discarded-slots added-slots))
(prog1
(call-next-method)
@@ -210,14 +160,15 @@
;; Apply default values for unbound & new slots (updates class index)
(apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs)
;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index)
- (loop for slot-def in (class-slots new-class)
- when (member (slot-definition-name slot-def) retained-persistent-slots)
- do (setf (slot-value-using-class new-class
- current
- slot-def)
- (slot-value-using-class old-class
- previous
- (find-slot-def-by-name old-class (slot-definition-name slot-def)))))
+ (with-transaction (:store-controller (get-con current))
+ (loop for slot-def in (class-slots new-class)
+ when (member (slot-definition-name slot-def) retained-persistent-slots)
+ do (setf (slot-value-using-class new-class
+ current
+ slot-def)
+ (slot-value-using-class old-class
+ previous
+ (find-slot-def-by-name old-class (slot-definition-name slot-def))))))
;; Delete this instance from its old class index, if exists
(when (indexed old-class)
(remove-kv (oid previous) (find-class-index old-class)))
@@ -229,14 +180,6 @@
(let ((name (slot-definition-name slot-def)))
(persistent-slot-reader (get-con instance) instance name)))
-;; ORIGINAL METHOD
-;; (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
-;; "Set the slot value in the database."
-;; (declare (optimize (speed 3)))
-;; (let ((name (slot-definition-name slot-def)))
-;; (persistent-slot-writer new-value instance name)))
-
-;; SUPPORT FOR INVERTED INDEXES
(defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
"Set the slot value in the database."
(declare (optimize (speed 3)))
@@ -270,7 +213,15 @@
(unregister-indexed-slot class (slot-definition-name slot-def)))
(persistent-slot-makunbound (get-con instance) instance (slot-definition-name slot-def)))
-;; NOTE: Closer to MOP will fix this
+;; ======================================================
+;; Handling metaclass overrides of normal slot operation
+;; NOTE: Closer to MOP should replace this need...
+;; ======================================================
+
+;;
+;; ALLEGRO
+;;
+
#+allegro
(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol))
(loop for slot in (class-slots class)
@@ -278,3 +229,93 @@
finally (return (if (typep slot 'persistent-slot-definition)
(slot-makunbound-using-class class instance slot)
(call-next-method)))))
+
+
+#+allegro
+(defun make-persistent-reader (name slot-definition class class-name)
+ (eval `(defmethod ,name ((instance ,class-name))
+ (slot-value-using-class ,class instance ,slot-definition))))
+
+#+allegro
+(defun make-persistent-writer (name slot-definition class class-name)
+ (let ((name (if (and (consp name)
+ (eq (car name) 'setf))
+ name
+ `(setf ,name))))
+ (eval `(defmethod ,name ((instance ,class-name) value)
+ (setf (slot-value-using-class ,class instance ,slot-definition)
+ value)))))
+
+#+allegro
+(defmethod initialize-accessors ((slot-definition persistent-slot-definition) class)
+ (let ((readers (slot-definition-readers slot-definition))
+ (writers (slot-definition-writers slot-definition))
+ (class-name (class-name class)))
+ (loop for reader in readers
+ do (make-persistent-reader reader slot-definition class class-name))
+ (loop for writer in writers
+ do (make-persistent-writer writer slot-definition class class-name))))
+
+#+allegro
+(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys)
+ (declare (ignore initargs))
+ (prog1
+ (call-next-method)
+ (when (class-finalized-p instance)
+ (update-persistent-slots instance (persistent-slot-names instance))
+ (update-indexed-record instance (indexed-slot-names-from-defs instance))
+ (set-db-synch instance :class)
+ (loop with persistent-slots = (persistent-slots instance)
+ for slot-def in (class-direct-slots instance)
+ when (member (slot-definition-name slot-def) persistent-slots)
+ do (initialize-accessors slot-def instance))
+ (make-instances-obsolete instance))))
+
+;;
+;; CMU / SBCL
+;;
+
+#+(or cmu sbcl)
+(defun make-persistent-reader (name)
+ (lambda (instance)
+ (declare (optimize (speed 3))
+ (type persistent-object instance))
+ (persistent-slot-reader (get-con instance) instance name)))
+
+#+(or cmu sbcl)
+(defun make-persistent-writer (name)
+ (lambda (new-value instance)
+ (declare (optimize (speed 3))
+ (type persistent-object instance))
+ (persistent-slot-writer (get-con instance) new-value instance name)))
+
+#+(or cmu sbcl)
+(defun make-persistent-slot-boundp (name)
+ (lambda (instance)
+ (declare (optimize (speed 3))
+ (type persistent-object instance))
+ (persistent-slot-boundp (get-con instance) instance name)))
+
+#+(or cmu sbcl)
+(defmethod initialize-internal-slot-functions ((slot-def persistent-slot-definition))
+ (let ((name (slot-definition-name slot-def)))
+ (setf (slot-definition-reader-function slot-def)
+ (make-persistent-reader name))
+ (setf (slot-definition-writer-function slot-def)
+ (make-persistent-writer name))
+ (setf (slot-definition-boundp-function slot-def)
+ (make-persistent-slot-boundp name)))
+ slot-def)
+
+#+(or cmu sbcl openmcl)
+(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys)
+ (declare (ignore initargs))
+ (prog1
+ (call-next-method)
+ (when (class-finalized-p instance)
+ (update-persistent-slots instance (persistent-slot-names instance))
+ (update-indexed-record instance (indexed-slot-names-from-defs instance))
+ (set-db-synch instance :class)
+;; (initialize-internal-slot-functions
+ (make-instances-obsolete instance))))
+
--- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/21 19:40:03 1.3
+++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/22 21:03:47 1.4
@@ -326,37 +326,6 @@
when (eq (slot-definition-name slot-def) slot-name)
do (return slot-def)))
-#+(or cmu sbcl)
-(defun make-persistent-reader (name)
- (lambda (instance)
- (declare (optimize (speed 3))
- (type persistent-object instance))
- (persistent-slot-reader (get-con instance) instance name)))
-
-#+(or cmu sbcl)
-(defun make-persistent-writer (name)
- (lambda (new-value instance)
- (declare (optimize (speed 3))
- (type persistent-object instance))
- (persistent-slot-writer (get-con instance) new-value instance name)))
-
-#+(or cmu sbcl)
-(defun make-persistent-slot-boundp (name)
- (lambda (instance)
- (declare (optimize (speed 3))
- (type persistent-object instance))
- (persistent-slot-boundp (get-con instance) instance name)))
-
-#+(or cmu sbcl)
-(defmethod initialize-internal-slot-functions ((slot-def persistent-slot-definition))
- (let ((name (slot-definition-name slot-def)))
- (setf (slot-definition-reader-function slot-def)
- (make-persistent-reader name))
- (setf (slot-definition-writer-function slot-def)
- (make-persistent-writer name))
- (setf (slot-definition-boundp-function slot-def)
- (make-persistent-slot-boundp name)))
- slot-def)
(defun persistent-slot-defs (class)
(let ((slot-definitions (class-slots class)))
@@ -374,4 +343,7 @@
(mapcar #'slot-definition-name (persistent-slot-defs class)))
(defun transient-slot-names (class)
- (mapcar #'slot-definition-name (transient-slot-defs class)))
\ No newline at end of file
+ (mapcar #'slot-definition-name (transient-slot-defs class)))
+
+
+
