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

[blee at common-lisp.net]

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

Modified Files:
	metaclasses.lisp 
Log Message:
merged in andrew's fixes: class slots, inheritence.
added slot-boundp, slot-makunbound.

Date: Mon Aug 30 23:15:13 2004
Author: blee

Index: elephant/src/metaclasses.lisp
diff -u elephant/src/metaclasses.lisp:1.2 elephant/src/metaclasses.lisp:1.3
--- elephant/src/metaclasses.lisp:1.2	Sun Aug 29 22:40:06 2004
+++ elephant/src/metaclasses.lisp	Mon Aug 30 23:15:12 2004
@@ -80,14 +80,14 @@
 (defmethod slot-definition-allocation ((slot-definition persistent-slot-definition))
   :class)
 
-#+(or cmu sbcl)
-(defmethod initialize-internal-slot-functions ((slot persistent-slot-definition))
-  (handle-optimized-accessors slot))
-
 (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs)
   (let ((allocation-key (getf initargs :allocation))
 	(transient-p (getf initargs :transient)))
-    (cond ((or (eq allocation-key :class) transient-p)
+    (cond ((and (eq allocation-key :class) transient-p)
+	   (find-class 'transient-direct-slot-definition))
+	  ((and (eq allocation-key :class) (not transient-p))
+	   (error "Persistent class slots are not supported, try :transient t."))
+	  (transient-p
 	   (find-class 'transient-direct-slot-definition))
 	  (t
 	   (find-class 'persistent-direct-slot-definition)))))
@@ -95,6 +95,9 @@
 (defmethod validate-superclass ((class persistent-metaclass) (super standard-class))
   t)
 
+(defmethod validate-superclass ((class standard-class) (super persistent-metaclass))
+  nil)
+
 (defgeneric persistent-p (class))
 
 (defmethod persistent-p ((class t))
@@ -103,6 +106,9 @@
 (defmethod persistent-p ((class persistent-metaclass))
   t)
 
+(defmethod persistent-p ((class persistent-slot-definition))
+  t)
+
 (defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs)
   (let ((transient-p (getf initargs :transient)))
     (cond (transient-p
@@ -110,6 +116,29 @@
 	  (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))
+
 (defun ensure-transient-chain (slot-definitions initargs)
   (declare (ignore initargs))
   (loop for slot-definition in slot-definitions
@@ -123,8 +152,6 @@
 	  (setf (getf initargs :allocation) :class)
 	  initargs))))
 
-(defparameter *buffer* (make-array 1000))
-
 (defmacro persistent-slot-reader (instance name)
   `(progn
     (buffer-write-int (oid ,instance) *key-buf*)
@@ -139,10 +166,11 @@
 	  #-cmu
 	  (error 'unbound-slot :instance ,instance :name ,name)))))
 
+#+(or cmu sbcl)
 (defun make-persistent-reader (name)
   (lambda (instance)
     (declare (optimize (speed 3))
-	     (type persistent instance))
+	     (type persistent-object instance))
     (persistent-slot-reader instance name)))
 
 (defmacro persistent-slot-writer (new-value instance name)
@@ -157,23 +185,39 @@
 		       :auto-commit *auto-commit*)
       ,new-value)))
 
+#+(or cmu sbcl)
 (defun make-persistent-writer (name)
   (lambda (new-value instance)
     (declare (optimize (speed 3))
-	     (type persistent instance))
+	     (type persistent-object instance))
     (persistent-slot-writer new-value instance name)))
 
-(defgeneric handle-optimized-accessors (slot-def))
+(defmacro persistent-slot-boundp (instance name)
+  `(progn
+    (buffer-write-int (oid ,instance) *key-buf*)
+    (let* ((key-length (serialize ,name *key-buf*))
+	   (buf (db-get-key-buffered 
+		 (controller-db *store-controller*) 
+		 (buffer-stream-buffer *key-buf*)
+		 key-length)))
+      (if buf T nil))))
 
-(defmethod handle-optimized-accessors ((slot-def t))
-  slot-def)
+#+(or cmu sbcl)
+(defun make-persistent-slot-boundp (name)
+  (lambda (instance)
+    (declare (optimize (speed 3))
+	     (type persistent-object instance))
+    (persistent-slot-boundp instance name)))
 
-(defmethod handle-optimized-accessors ((slot-def persistent-slot-definition))
+#+(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)))
+	  (make-persistent-writer name))
+    (setf (slot-definition-boundp-function slot-def)
+	  (make-persistent-slot-boundp name)))
   slot-def)
 
 (defun persistent-slot-names (class)
@@ -181,3 +225,9 @@
     (loop for slot-definition in slot-definitions
 	  when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition))
 	  collect (slot-definition-name slot-definition))))
+
+(defun transient-slot-names (class)
+  (let ((slot-definitions (class-slots class)))
+    (loop for slot-definition in slot-definitions
+	  unless (persistent-p slot-definition)
+	  collect (slot-definition-name slot-definition))))
\ No newline at end of file