[elephant-cvs] CVS update: elephant/src/classes.lisp

[blee at common-lisp.net]

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)))