[elephant-cvs] CVS update: elephant/src/metaclasses.lisp elephant/src/elephant.lisp elephant/src/classes.lisp
blee at common-lisp.net
blee at common-lisp.net
Thu Feb 24 01:07:55 UTC 2005
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv4404/src
Modified Files:
metaclasses.lisp elephant.lisp classes.lisp
Log Message:
mop updates : update-class, change-class, new slot
allocation type...
Date: Thu Feb 24 02:07:53 2005
Author: blee
Index: elephant/src/metaclasses.lisp
diff -u elephant/src/metaclasses.lisp:1.6 elephant/src/metaclasses.lisp:1.7
--- elephant/src/metaclasses.lisp:1.6 Sun Sep 19 19:50:38 2004
+++ elephant/src/metaclasses.lisp Thu Feb 24 02:07:52 2005
@@ -49,12 +49,24 @@
to user-defined classes and collections.)"))
(defclass persistent-metaclass (standard-class)
- ()
+ ((%persistent-slots :accessor %persistent-slots))
(:documentation
"Metaclass for persistent classes. Use this metaclass to
define persistent classes. All slots are persistent by
default; use the :transient flag otherwise."))
+(defmethod persistent-slots ((class persistent-metaclass))
+ (car (%persistent-slots class)))
+
+(defmethod persistent-slots ((class standard-class))
+ nil)
+
+(defmethod old-persistent-slots ((class persistent-metaclass))
+ (cdr (%persistent-slots class)))
+
+(defmethod update-persistent-slots ((class persistent-metaclass) new-slot-list)
+ (setf (%persistent-slots class) (cons new-slot-list (car (%persistent-slots class)))))
+
(defclass persistent-slot-definition (standard-slot-definition)
())
@@ -81,8 +93,12 @@
(defmethod transient ((slot persistent-direct-slot-definition))
nil)
+#+allegro
+(defmethod excl::valid-slot-allocation-list ((class persistent-metaclass))
+ '(:instance :class :database))
+
(defmethod slot-definition-allocation ((slot-definition persistent-slot-definition))
- :class)
+ :database)
(defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs)
"Checks for the transient tag (and the allocation type)
@@ -128,29 +144,6 @@
(t
(find-class 'persistent-effective-slot-definition)))))
-#+(or cmu sbcl)
-(defgeneric ensure-storage-exists (class slot-definition slot-name))
-
-#+(or cmu sbcl)
-(defmethod ensure-storage-exists (class slot-definition slot-name)
- nil)
-
-#+(or cmu sbcl)
-(defmethod ensure-storage-exists (class (slot-definition persistent-slot-definition) slot-name)
- (let ((use-class (or (slot-definition-allocation-class slot-definition)
- class)))
- (when (not (assoc slot-name (class-slot-cells use-class)))
- (setf (plist-value use-class 'class-slot-cells)
- (append
- (plist-value use-class 'class-slot-cells)
- (list (cons slot-name +slot-unbound+)))))))
-
-#+(or cmu sbcl)
-(defmethod compute-effective-slot-definition :around ((class persistent-metaclass) slot-name direct-slot-definitions)
- (let ((slot-definition (call-next-method)))
- (ensure-storage-exists class slot-definition slot-name)
- slot-definition))
-
#+openmcl
(defmethod compute-effective-slot-definition ((class persistent-metaclass) slot-name direct-slot-definitions)
(declare (ignore slot-name))
@@ -198,7 +191,7 @@
(if (ensure-transient-chain slot-definitions initargs)
(append initargs '(:transient t))
(progn
- (setf (getf initargs :allocation) :class)
+ (setf (getf initargs :allocation) :database)
initargs))))
(defmacro persistent-slot-reader (instance name)
Index: elephant/src/elephant.lisp
diff -u elephant/src/elephant.lisp:1.13 elephant/src/elephant.lisp:1.14
--- elephant/src/elephant.lisp:1.13 Tue Sep 21 03:35:11 2004
+++ elephant/src/elephant.lisp Thu Feb 24 02:07:52 2005
@@ -104,6 +104,8 @@
slot-makunbound-using-class
slot-definition-allocation
slot-definition-initargs
+ class-finalized-p
+ finalize-inheritance
compute-slots
initialize-internal-slot-functions
@@ -142,6 +144,8 @@
slot-makunbound-using-class
slot-definition-allocation
slot-definition-initargs
+ class-finalized-p
+ finalize-inheritance
compute-slots)
#+sbcl
(:import-from :sb-pcl
@@ -181,6 +185,8 @@
slot-makunbound-using-class
slot-definition-allocation
slot-definition-initargs
+ class-finalized-p
+ finalize-inheritance
compute-slots)
#+allegro
(:import-from :excl
Index: elephant/src/classes.lisp
diff -u elephant/src/classes.lisp:1.12 elephant/src/classes.lisp:1.13
--- elephant/src/classes.lisp:1.12 Tue Sep 21 21:35:29 2004
+++ elephant/src/classes.lisp Thu Feb 24 02:07:52 2005
@@ -54,9 +54,9 @@
(cache-instance *store-controller* instance))
(defclass persistent-object (persistent)
- ((%persistent-slots :transient t))
+ ()
(:documentation
-"Superclass of all user-defined persistent classes. This is
+ "Superclass of all user-defined persistent classes. This is
automatically inherited if you use the persistent-metaclass
metaclass.")
(:metaclass persistent-metaclass))
@@ -73,6 +73,63 @@
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)
+ (eval `(defmethod (setf ,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)
+ (prog1
+ (call-next-method)
+ (when (class-finalized-p instance)
+ (update-persistent-slots instance (persistent-slot-names instance))
+ (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)
+(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys)
+ (prog1
+ (call-next-method)
+ (when (class-finalized-p instance)
+ (update-persistent-slots instance (persistent-slot-names instance))
+ (make-instances-obsolete instance))))
+
+#+allegro
+(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)))))
+
+#+(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)))))
+
(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys)
"Initializes the persistent slots via initargs or forms.
This seems to be necessary because it is typical for
@@ -111,45 +168,76 @@
;; let the implementation initialize the transient slots
(apply #'call-next-method instance transient-slot-inits initargs)))))
+(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys)
+ ;; probably should delete discarded slots, but we'll worry about that later
+ (prog1
+ (call-next-method)
+ (let* ((class (class-of instance))
+ (new-persistent-slots (set-difference (persistent-slots class)
+ (old-persistent-slots class))))
+
+ (apply #'shared-initialize instance new-persistent-slots initargs))))
+
+(defun find-slot-def-by-name (class slot-name)
+ (loop for slot-def in (class-slots class)
+ when (eq (slot-definition-name slot-def) slot-name)
+ do (return slot-def)))
+
(defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key)
- "Need to also update the persistent-slots, which have
-:class allocation."
- (let ((new-persistent-slots
- (loop for slotd in (class-slots (class-of current))
- for slot-name = (slot-definition-name slotd)
- with old-slot-names = (mapcar #'slot-definition-name
- (class-slots (class-of previous)))
- when (and (not (member slot-name old-slot-names :test #'eq))
- (persistent-p slotd))
- collect slot-name)))
- (apply #'shared-initialize current new-persistent-slots initargs)
+ (let* ((old-class (class-of previous))
+ (new-class (class-of current))
+ (new-persistent-slots (set-difference
+ (persistent-slots new-class)
+ (persistent-slots old-class)))
+ (raw-retained-persistent-slots (intersection (persistent-slots new-class)
+ (persistent-slots old-class)))
+ (retained-unbound-slots (loop for slot-name in raw-retained-persistent-slots
+ when (not (persistent-slot-boundp previous slot-name))
+ collect slot-name))
+ (retained-persistent-slots (set-difference raw-retained-persistent-slots retained-unbound-slots)))
+ (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs)
+ (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)))))
(call-next-method)))
-(defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition))
+(defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
"Get the slot value from the database."
- (declare (optimize (speed 3))
- (ignore class))
+ (declare (optimize (speed 3)))
(let ((name (slot-definition-name slot-def)))
(persistent-slot-reader instance name)))
-(defmethod (setf slot-value-using-class) :around (new-value class (instance persistent-object) (slot-def persistent-slot-definition))
+(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))
- (ignore class))
+ (declare (optimize (speed 3)))
(let ((name (slot-definition-name slot-def)))
(persistent-slot-writer new-value instance name)))
-(defmethod slot-boundp-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition))
+(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
"Checks if the slot exists in the database."
- (declare (optimize (speed 3))
- (ignore class))
+ (declare (optimize (speed 3)))
(let ((name (slot-definition-name slot-def)))
(persistent-slot-boundp instance name)))
-(defmethod slot-makunbound-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition))
+(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol))
+ "Checks if the slot exists in the database."
+ (declare (optimize (speed 3)))
+ (loop for slot in (class-slots class)
+ for matches-p = (eq (slot-definition-name slot) slot-name)
+ until matches-p
+ finally (if (and matches-p
+ (typep slot 'persistent-slot-definition))
+ (persistent-slot-boundp instance slot-name)
+ (call-next-method))))
+
+(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
"Deletes the slot from the database."
- (declare (optimize (speed 3))
- (ignore class))
+ (declare (optimize (speed 3)))
(with-buffer-streams (key-buf)
(buffer-write-int (oid instance) key-buf)
(serialize (slot-definition-name slot-def) key-buf)
@@ -158,4 +246,11 @@
:transaction *current-transaction*
:auto-commit *auto-commit*))
instance)
-
\ No newline at end of file
+
+#+allegro
+(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol))
+ (loop for slot in (class-slots class)
+ until (eq (slot-definition-name slot) slot-name)
+ finally (if (typep slot 'persistent-slot-definition)
+ (slot-makunbound-using-class class instance slot)
+ (call-next-method))))
\ No newline at end of file
More information about the Elephant-cvs
mailing list