[elephant-cvs] CVS elephant/src/elephant - elephant-cvs@common-lisp.net - mailman3.common-lisp.net

19 Mar 2007

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv8886/src/elephant
Modified Files:
    classes.lisp classindex.lisp metaclasses.lisp package.lisp 
Log Message:
Fixed lispworks MOP support; lispworks is green under Mac OS X

--- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp	2007/03/08 21:29:53	1.21
+++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp	2007/03/19 19:41:35	1.22
@@ -47,14 +47,14 @@
 ;; METACLASS INITIALIZATION AND CHANGES
 ;; ================================================
-(defmethod ensure-class-using-class :around ((class (eql nil)) name &rest args &key index)
+(defmethod ensure-class-using-class :around ((class null) name &rest args &key index)
   "Support the :index class option"
   (let ((result (apply #'call-next-method class name (remove-keywords '(:index) args))))
     (when (and index (subtypep (type-of result) 'persistent-metaclass))
       (update-indexed-record result nil :class-indexed t))
     result))
-(defmethod ensure-class-using-class :around ((class persistent-metaclass) name &rest args &key index)
+(defmethod ensure-class-using-class ((class persistent-metaclass) name &rest args &key index)
   "Support the :index class option on redefinition"
   (let ((result (apply #'call-next-method class name (remove-keywords '(:index) args))))
     (when index
@@ -222,28 +222,28 @@
     (call-next-method)))
-;;
-;; SLOT ACCESS PROTOCOLS
-;;
+;; =============================================
+;; SHARED SLOT ACCESS PROTOCOL DEFINITIONS
+;; =============================================
-(defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
+(defmethod slot-value-using-class ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
   "Get the slot value from the database."
   (let ((name (slot-definition-name slot-def)))
     (persistent-slot-reader (get-con instance) instance name)))
-(defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
+(defmethod (setf slot-value-using-class) (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
   "Set the slot value in the database."
   (if (indexed class)
       (indexed-slot-writer class instance slot-def new-value)
       (let ((name (slot-definition-name slot-def)))
    (persistent-slot-writer (get-con instance) new-value instance name))))
-(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
+(defmethod slot-boundp-using-class ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
   "Checks if the slot exists in the database."
   (let ((name (slot-definition-name slot-def)))
     (persistent-slot-boundp (get-con instance) instance name)))
-(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol))
+(defmethod slot-boundp-using-class ((class persistent-metaclass) (instance persistent-object) (slot-name symbol))
   "Checks if the slot exists in the database."
   (loop for slot in (class-slots class)
    for matches-p = (eq (slot-definition-name slot) slot-name)
@@ -253,7 +253,7 @@
    		    (persistent-slot-boundp (get-con instance) instance slot-name)
    		    (call-next-method)))))
-(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
+(defmethod slot-makunbound-using-class ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
   "Removes the slot value from the database."
   (if (indexed class)
       (indexed-slot-makunbound class instance slot-def)
@@ -268,12 +268,14 @@
 ;;
#+allegro
-(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol))
+(defmethod slot-makunbound-using-class ((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 (return (if (typep slot 'persistent-slot-definition)
-			    (slot-makunbound-using-class class instance slot)
-			    (call-next-method)))))
+     until (eq (slot-definition-name slot) slot-name)
+     finally (return (if (typep slot 'persistent-slot-definition)
+			 (if (indexed class)
+			     (indexed-slot-makunbound class instance slot)
+			     (slot-makunbound-using-class class instance slot))
+			 (call-next-method)))))
#+allegro
@@ -346,3 +348,36 @@
      (make-persistent-slot-boundp name)))
   slot-def)
+;;
+;; LISPWORKS
+;;
+
+#+lispworks
+(defmethod slot-value-using-class ((class persistent-metaclass) (instance persistent-object) slot)
+  (let ((slot-def (or (find slot (class-slots class) :key 'slot-definition-name)
+		      (find slot (class-slots class)))))
+    (if (typep slot-def 'persistent-slot-definition)
+	(persistent-slot-reader (get-con instance) instance (slot-definition-name slot-def))
+	(call-next-method class instance (slot-definition-name slot-def)))))
+
+#+lispworks
+(defmethod (setf slot-value-using-class) (new-value (class persistent-metaclass) (instance persistent-object) slot)
+  "Set the slot value in the database."
+  (let ((slot-def (or (find slot (class-slots class) :key 'slot-definition-name)
+		      (find slot (class-slots class)))))
+    (if (typep slot-def 'persistent-slot-definition)
+	(if (indexed class)
+	    (indexed-slot-writer class instance slot-def new-value)
+	    (persistent-slot-writer (get-con instance) new-value instance (slot-definition-name slot-def)))
+	(call-next-method new-value class instance (slot-definition-name slot-def)))))
+
+#+lispworks
+(defmethod slot-makunbound-using-class ((class persistent-metaclass) (instance persistent-object) slot)
+  "Removes the slot value from the database."
+  (let ((slot-def (or (find slot (class-slots class) :key 'slot-definition-name)
+		      (find slot (class-slots class)))))
+    (if (typep slot-def 'persistent-slot-definition)
+	(if (indexed class)
+	    (indexed-slot-makunbound class instance slot-def)
+	    (persistent-slot-makunbound (get-con instance) instance (slot-definition-name slot-def)))
+	(call-next-method class instance (slot-definition-name slot-def)))))
\ No newline at end of file
--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp	2007/03/18 20:40:50	1.28
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp	2007/03/19 19:41:35	1.29
@@ -205,7 +205,7 @@
    		(setf indexed-slot-names (union slots indexed-slot-names)))))))
       ;; Put class instance index into the class root & cache it in the class object
       (update-indexed-record class indexed-slot-names :class-indexed t)
-      (with-transaction (:store-controller sc)
+      (ensure-transaction (:store-controller sc)
    (when (not found)
      (let ((class-idx (build-indexed-btree sc)))
        (setf (get-value (class-name class) croot) class-idx)
--- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp	2007/03/08 21:29:53	1.10
+++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp	2007/03/19 19:41:35	1.11
@@ -24,7 +24,7 @@
(defclass persistent ()
   ((%oid :accessor oid :initarg :from-oid)
-   (dbonnection-spec-pst :type (or list string) :accessor dbcn-spc-pst :initarg :dbconnection-spec-pst))
+   (dbconnection-spec-pst :type (or list string) :accessor dbcn-spc-pst :initarg :dbconnection-spec-pst))
   (:documentation "Abstract superclass for all persistent classes (common
     to user-defined classes and collections.)"))
@@ -239,12 +239,17 @@
   '(:instance :class :database))
(defmethod slot-definition-allocation ((slot-definition persistent-slot-definition))
-  #-lispworks :database
-  #+lispworks nil)
+  :database)
+
+#+lispworks
+(defmethod (setf slot-definition-allocation) (allocation (slot-def persistent-slot-definition))
+  (unless (eq allocation :database)
+    (error "Invalid allocation type ~A for slot-definition-allocation" allocation))
+  allocation)
(defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs)
   "Checks for the transient tag (and the allocation type)
-and chooses persistent or transient slot definitions."
+   and chooses persistent or transient slot definitions."
   (let ((allocation-key (getf initargs :allocation))
    (transient-p (getf initargs :transient))
    (indexed-p (getf initargs :index)))
@@ -299,7 +304,7 @@
   (declare (ignore slot-name))
   (apply #'make-effective-slot-definition class
     (compute-effective-slot-definition-initargs 
-	  class direct-slot-definitions)))
+	 class slot-name direct-slot-definitions)))
#+openmcl
 (defmethod compute-effective-slot-definition-initargs ((class slots-class)
@@ -336,7 +341,8 @@
   (loop for slot-definition in slot-definitions
      always (transient slot-definition)))
-(defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions)
+(defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) #+lispworks slot-name slot-definitions)
+  #+lispworks (declare (ignore slot-name))
   (let ((initargs (call-next-method)))
     (if (ensure-transient-chain slot-definitions initargs)
    (setf initargs (append initargs '(:transient t)))
--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/03/11 05:45:14	1.23
+++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/03/19 19:41:35	1.24
@@ -133,12 +133,13 @@
    	standard-slot-definition
    	standard-direct-slot-definition
    	standard-effective-slot-definition
-		direct-slot-definition-class
-		effective-slot-definition-class
    	slot-definition-name
    	slot-definition-initform
    	slot-definition-initfunction
+		direct-slot-definition-class
+		effective-slot-definition-class
    	compute-effective-slot-definition
+		compute-effective-slot-definition-initargs
    	class-slots
    	slot-value-using-class
    	slot-boundp-using-class
@@ -149,9 +150,7 @@
    	finalize-inheritance
    	ensure-class-using-class
    	compute-slots
-
    	initialize-internal-slot-functions
-		compute-effective-slot-definition-initargs
    	slot-definition-reader-function
    	slot-definition-writer-function
    	slot-definition-boundp-function
@@ -276,18 +275,20 @@
   #+lispworks  
   (:import-from :clos
    	class-finalized-p
+		finalize-inheritance
    	compute-class-precedence-list
    	validate-superclass
    	ensure-class-using-class
    	standard-slot-definition
    	standard-direct-slot-definition
    	standard-effective-slot-definition
-		direct-slot-definition-class
-		effective-slot-definition-class
    	slot-definition-name
    	slot-definition-initform
    	slot-definition-initfunction
+		direct-slot-definition-class
+		effective-slot-definition-class
    	compute-effective-slot-definition
+		compute-effective-slot-definition-initargs
    	class-slots
    	slot-value-using-class
    	slot-boundp-using-class

    