[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Mon Mar 19 19:41:36 UTC 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
More information about the Elephant-cvs
mailing list