[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Thu Aug 31 20:09:18 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv1363
Modified Files:
do.txt done.txt mop.lisp rucksack.lisp test-index-1a.lisp
Log Message:
Get rid of the Lispworks specific PROCESS-A-CLASS-OPTION stuff and handle
the :INDEX class option in a way that's compatible with the AMOP.
--- /project/rucksack/cvsroot/rucksack/do.txt 2006/08/31 15:53:57 1.1
+++ /project/rucksack/cvsroot/rucksack/do.txt 2006/08/31 20:09:17 1.2
@@ -2,7 +2,7 @@
- Handle initargs in LOAD-OBJECT and UPDATE-PERSISTENT-...
-- Initialize transient slots during LOAD-OBJECT.
+- Initialize non-persistent slots during LOAD-OBJECT.
- Figure out if there's a better way than
(eval-when (:compile-toplevel :load-toplevel :execute) ...)
@@ -25,9 +25,6 @@
of transient slots will be gone.
3. Forbid it and signal some kind of error.
-- Get rid of the PROCESS-A-CLASS-OPTION stuff and handle the :INDEX class
- option in a way that's compatible with AMOP.
-
- I'm not sure that :INCLUDE-SUBCLASSES NIL makes sense for
RUCKSACK-MAP-SLOT. Think about this.
--- /project/rucksack/cvsroot/rucksack/done.txt 2006/08/31 15:53:57 1.1
+++ /project/rucksack/cvsroot/rucksack/done.txt 2006/08/31 20:09:17 1.2
@@ -1,5 +1,8 @@
* 2006-08-31
+- Get rid of the Lispworks-specific PROCESS-A-CLASS-OPTION stuff and handle
+ the :INDEX class option in a way that's compatible with AMOP.
+
- Write test cases for schema updates and user defined methods for
UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS.
--- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/30 14:05:40 1.8
+++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/31 20:09:17 1.9
@@ -1,4 +1,4 @@
-;; $Id: mop.lisp,v 1.8 2006/08/30 14:05:40 alemmens Exp $
+;; $Id: mop.lisp,v 1.9 2006/08/31 20:09:17 alemmens Exp $
(in-package :rucksack)
@@ -13,10 +13,20 @@
(defclass persistent-class (standard-class)
((persistent-slots :initform '()
:accessor class-persistent-slots)
- (index :initarg :index :initform nil :accessor class-index
+ (index :initarg :index :initform nil
:documentation "Can be either NIL (for no class index) or T
(for the standard class index). Default value is NIL.")))
+(defmethod class-index ((class persistent-class))
+ ;; According to the MOP, the INDEX slot is initialized with the
+ ;; list of items following the :INDEX option, but we're only
+ ;; interested in the first item of that list.
+ (first (slot-value class 'index)))
+
+;;
+;; Persistent slot definitions
+;;
+
(defclass persistent-slot-mixin ()
((persistence :initarg :persistence
:initform t
@@ -115,14 +125,6 @@
(list* option value already-processed-options)
(call-next-method)))
-#+lispworks
-(defmethod clos:process-a-class-option ((class persistent-class)
- option-name
- value)
- (if (eql option-name :index)
- (cons option-name value)
- (call-next-method)))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Initializing the persistent-class metaobjects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -146,7 +148,7 @@
;; slot-value-using-class.
#+lispworks :optimize-slot-access #+lispworks nil
args)))
- (update-indexes class '())
+ (update-indexes class)
result))
@@ -154,17 +156,16 @@
&rest args
&key direct-superclasses
&allow-other-keys)
- (let* ((old-slots (mapcar #'copy-slot-definition (class-direct-slots class)))
- (result (apply #'call-next-method
- class
- :direct-superclasses (maybe-add-persistent-object-class
- class
- direct-superclasses)
- ;; Tell Lispworks that it shouldn't bypass
- ;; SLOT-VALUE-USING-CLASS.
- #+lispworks :optimize-slot-access #+lispworks nil
- args)))
- (update-indexes class old-slots)
+ (let ((result (apply #'call-next-method
+ class
+ :direct-superclasses (maybe-add-persistent-object-class
+ class
+ direct-superclasses)
+ ;; Tell Lispworks that it shouldn't bypass
+ ;; SLOT-VALUE-USING-CLASS.
+ #+lispworks :optimize-slot-access #+lispworks nil
+ args)))
+ (update-indexes class)
result))
@@ -182,7 +183,7 @@
direct-superclasses
(cons root-class direct-superclasses))))
-(defun update-indexes (class old-slots)
+(defun update-indexes (class)
;; Update class and slot indexes.
(when (fboundp 'current-rucksack)
;; This function is also called during compilation of Rucksack
@@ -192,7 +193,7 @@
(let ((rucksack (current-rucksack)))
(when rucksack
(rucksack-update-class-index rucksack class)
- (rucksack-update-slot-indexes rucksack class old-slots)))))
+ (rucksack-update-slot-indexes rucksack class)))))
(defmethod finalize-inheritance :after ((class persistent-class))
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/31 15:47:58 1.15
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/31 20:09:18 1.16
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.15 2006/08/31 15:47:58 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.16 2006/08/31 20:09:18 alemmens Exp $
(in-package :rucksack)
@@ -66,14 +66,13 @@
class index (i.e. a class index that's specified anymore in the class
option) is removed, new class indexes are added."))
-(defgeneric rucksack-update-slot-indexes (rucksack class old-slots)
+(defgeneric rucksack-update-slot-indexes (rucksack class)
(:documentation
"Compares the current slot indexes for CLASS to the slot indexes
that are specified in the slot options for the direct slots of CLASS.
Obsolete slot indexes (i.e. slot indexes that are not specified
anymore in the slot options or indexes for slots that don't exist
-anymore) are removed, new slot indexes are added.
- OLD-SLOTS is a list with the previous slot definitions."))
+anymore) are removed, new slot indexes are added."))
(defgeneric rucksack-add-class-index (rucksack class-designator &key errorp))
@@ -553,8 +552,7 @@
(defmethod rucksack-update-slot-indexes ((rucksack standard-rucksack)
- (class persistent-class)
- old-slots)
+ (class persistent-class))
(let ((direct-slots (class-direct-slots class))
(indexed-slot-names (rucksack-indexed-slots-for-class rucksack class)))
;; Remove indexes for slots that don't exist anymore.
@@ -686,8 +684,7 @@
(defmethod rucksack-make-class-index
((rucksack standard-rucksack) class
- &key
- (index-spec '(btree :key< < :value= p-eql)))
+ &key (index-spec '(btree :key< < :value= p-eql)))
;; A class index maps object ids to objects.
(declare (ignore class))
(make-index index-spec t))
--- /project/rucksack/cvsroot/rucksack/test-index-1a.lisp 2006/08/31 15:50:27 1.1
+++ /project/rucksack/cvsroot/rucksack/test-index-1a.lisp 2006/08/31 20:09:18 1.2
@@ -1,4 +1,4 @@
-;; $Id: test-index-1a.lisp,v 1.1 2006/08/31 15:50:27 alemmens Exp $
+;; $Id: test-index-1a.lisp,v 1.2 2006/08/31 20:09:18 alemmens Exp $
(in-package :rucksack-test)
@@ -23,7 +23,7 @@
(defparameter *hacker-rucksack* #p"/tmp/rucksack/hackers/")
- (with-rucksack (*rucksack* *hacker-rucksack*)
+ (with-rucksack (*rucksack* *hacker-rucksack* :if-exists :supersede)
(with-transaction ()
;; We define some persistent classes with indexed slots.
More information about the rucksack-cvs
mailing list