Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv30377/src

Modified Files: classes.lisp Log Message: andrew's new stuff, work for sbcl

Date: Sun Aug 29 09:46:34 2004 Author: blee

Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.3 elephant/src/classes.lisp:1.4 --- elephant/src/classes.lisp:1.3 Fri Aug 27 19:31:30 2004 +++ elephant/src/classes.lisp Sun Aug 29 09:46:34 2004 @@ -40,13 +40,6 @@

(in-package "ELEPHANT")

-(defclass persistent () - ((%oid :accessor oid - :initarg :from-oid)) - (:documentation - "Abstract superclass for all persistent classes (common -to user-defined classes and collections.)")) - (defmethod initialize-instance :before ((instance persistent) &rest initargs &key from-oid) @@ -54,114 +47,13 @@ "Sets the OID." (if (not from-oid) (setf (oid instance) (next-oid *store-controller*)) - (setf (oid instance) from-oid)) - (cache-instance *store-controller* instance)) + (setf (oid instance) from-oid)))

(defclass persistent-object (persistent) - ((%persistent-slots)) + ((%persistent-slots :transient t)) (:documentation "Superclass of all user-defined persistent -classes")) - -(defclass persistent-metaclass (pcl::standard-class) - ()) - -(defclass persistent-slot-definition (pcl::standard-slot-definition) - ()) - -(defclass persistent-direct-slot-definition (pcl::standard-direct-slot-definition persistent-slot-definition) - ()) - -(defclass persistent-effective-slot-definition (pcl::standard-effective-slot-definition persistent-slot-definition) - ()) - -(defmethod pcl::slot-definition-allocation ((slot-definition persistent-slot-definition)) - :instance) - -(defmethod (setf pcl::slot-definition-allocation) (value (slot-definition persistent-slot-definition)) - (declare (ignore value)) - (error "Cannot change the allocation of a persistent slot")) - -(defmethod pcl::initialize-internal-slot-functions ((slot persistent-slot-definition)) - nil) - -(defmethod pcl::direct-slot-definition-class ((class persistent-metaclass) &rest initargs) - (let ((allocation-key (getf initargs :allocation))) - (cond ((eq allocation-key :class) - (call-next-method)) - (t - (find-class 'persistent-direct-slot-definition))))) - -(defmethod pcl:validate-superclass ((class elephant::persistent-metaclass) (super pcl::standard-class)) - t) - -(defmethod persistent-p ((class t)) - nil) - -(defmethod persistent-p ((class persistent-metaclass)) - t) - -(defmethod pcl::effective-slot-definition-class ((class persistent-metaclass) &rest initargs) - (let ((allocation-key (getf initargs :allocation)) - (allocation-class (getf initargs :allocation-class))) - (cond ((eq allocation-key :class) - (call-next-method)) - ((not (persistent-p allocation-class)) - (call-next-method)) - (t - (find-class 'persistent-effective-slot-definition))))) - -(defmacro make-persistent-reader (name) - `(lambda (instance) - (declare (type persistent instance)) - (buffer-write-int (oid instance) *key-buf*) - (let ((key-length (serialize ,name *key-buf*))) - (handler-case - (deserialize (db-get-key-buffered - (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) - key-length)) - (db-error (err) - (if (= (db-error-errno err) DB_NOTFOUND) - (error 'unbound-slot :instance instance :slot ,name) - (error err))))))) - -(defmacro make-persistent-writer (name) - `(lambda (new-value instance) - (declare (type persistent instance)) - (buffer-write-int (oid instance) *key-buf*) - (let ((key-length (serialize ,name *key-buf*)) - (val-length (serialize new-value *out-buf*))) - (db-put-buffered (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) key-length - (buffer-stream-buffer *out-buf*) val-length - :transaction *current-transaction* - :auto-commit *auto-commit*)))) - -#| -(defmethod pcl::compute-slots :around ((class persistent-metaclass)) - (call-next-method)) -|# - -(defmethod handle-optimized-accessors ((slot-def t)) - slot-def) - -(defmethod handle-optimized-accessors ((slot-def persistent-slot-definition)) - (let ((name (pcl::slot-definition-name slot-def))) - (setf (pcl::slot-definition-reader-function slot-def) - (make-persistent-reader name)) - (setf (pcl::slot-definition-writer-function slot-def) - (make-persistent-writer name))) - slot-def) - -(defmethod pcl::compute-effective-slot-definition ((class persistent-metaclass) name direct-slot-definitions) - (let ((object (call-next-method))) - (handle-optimized-accessors object))) - -(defun persistent-slot-names (class) - (let ((slot-definitions (pcl::class-slots class))) - (loop for slot-definition in slot-definitions - when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition)) - collect (pcl::slot-definition-name slot-definition)))) +classes") + (:metaclass persistent-metaclass))

(defmethod initialize-instance :around ((class persistent-metaclass) &rest args &key direct-superclasses) (let* ((persistent-metaclass (find-class 'persistent-metaclass)) @@ -171,12 +63,13 @@ (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-object) direct-superclasses) args) (call-next-method))))

-(defmethod pcl::slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) - (let ((slot-name (pcl::slot-definition-name slot-def))) - (format *standard-output* "Deserializing ~A ~%" slot-name))) - -(defmethod (setf pcl::slot-value-using-class) :around (new-value class (instance persistent-object) (slot-def persistent-slot-definition)) - (let ((slot-name (pcl::slot-definition-name slot-def))) - (format *standard-output* "Serializing ~A into ~A ~%" new-value slot-name))) - +(defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) + (declare (ignore class)) + (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)) + (declare (ignore class)) + (let ((name (slot-definition-name slot-def))) + (persistent-slot-writer new-value instance name)))