[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Wed Aug 30 14:05:42 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv26918
Modified Files:
example-1.lisp mop.lisp objects.lisp package.lisp
rucksack.lisp schema-table.lisp test.lisp
Log Message:
- FINALIZE-INHERITANCE: compute slot diffs for obsolete schemas.
- More work on UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS.
--- /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/29 13:50:18 1.4
+++ /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/30 14:05:40 1.5
@@ -1,13 +1,13 @@
-;; $Id: example-1.lisp,v 1.4 2006/08/29 13:50:18 alemmens Exp $
+;; $Id: example-1.lisp,v 1.5 2006/08/30 14:05:40 alemmens Exp $
-(in-package :test-rucksack)
+(in-package :rucksack-test)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Indexing example
;;;
;;; To run this example:
;;; - compile and load this file
-;;; - (IN-PACKAGE :TEST-RS)
+;;; - (IN-PACKAGE :RUCKSACK-TEST)
;;; - (CREATE-HACKERS)
;;; - (SHOW-HACKERS)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -94,9 +94,6 @@
#|
-CL-USER 2 > (in-package :test-rs)
-#<The TEST-RUCKSACK package, 74/256 internal, 0/16 external>
-
TEST-RS 3 > (create-hackers)
#<HACKER #:HACKER-9234 called "Martin">
--- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/29 11:41:40 1.7
+++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/30 14:05:40 1.8
@@ -1,4 +1,4 @@
-;; $Id: mop.lisp,v 1.7 2006/08/29 11:41:40 alemmens Exp $
+;; $Id: mop.lisp,v 1.8 2006/08/30 14:05:40 alemmens Exp $
(in-package :rucksack)
@@ -146,7 +146,7 @@
;; slot-value-using-class.
#+lispworks :optimize-slot-access #+lispworks nil
args)))
- (ensure-class-schema class '())
+ (update-indexes class '())
result))
@@ -164,7 +164,7 @@
;; SLOT-VALUE-USING-CLASS.
#+lispworks :optimize-slot-access #+lispworks nil
args)))
- (ensure-class-schema class old-slots)
+ (update-indexes class old-slots)
result))
@@ -182,37 +182,29 @@
direct-superclasses
(cons root-class direct-superclasses))))
-(defun ensure-class-schema (class old-slots)
+(defun update-indexes (class old-slots)
;; Update class and slot indexes.
- (when (or (class-index class)
- (some #'slot-persistence (class-direct-slots class)))
- ;; NOTE: We get the current-rucksack only if there are some
- ;; persistent slots, because this will also get called during
- ;; compilation of Rucksack (when the class definition of
- ;; PERSISTENT-OBJECT is compiled). At that stage the CURRENT-RUCKSACK
- ;; function isn't even defined yet, so we shouldn't call it.
+ (when (fboundp 'current-rucksack)
+ ;; This function is also called during compilation of Rucksack
+ ;; (when the class definition of PERSISTENT-OBJECT is compiled).
+ ;; At that stage the CURRENT-RUCKSACK function isn't even defined
+ ;; yet, so we shouldn't call it.
(let ((rucksack (current-rucksack)))
(when rucksack
(rucksack-update-class-index rucksack class)
- (rucksack-update-slot-indexes rucksack class old-slots)
- ;; Update schema in schema table, if necessary.
- (rucksack-maybe-update-schema rucksack class old-slots)))))
+ (rucksack-update-slot-indexes rucksack class old-slots)))))
(defmethod finalize-inheritance :after ((class persistent-class))
- ;; Register all persistent slots.
+ ;; Register all (effective) persistent slots.
(setf (class-persistent-slots class)
(remove-if-not #'slot-persistence (class-slots class)))
- ;;
- (when (or (class-index class) (class-persistent-slots class))
+ ;; Update schemas if necessary.
+ (when (fboundp 'current-rucksack) ; see comment for UPDATE-INDEXES
(let ((rucksack (current-rucksack)))
(when rucksack
- (let* ((schema-table (schema-table (rucksack-cache rucksack)))
- (schema (find-schema-for-class schema-table class)))
- (when schema
- (setf (persistent-slot-names schema)
- (mapcar #'slot-definition-name
- (class-persistent-slots class)))))))))
+ (maybe-update-schemas (schema-table (rucksack-cache rucksack))
+ class)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/29 13:50:18 1.12
+++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/30 14:05:40 1.13
@@ -1,4 +1,4 @@
-;; $Id: objects.lisp,v 1.12 2006/08/29 13:50:18 alemmens Exp $
+;; $Id: objects.lisp,v 1.13 2006/08/30 14:05:40 alemmens Exp $
(in-package :rucksack)
@@ -677,8 +677,8 @@
;; their (obsolete) values.
(discarded-slot-values '()))
(when (schema-obsolete-p schema)
- (setf added-slots (schema-added-slot-names schema)
- discarded-slots (schema-discarded-slot-names schema)))
+ (setf added-slots (added-slot-names schema)
+ discarded-slots (discarded-slot-names schema)))
;; Load and set slot values.
;; DO: We should probably initialize the transient slots to their
;; initforms here.
--- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/29 13:50:18 1.9
+++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/30 14:05:40 1.10
@@ -1,4 +1,4 @@
-;; $Id: package.lisp,v 1.9 2006/08/29 13:50:18 alemmens Exp $
+;; $Id: package.lisp,v 1.10 2006/08/30 14:05:40 alemmens Exp $
#-(or allegro lispworks sbcl openmcl)
(error "Unsupported implementation: ~A" (lisp-implementation-type))
@@ -102,7 +102,10 @@
-(defpackage :test-rucksack
- (:nicknames :test-rs)
- (:use :cl :rucksack))
-
+(defpackage :rucksack-test
+ (:nicknames :rs-test)
+ (:use :common-lisp :rucksack))
+
+(defpackage :rucksack-test-schema-update
+ (:nicknames :rs-tsu)
+ (:use :common-lisp :rucksack))
\ No newline at end of file
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/29 11:41:40 1.13
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/30 14:05:40 1.14
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.13 2006/08/29 11:41:40 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.14 2006/08/30 14:05:40 alemmens Exp $
(in-package :rucksack)
@@ -560,7 +560,7 @@
(loop for slot in old-slots
for slot-name = (slot-definition-name slot)
unless (find slot-name direct-slots :key #'slot-definition-name)
- do (rucksack-remove-slot-index rucksack class slot-name :errorp t))
+ do (rucksack-remove-slot-index rucksack class slot-name :errorp nil))
;; Update indexes for the current set of direct slots.
(dolist (slot direct-slots)
(let ((index-spec (and (slot-persistence slot)
@@ -808,12 +808,12 @@
;; Return the slot name if everything went fine; otherwise, return
;; NIL (or signal an error).
(and (handler-bind ((btree-search-error #'oops))
-
(let ((slot-index-table (btree-search (slot-index-tables rucksack) class
:errorp errorp)))
- (handler-bind ((btree-deletion-error #'oops))
- (btree-delete-key slot-index-table slot
- :if-does-not-exist (if errorp :error :ignore)))))
+ (and slot-index-table
+ (handler-bind ((btree-deletion-error #'oops))
+ (btree-delete-key slot-index-table slot
+ :if-does-not-exist (if errorp :error :ignore))))))
slot)))
@@ -942,17 +942,6 @@
(push class-name result))))
result))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Schema updates
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmethod rucksack-maybe-update-schema ((rucksack standard-rucksack)
- class
- old-slot-indexes)
- ;; This is just a thin wrapper, so you can customize it if necessary.
- (maybe-update-schema (schema-table (rucksack-cache rucksack))
- class
- old-slot-indexes))
\ No newline at end of file
--- /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/29 13:50:18 1.5
+++ /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/30 14:05:40 1.6
@@ -1,4 +1,4 @@
-;; $Id: schema-table.lisp,v 1.5 2006/08/29 13:50:18 alemmens Exp $
+;; $Id: schema-table.lisp,v 1.6 2006/08/30 14:05:40 alemmens Exp $
(in-package :rucksack)
@@ -22,14 +22,20 @@
also uniquely identifies a schema.")
(obsolete-p :initform nil :accessor schema-obsolete-p)
;; Slot info (computed during FINALIZE-INHERITANCE).
- (added-slot-names :initform '() :accessor schema-added-slot-names)
- (discarded-slot-names :initform '() :accessor schema-discarded-slot-names)
+ (added-slot-names :initform '()
+ :accessor added-slot-names
+ :documentation "A list with the names of all
+persistent slots that were added by the most recent version (compared
+to this version).")
+ (discarded-slot-names :initform '()
+ :accessor discarded-slot-names
+ :documentation "A list with the names of all
+persistent slots that were discarded by the most recent version
+(compared to this version).")
(persistent-slot-names :initarg :persistent-slot-names
:accessor persistent-slot-names
:documentation "A list with the names of all
-persistent effective slots.")
- ;; Class info (computed at schema creation time).
- (class-index :initarg :class-index :reader class-index)))
+persistent effective slots.")))
(defmethod nr-persistent-slots ((schema schema))
(length (persistent-slot-names schema)))
@@ -102,6 +108,8 @@
;; (or NIL if there is no schema for the class).
(first (gethash (class-name class) (schema-table-by-name table))))
+(defmethod old-schemas-for-class ((table schema-table) class)
+ (rest (gethash (class-name class) (schema-table-by-name table))))
(defmethod find-or-create-schema-for-object ((table schema-table) object)
;; NOTE: This assumes that the class hasn't changed without the
@@ -121,8 +129,7 @@
:id (fresh-schema-id table)
:class-name (class-name class)
:version version
- :persistent-slot-names persistent-slots
- :class-index (compute-class-index class))))
+ :persistent-slot-names persistent-slots)))
(add-schema table schema)
schema))
@@ -131,11 +138,6 @@
(declare (ignore object))
(mapcar #'slot-definition-name (class-persistent-slots class)))
-(defgeneric compute-class-index (class)
- (:method ((class persistent-class))
- (class-index class))
- (:method ((class t))
- nil))
(defmethod add-schema ((table schema-table) (schema schema))
(setf (gethash (schema-id schema) (schema-table-by-id table))
@@ -189,26 +191,25 @@
;;; Schema updates
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defmethod maybe-update-schema ((table schema-table) class old-slots)
+(defmethod maybe-update-schemas ((table schema-table) class)
;; Rucksack analyzes the new class definition; if it's different from the
;; previous version, a new schema is added to the schema table. From that
;; moment, when an instance of the redefined class is created it will be
;; saved with the new schema id.
- ;; This is called by the (RE-)INITIALIZE-INSTANCE method for
- ;; PERSISTENT-CLASS.
- (let ((old-schema (find-schema-for-class table class)))
+ ;; This is called by the FINALIZE-INHERITANCE method for PERSISTENT-CLASS.
+ (let ((slots (mapcar #'slot-definition-name (class-persistent-slots class)))
+ (old-schema (find-schema-for-class table class)))
(if (null old-schema)
;; There is no schema yet: create the first one.
- (create-schema table class 0)
- ;; There is a schema: create a new one if necessary.
- (multiple-value-bind (added-slots discarded-slots changed-slots)
- (compare-slots old-slots (class-direct-slots class))
- (when (or added-slots discarded-slots changed-slots
- (not (equal (class-index class) (class-index old-schema))))
- ;; Add a new schema for this class.
- (create-schema table class (1+ (schema-version old-schema)))
- ;; Mark all older versions as obsolete.
- (let ((old-schemas (rest (gethash (class-name class)
- (schema-table-by-name table)))))
- (loop for schema in old-schemas
- do (setf (schema-obsolete-p schema) t))))))))
+ (create-schema table class 0 slots)
+ ;; There is a schema already: create a new one if necessary.
+ (when (set-difference slots (persistent-slot-names old-schema))
+ ;; Add a new schema for this class.
+ (create-schema table class (1+ (schema-version old-schema)) slots)
+ ;; Mark all older versions as obsolete and compute their
+ ;; slot diffs w.r.t. to the new schema
+ (dolist (schema (old-schemas-for-class table class))
+ (let ((old-slots (persistent-slot-names schema)))
+ (setf (schema-obsolete-p schema) t
+ (added-slot-names schema) (set-difference slots old-slots)
+ (discarded-slot-names schema) (set-difference old-slots slots))))))))
--- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/24 15:45:02 1.12
+++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/30 14:05:40 1.13
@@ -1,6 +1,6 @@
-;; $Id: test.lisp,v 1.12 2006/08/24 15:45:02 alemmens Exp $
+;; $Id: test.lisp,v 1.13 2006/08/30 14:05:40 alemmens Exp $
-(in-package :test-rucksack)
+(in-package :rucksack-test)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A few quick tests to make sure the basics work.
More information about the rucksack-cvs
mailing list