[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Mon Sep 4 12:34:35 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv7254
Modified Files:
do.txt done.txt garbage-collector.lisp heap.lisp mop.lisp
objects.lisp test-schema-update-1a.lisp
test-schema-update-1b.lisp test-schema-update-1c.lisp
Log Message:
Take care of some differences between the MOP implementations of Lispworks
and SBCL. Lispworks doesn call (SETF SLOT-VALUE-USING-CLASS) in
SHARED-INITIALIZE, but SBCL does. Lispworks calls FINALIZE-INHERITANCE
after a class is redefined and a new instance is created, but SBCL doesn't.
All tests now work for Lispworks (5.0) and SBCL (0.9.16).
Some work on a copying GC.
--- /project/rucksack/cvsroot/rucksack/do.txt 2006/09/03 14:40:50 1.4
+++ /project/rucksack/cvsroot/rucksack/do.txt 2006/09/04 12:34:34 1.5
@@ -1,5 +1,9 @@
DO:
+- In SBCL, FINALIZE-INHERITANCE is not called when a class was redefined
+ and a new instance of the redefined class is created. (In Lispworks,
+ it *is* called then.)
+
- Make Rucksack crash proof. (Use a copying GC?)
- There's still a btree bug that's detected (very rarely) by the
--- /project/rucksack/cvsroot/rucksack/done.txt 2006/09/03 14:40:51 1.4
+++ /project/rucksack/cvsroot/rucksack/done.txt 2006/09/04 12:34:34 1.5
@@ -1,3 +1,13 @@
+* 2006-09-04
+
+- Take care of some differences between the MOP implementations of Lispworks
+ and SBCL. Lispworks doesn't call (setf slot-value-using-class) in
+ SHARED-INITIALIZE, but SBCL does. Lispworks calls FINALIZE-INHERITANCE
+ after a class is redefined and a new instance is created, but SBCL
+ doesn't. All tests now work for Lispworks (5.0) and SBCL (0.9.16).
+
+- Some work on a copying GC.
+
* 2006-09-03
- Handle updates of in-memory persistent objects by writing a method
--- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/24 15:21:25 1.18
+++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/09/04 12:34:34 1.19
@@ -1,4 +1,4 @@
-;; $Id: garbage-collector.lisp,v 1.18 2006/08/24 15:21:25 alemmens Exp $
+;; $Id: garbage-collector.lisp,v 1.19 2006/09/04 12:34:34 alemmens Exp $
(in-package :rucksack)
@@ -7,7 +7,30 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass garbage-collector ()
- ())
+ ((object-table :initarg :object-table :reader object-table)
+ (buffer :initform (make-instance 'serialization-buffer)
+ :reader serialization-buffer)
+ (rucksack :initarg :rucksack :reader rucksack)
+ ;; Some state used for incremental garbage collection.
+ (roots :initarg :roots :initform '() :accessor roots
+ :documentation "A list of object-ids of roots that must be kept alive.")
+ (state :initform :ready
+ :type (member :starting
+ :finishing
+ :ready
+ ;; For copying collector
+ :copying
+ ;; For mark-and-sweep collector
+ :marking-object-table
+ :scanning
+ :sweeping-heap
+ :sweeping-object-table)
+ :accessor state)
+ (doing-work :initform nil :accessor gc-doing-work
+ ;; NOTE: This flag is probably not necessary anymore and
+ ;; should probably be removed.
+ :documentation
+ "A flag to prevent recursive calls to COLLECT-SOME-GARBAGE.")))
(defgeneric scan (buffer garbage-collector)
@@ -24,33 +47,42 @@
;; Most of the SCAN-CONTENTS methods are in serialize.lisp.
(scan-contents marker buffer gc)))
+
+
+(defmethod gc-work-for-size ((heap heap) size)
+ ;; The garbage collector needs to be ready when there's no more free space
+ ;; left in the heap. So when SIZE octets are allocated, the garbage collector
+ ;; needs to collect a proportional amount of bytes:
+ ;;
+ ;; Size / Free = Work / WorkLeft
+ ;;
+ ;; or: Work = (Size / Free) * WorkLeft
+ ;;
+ (if (zerop size)
+ 0
+ (let* ((free (free-space heap))
+ (work-left (work-left heap)))
+ (if (>= size free)
+ work-left
+ (floor (* size work-left) free)))))
+
+(defmethod free-space ((heap heap))
+ ;; Returns an estimate of the number of octets that can be
+ ;; allocated until the heap is full (i.e. heap-end >= heap-max-end).
+ ;; For a copying collector, this number is very close to the truth.
+ ;; But for mark-and-sweep collectorsestimate it is a very conservative
+ ;; estimate, because we only count the heap space that hasn't been
+ ;; reserved by one of the free lists (because you can't be sure that
+ ;; a free list block can actually be used to allocate an arbitrary-sized
+ ;; block).
+ (- (max-heap-end heap) (heap-end heap)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Mark and sweep collector
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass mark-and-sweep-heap (garbage-collector free-list-heap serializer)
- ((object-table :initarg :object-table :reader object-table)
- (buffer :initform (make-instance 'serialization-buffer)
- :reader serialization-buffer)
- (rucksack :initarg :rucksack :reader rucksack)
- ;; Some state used for incremental garbage collection.
- (roots :initarg :roots :initform '() :accessor roots
- :documentation "A list of object-ids of roots that must be marked.")
- (state :initform :ready
- :type (member :starting
- :marking-object-table
- :scanning
- :sweeping-heap
- :sweeping-object-table
- :finishing
- :ready)
- :accessor state)
- (doing-work :initform nil :accessor gc-doing-work
- ;; NOTE: This flag is probably not necessary anymore and
- ;; should probably be removed.
- :documentation
- "A flag to prevent recursive calls to COLLECT-SOME-GARBAGE.")
- ;; Some counters that keep track of the amount of work done by
+ (;; Some counters that keep track of the amount of work done by
;; the garbage collector.
(nr-object-bytes-marked :initform 0 :accessor nr-object-bytes-marked)
(nr-heap-bytes-scanned :initform 0 :accessor nr-heap-bytes-scanned)
@@ -92,7 +124,6 @@
(defmethod close-heap :after ((heap mark-and-sweep-heap))
(close-heap (object-table heap)))
-
(defmethod initialize-block (block block-size (heap mark-and-sweep-heap))
;; This is called by a free list heap while creating free blocks.
;; Write the block size (as a negative number) in the start of the
@@ -122,32 +153,7 @@
;; Hooking into free list methods
;;
-(defmethod gc-work-for-size ((heap mark-and-sweep-heap) size)
- ;; The garbage collector needs to be ready when there's no more free space
- ;; left in the heap. So when SIZE octets are allocated, the garbage collector
- ;; needs to collect a proportional amount of bytes:
- ;;
- ;; Size / Free = Work / WorkLeft
- ;;
- ;; or: Work = (Size / Free) * WorkLeft
- ;;
- (if (zerop size)
- 0
- (let* ((free (free-space heap))
- (work-left (work-left heap)))
- (if (>= size free)
- work-left
- (floor (* size work-left) free)))))
-
-(defmethod free-space ((heap mark-and-sweep-heap))
- ;; Returns an estimate of the number of octets that can be
- ;; allocated until the heap is full (i.e. heap-end >= heap-max-end).
- ;; We use a conservative estimate and only count the heap space that
- ;; hasn't been reserved by one of the free lists (because you can't
- ;; be sure that a free list block can actually be used to allocate
- ;; an arbitrary-sized block).
- (- (max-heap-end heap) (heap-end heap)))
(defmethod expand-heap :after ((heap mark-and-sweep-heap) block-size)
@@ -480,12 +486,8 @@
#| MAYBE LATER
-(defclass compacting-heap (heap)
- ((top :initform 0 :accessor top
- :documentation "The file-position where new objects can be allocated.")))
-
-(defclass copying-collector (garbage-collector serializer)
+(defclass copying-heap (garbage-collector serializer)
((space-0 :initarg :space-0 :reader space-0)
(space-1 :initarg :space-1 :reader space-1)
(from-space :accessor from-space)
@@ -494,6 +496,14 @@
:documentation "The position in to-space where the next object
can be evacuated.")))
+(defmethod collect-some-garbage ((heap copying-collector) amount)
+ 'DO-THIS)
+
+(defmethod gc-work-for-size ((heap copying-collector) nr-allocated-octets)
+ 'DO-THIS)
+
+(defmethod close-heap :after ((heap copying-heap))
+ (close-heap (object-table heap)))
(defmethod deserialize-byte ((gc copying-collector)
&optional (eof-error-p t))
@@ -551,7 +561,8 @@
;;
-(defmethod trace-contents ((marker (eql +cached-object+))
+(defmethod scan-contents ((marker (eql +cached-object+))
+ buffer
(gc copying-collector))
;; Hook into the scanner: when the scanner finds a cached-object,
;; it evacuates that object and returns.
--- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/10 12:36:16 1.11
+++ /project/rucksack/cvsroot/rucksack/heap.lisp 2006/09/04 12:34:34 1.12
@@ -1,4 +1,4 @@
-;; $Id: heap.lisp,v 1.11 2006/08/10 12:36:16 alemmens Exp $
+;; $Id: heap.lisp,v 1.12 2006/09/04 12:34:34 alemmens Exp $
(in-package :rucksack)
@@ -18,6 +18,9 @@
(defgeneric heap-stream (heap)
(:documentation "Returns the heap's stream."))
+(defgeneric heap-start (heap)
+ (:documentation "Returns the position of the first block in the heap."))
+
(defgeneric heap-end (heap)
(:documentation "Returns the end of the heap."))
@@ -52,8 +55,9 @@
;; Just a buffer for 1 cell.
:reader cell-buffer)
(end :accessor heap-end
- :documentation "The end of the heap. This number is stored in the first
-heap cell.")
+ :documentation "The end of the heap. For free-list heaps, this number
+is stored in the first heap cell. For appending heaps, it's stored in the
+end of the file.")
(max-size :initarg :max-size
:initform nil :accessor max-heap-size
:documentation "The maximum size (in octets) for the heap.
@@ -70,14 +74,6 @@
;; Open/close/initialize
;;
-(defmethod initialize-instance :after ((heap heap) &key &allow-other-keys)
- ;; Initialize the heap end.
- (if (zerop (file-length (heap-stream heap)))
- (setf (heap-end heap) +pointer-size+)
- (setf (slot-value heap 'end) (pointer-value 0 heap))))
-
-
-
(defun open-heap (pathname
&key (class 'heap) rucksack (options '())
(if-exists :overwrite) (if-does-not-exist :create))
@@ -99,19 +95,9 @@
(defmethod finish-heap-output ((heap heap))
(finish-output (heap-stream heap)))
-;;
-;; Heap start/end
-;;
-
-(defgeneric heap-start (heap)
- (:method ((heap heap))
- ;; Default: return the position just after the heap end cell.
- +pointer-size+)
- (:documentation "Returns the position of the first block in the heap."))
-(defmethod (setf heap-end) :after (end (heap heap))
- ;; Store the heap end in the file.
- (setf (pointer-value 0 heap) end))
+(defmethod heap-size ((heap heap))
+ (- (heap-end heap) (heap-start heap)))
;;
;; Pointers
@@ -205,6 +191,10 @@
(defmethod initialize-instance :after ((heap free-list-heap)
&key &allow-other-keys)
+ ;; Initialize the heap end.
+ (if (zerop (file-length (heap-stream heap)))
+ (setf (heap-end heap) +pointer-size+)
+ (setf (slot-value heap 'end) (pointer-value 0 heap)))
;; Load or create the array of free list pointers.
(setf (slot-value heap 'starts)
(make-array (nr-free-lists heap)))
@@ -230,6 +220,16 @@
(+ +pointer-size+ ; skip heap end cell
(* size-class +pointer-size+)))
+
+(defmethod heap-start ((heap free-list-heap))
+ ;; A free-list-heap starts with an array of pointers to the first element
+ ;; of each free list; the heap blocks start after that array.
+ (free-list-pointer (nr-free-lists heap)))
+
+(defmethod (setf heap-end) :after (end (heap free-list-heap))
+ ;; Store the heap end in the file.
+ (setf (pointer-value 0 heap) end))
+
;;
;;
@@ -291,17 +291,6 @@
;; the block is occupied.
(block-header block heap))
-;;
-;;
-
-
-(defmethod heap-start ((heap free-list-heap))
- ;; A free-list-heap starts with an array of pointers to the first element
- ;; of each free list; the heap blocks start after that array.
- (free-list-pointer (nr-free-lists heap)))
-
-(defmethod heap-size ((heap free-list-heap))
- (- (heap-end heap) (heap-start heap)))
;;
;; Allocating and deallocating blocks
@@ -467,6 +456,45 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Appending heap (as used by copying garbage collector)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass appending-heap (heap)
+ ;; For an APPENDING-HEAP, all writes take place to the heap's end.
+ ;; The last 7 octets of the file always contain a serialized version
+ ;; of the heap's end.
+ ())
+
+(defmethod allocate-block ((heap appending-heap) &key size &allow-other-keys)
+ (let ((block (heap-end heap)))
+ ;; Put block size (including the size of header) into header.
+ (setf (block-size block heap) size)
+ ;;
+ (incf (heap-end heap) size)
+ (values block size)))
+
+(defmethod (setf heap-end) :after (end (heap appending-heap))
+ (let ((stream (heap-stream heap)))
+ (file-position stream end)
+ ;; Write new end to the end of the file.
+ (serialize-marker +positive-byte-48+ stream)
+ (serialize-byte-48 end stream)))
+
+(defmethod heap-start ((heap appending-heap))
+ 0)
+
+(defmethod load-heap-end ((heap appending-heap))
+ (let* ((stream (heap-stream heap))
+ ;; 7 octets: one for a marker, 6 for a byte-48.
+ (pos (- (file-length stream) 7)))
+ (file-position stream pos)
+ (let ((end (deserialize stream)))
+ (unless (= end pos)
+ (error "Heap may be corrupt (heap-end info is missing."))
+ (setf (slot-value heap 'end) end))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Little utility functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/09/01 13:57:07 1.10
+++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/09/04 12:34:34 1.11
@@ -1,4 +1,4 @@
-;; $Id: mop.lisp,v 1.10 2006/09/01 13:57:07 alemmens Exp $
+;; $Id: mop.lisp,v 1.11 2006/09/04 12:34:34 alemmens Exp $
(in-package :rucksack)
@@ -15,7 +15,13 @@
:accessor class-persistent-slots)
(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.")))
+(for the standard class index). Default value is NIL.")
+ (changed-p :initform nil :accessor class-changed-p
+ :documentation "True iff the class definition was changed
+but the schemas haven't been updated yet. This flag is necessary because
+some MOP implementations don't call FINALIZE-INHERITANCE when a class
+was redefined and a new instance of the redefined class is created.")))
+
(defmethod class-index ((class persistent-class))
;; According to the MOP, the INDEX slot is initialized with the
@@ -151,10 +157,12 @@
;; SLOT-VALUE-USING-CLASS.
#+lispworks :optimize-slot-access #+lispworks nil
args)))
+ (setf (class-changed-p class) t)
(update-indexes class)
result))
+
(defun maybe-add-persistent-object-class (class direct-superclasses)
;; Add PERSISTENT-OBJECT to the superclass list if necessary.
(let ((root-class (find-class 'persistent-object nil))
@@ -183,6 +191,9 @@
(defmethod finalize-inheritance :after ((class persistent-class))
+ (update-slot-info class))
+
+(defun update-slot-info (class)
;; Register all (effective) persistent slots.
(setf (class-persistent-slots class)
(remove-if-not #'slot-persistence (class-slots class)))
@@ -191,8 +202,13 @@
(let ((rucksack (current-rucksack)))
(when rucksack
(maybe-update-schemas (schema-table (rucksack-cache rucksack))
- class)))))
-
+ class))))
+ ;;
+ (setf (class-changed-p class) nil))
+
+(defun maybe-update-slot-info (class)
+ (when (class-changed-p class)
+ (update-slot-info class)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Computing slot definitions
@@ -236,3 +252,4 @@
;; Return the effective slot definition.
effective-slotdef))
+
--- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/09/03 14:40:51 1.16
+++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/09/04 12:34:34 1.17
@@ -1,4 +1,4 @@
-;; $Id: objects.lisp,v 1.16 2006/09/03 14:40:51 alemmens Exp $
+;; $Id: objects.lisp,v 1.17 2006/09/04 12:34:34 alemmens Exp $
(in-package :rucksack)
@@ -402,8 +402,14 @@
inherit from this class."))
+(defparameter *initializing-instance*
+ ;; A hack to paper over some MOP differences. Maybe a cleaner way
+ ;; to solve this would be to write our own method for SHARED-INITIALIZE,
+ ;; as suggested by Pascal Costanza.
+ ;; See emails of 2006-09-03/04 on rucksack-devel at common-lisp.net.
+ nil)
-(defmethod initialize-instance :before ((object persistent-object)
+(defmethod initialize-instance :around ((object persistent-object)
&rest args
&key rucksack
;; The DONT-INDEX argument is used
@@ -411,6 +417,7 @@
;; (to prevent infinite recursion).
(dont-index nil)
&allow-other-keys)
+ (maybe-update-slot-info (class-of object))
;; This happens when persistent-objects are created in memory, not when
;; they're loaded from the cache (loading uses ALLOCATE-INSTANCE instead).
(let ((rucksack (or rucksack (rucksack object))))
@@ -421,23 +428,27 @@
(unless (slot-boundp object 'rucksack)
(setf (slot-value object 'rucksack) rucksack))
(unless dont-index
- (rucksack-maybe-index-new-object rucksack (class-of object) object))))
-
-(defmethod initialize-instance :after ((object persistent-object)
- &rest args
- &key rucksack (dont-index nil)
- &allow-other-keys)
- ;; Update slot indexes for persistent slots that are bound now.
- (unless dont-index
- (let ((class (class-of object)))
- (dolist (slot (class-slots class))
- (let ((slot-name (slot-definition-name slot)))
- (when (and (slot-boundp object slot-name)
- (slot-persistence slot))
- (rucksack-maybe-index-changed-slot (or rucksack (rucksack object))
- class object slot
- nil (slot-value object slot-name)
- nil t)))))))
+ (rucksack-maybe-index-new-object rucksack (class-of object) object)))
+ ;;
+ (let (;; Tell (SETF SLOT-VALUE-USING-CLASS), which may be called
+ ;; by SHARED-INITIALIZE in some implementations, that we're
+ ;; just initializing the instance and it shouldn't try to
+ ;; update any indexes.
+ (*initializing-instance* t))
+ (let ((result (call-next-method)))
+ ;; Update slot indexes for persistent slots that are bound now.
+ (unless dont-index
+ (let ((class (class-of object)))
+ (dolist (slot (class-slots class))
+ (let ((slot-name (slot-definition-name slot)))
+ (when (and (slot-boundp object slot-name)
+ (slot-persistence slot))
+ (rucksack-maybe-index-changed-slot (or rucksack (rucksack object))
+ class object slot
+ nil (slot-value object slot-name)
+ nil t))))))
+ ;;
+ result)))
(defmethod print-object ((object persistent-object) stream)
@@ -468,8 +479,8 @@
(defmethod slot-value-using-class :around ((class persistent-class)
object
slot)
+ (maybe-update-slot-info class)
;; Automatically dereference proxies.
- (declare (ignore class slot))
(maybe-dereference-proxy (call-next-method)))
@@ -477,6 +488,7 @@
(class persistent-class)
object
slot-name-or-def)
+ (maybe-update-slot-info class)
;; If this is a persistent slot, tell the cache that this object
;; has changed. The cache will save it when necessary.
(let ((slot (slot-def-and-name class slot-name-or-def)))
@@ -492,10 +504,11 @@
(result (call-next-method)))
(cache-touch-object object (cache object))
;; Update indexes.
- (rucksack-maybe-index-changed-slot (rucksack object)
- class object slot
- old-value new-value
- old-boundp t)
+ (unless *initializing-instance*
+ (rucksack-maybe-index-changed-slot (rucksack object)
+ class object slot
+ old-value new-value
+ old-boundp t))
result)
(call-next-method))))
@@ -503,6 +516,7 @@
(defmethod slot-makunbound-using-class :around ((class persistent-class)
object
slot-name-or-def)
+ (maybe-update-slot-info class)
;; If this is a persistent slot, tell the cache that this object
;; has changed. Rely on the cache to save it when necessary.
(let ((slot (slot-def-and-name class slot-name-or-def)))
--- /project/rucksack/cvsroot/rucksack/test-schema-update-1a.lisp 2006/09/01 13:57:07 1.2
+++ /project/rucksack/cvsroot/rucksack/test-schema-update-1a.lisp 2006/09/04 12:34:34 1.3
@@ -1,12 +1,15 @@
-;; $Id: test-schema-update-1a.lisp,v 1.2 2006/09/01 13:57:07 alemmens Exp $
+;; $Id: test-schema-update-1a.lisp,v 1.3 2006/09/04 12:34:34 alemmens Exp $
(in-package :rucksack-test-schema-update)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Schema updates and UPDATE-INSTANCE-FOR-REDEFINED-CLASS, part 1 of 3
;;;
-;;; After compiling and loading this file, compile and load
-;;; test-schema-update-1b.lisp.
+;;; After compiling and loading this file, evaluate:
+;;; - (in-package :rucksack-test-schema-update)
+;;; - (test-1)
+;;;
+;;; Then move on to test-schema-update-1b.lisp.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *names* '(john dick mary jane peter ronald))
@@ -40,17 +43,17 @@
(name person)
(age person))))
-;; Create some persons.
-(with-rucksack (rs *dir*)
- (with-transaction ()
- (loop repeat 10
- do (make-instance 'person))))
-
-;; Show them.
-(with-rucksack (rs *dir*)
- (with-transaction ()
- (rucksack-map-class rs 'person #'print)))
+(defun test-1 ()
+ ;; Create some persons.
+ (with-rucksack (rs *dir*)
+ (with-transaction ()
+ (loop repeat 10
+ do (make-instance 'person))))
+ ;; Show them.
+ (with-rucksack (rs *dir*)
+ (with-transaction ()
+ (rucksack-map-class rs 'person #'print))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Sample output
--- /project/rucksack/cvsroot/rucksack/test-schema-update-1b.lisp 2006/09/01 13:57:07 1.2
+++ /project/rucksack/cvsroot/rucksack/test-schema-update-1b.lisp 2006/09/04 12:34:34 1.3
@@ -1,13 +1,15 @@
-;; $Id: test-schema-update-1b.lisp,v 1.2 2006/09/01 13:57:07 alemmens Exp $
+;; $Id: test-schema-update-1b.lisp,v 1.3 2006/09/04 12:34:34 alemmens Exp $
(in-package :rucksack-test-schema-update)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Schema updates and UPDATE-INSTANCE-FOR-REDEFINED-CLASS, part 2 of 3
;;;
-;;; Compile and load this file after compiling and loading
-;;; test-schema-update-1a.lisp. Study the output, and then compile
-;;; and load test-schema-update-1c.lisp.
+;;; Run this example after test-schema-update-1a.lisp:
+;;;
+;;; - Compile and load this file
+;;; - Evaluate (TEST-2)
+;;; - Then move on to test-schema-update-1c.lisp.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@@ -49,27 +51,28 @@
(- +this-year+ (year-of-birth person)))
-;; Create some persons with the new class definition.
-(with-rucksack (rs *dir*)
- (with-transaction ()
- (loop repeat 10
- do (make-instance 'person))))
-
-;; Show some PERSON instances and some old PERSON instances.
-;; (We don't show all PERSON instances, because showing them may
-;; update them and we want to keep a few old instances for the next
-;; part of the test).
-
-(with-rucksack (rs *dir*)
- (with-transaction ()
- (let ((cache (rucksack-cache rs))
- (count 0))
- (rucksack-map-class rs 'person
- (lambda (id)
- (when (evenp count)
- (print (cache-get-object id cache)))
- (incf count))
- :id-only t))))
+(defun test-2 ()
+ ;; Create some persons with the new class definition.
+ (with-rucksack (rs *dir*)
+ (with-transaction ()
+ (loop repeat 10
+ do (make-instance 'person))))
+
+ ;; Show some PERSON instances and some old PERSON instances.
+ ;; (We don't show all PERSON instances, because showing them may
+ ;; update them and we want to keep a few old instances for the next
+ ;; part of the test).
+
+ (with-rucksack (rs *dir*)
+ (with-transaction ()
+ (let ((cache (rucksack-cache rs))
+ (count 0))
+ (rucksack-map-class rs 'person
+ (lambda (id)
+ (when (evenp count)
+ (print (cache-get-object id cache)))
+ (incf count))
+ :id-only t)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /project/rucksack/cvsroot/rucksack/test-schema-update-1c.lisp 2006/09/01 13:57:07 1.2
+++ /project/rucksack/cvsroot/rucksack/test-schema-update-1c.lisp 2006/09/04 12:34:34 1.3
@@ -1,12 +1,13 @@
-;; $Id: test-schema-update-1c.lisp,v 1.2 2006/09/01 13:57:07 alemmens Exp $
+;; $Id: test-schema-update-1c.lisp,v 1.3 2006/09/04 12:34:34 alemmens Exp $
(in-package :rucksack-test-schema-update)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Schema updates and UPDATE-INSTANCE-FOR-REDEFINED-CLASS, part 3 of 3
;;;
-;;; Compile and load this file after compiling and loading
-;;; test-schema-update-1c.lisp
+;;; Run this example after test-schema-update-1b.lisp:
+;;; - compile and load this file
+;;; - evaluate (TEST-3)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@@ -72,16 +73,16 @@
(nth-value 5 (decode-universal-time (date-of-birth person))))
-;; Create some persons with the second version of the class definition.
-(with-rucksack (rs *dir*)
- (with-transaction ()
- (loop repeat 10
- do (make-instance 'person))))
-
-;; Show all persons (for three versions of the class definition).
-(with-rucksack (rs *dir*)
- (with-transaction ()
- (rucksack-map-class rs 'person #'print)))
+(defun test-3 ()
+ ;; Create some persons with the second version of the class definition.
+ (with-rucksack (rs *dir*)
+ (with-transaction ()
+ (loop repeat 10
+ do (make-instance 'person))))
+ ;; Show all persons (for three versions of the class definition).
+ (with-rucksack (rs *dir*)
+ (with-transaction ()
+ (rucksack-map-class rs 'person #'print))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Sample output
More information about the rucksack-cvs
mailing list