[bknr-cvs] r2374 - branches/bos/projects/bos/m2

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Mon Jan 21 07:40:18 2008
New Revision: 2374

Modified:
   branches/bos/projects/bos/m2/allocation-test.lisp
   branches/bos/projects/bos/m2/allocation.lisp
   branches/bos/projects/bos/m2/test-fixtures.lisp
Log:
Started some testing using REOPEN-STORE.


Modified: branches/bos/projects/bos/m2/allocation-test.lisp
==============================================================================
--- branches/bos/projects/bos/m2/allocation-test.lisp	(original)
+++ branches/bos/projects/bos/m2/allocation-test.lisp	Mon Jan 21 07:40:18 2008
@@ -25,7 +25,9 @@
 	  (m2-count 10))
       (with-transaction ()
 	(bos.m2::activate-allocation-area area))
+      (finishes (allocation-area-free-m2s area))
       (is (= 1 (bos.m2.allocation-cache:free-regions-count)))
+      (reopen-store (:snapshot nil) area sponsor)
       (is-true (bos.m2.allocation-cache:find-exact-match 10))
       (finishes (make-contract sponsor m2-count))
       (is (zerop (allocation-area-free-m2s area))))))

Modified: branches/bos/projects/bos/m2/allocation.lisp
==============================================================================
--- branches/bos/projects/bos/m2/allocation.lisp	(original)
+++ branches/bos/projects/bos/m2/allocation.lisp	Mon Jan 21 07:40:18 2008
@@ -46,10 +46,13 @@
 
 (defmethod print-object ((allocation-area allocation-area) stream)
   (print-unreadable-object (allocation-area stream :type t)
-    (format stream "~a x ~a ~:[inactive~;active~] ID: ~a"
+    (format stream "~a x ~a ~:[inactive~;active~] free: ~s ID: ~a"
 	    (allocation-area-width allocation-area)
 	    (allocation-area-height allocation-area)
 	    (allocation-area-active-p allocation-area)
+	    (if (slot-boundp allocation-area 'free-m2s)
+		(allocation-area-free-m2s allocation-area)
+		:unbound)
 	    (store-object-id allocation-area))))
 
 (defmethod initialize-persistent-instance :after ((allocation-area allocation-area))
@@ -181,13 +184,13 @@
 						(null (allocation-area-free-m2s allocation-area)))))
 	   (all-allocation-areas)))
 
-(defun activate-allocation-area (area)
+(deftransaction activate-allocation-area (area)
   (warn "activating ~S" area)
   (setf (slot-value area 'active-p) t)
   (bos.m2.allocation-cache:rebuild-cache)
   area)
 
-(defun deactivate-allocation-area (area)
+(deftransaction deactivate-allocation-area (area)
   (warn "deactivating ~S" area)
   (setf (slot-value area 'active-p) nil)
   (bos.m2.allocation-cache:rebuild-cache)

Modified: branches/bos/projects/bos/m2/test-fixtures.lisp
==============================================================================
--- branches/bos/projects/bos/m2/test-fixtures.lisp	(original)
+++ branches/bos/projects/bos/m2/test-fixtures.lisp	Mon Jan 21 07:40:18 2008
@@ -1,5 +1,31 @@
 (in-package :bos.test)
 
+(defun %reopen-store (&key snapshot)
+  (format t "~&;; ++ reopen-store~%")
+  (when snapshot
+    (format t "~&;; ++ taking snapshot~%")
+    (snapshot))
+  (bos.m2::reinit :directory (bknr.datastore::store-directory *store*)
+		  :website-url bos.m2::*website-url*)
+  (format t "~&;; ++ reopen-store done~%"))
+
+(defmacro reopen-store ((&key snapshot) &body store-object-vars)
+  (let ((id-vars (iter
+		   (with *print-case* = :upcase)
+		   (for store-object-var in store-object-vars)
+		   (for id-var = (gensym (format nil "~A-ID" store-object-var)))
+		   (collect id-var))))
+    `(let (,@(iter
+	      (for id-var in id-vars)
+	      (for store-object-var in store-object-vars)
+	      (collect `(,id-var (store-object-id ,store-object-var)))))
+       (%reopen-store :snapshot ,snapshot)
+       (setf ,@(iter
+		(for id-var in id-vars)
+		(for store-object-var in store-object-vars)
+		(collect store-object-var)
+		(collect `(find-store-object ,id-var)))))))
+
 (def-fixture empty-store ()  
   (unwind-protect
        (progn