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