[bknr-cvs] r2361 - in branches/bos/projects/bos: m2 test

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Fri Jan 18 13:25:24 2008
New Revision: 2361

Modified:
   branches/bos/projects/bos/m2/allocation-cache.lisp
   branches/bos/projects/bos/m2/packages.lisp
   branches/bos/projects/bos/test/allocation-area.lisp
Log:
all tests pass!!

Modified: branches/bos/projects/bos/m2/allocation-cache.lisp
==============================================================================
--- branches/bos/projects/bos/m2/allocation-cache.lisp	(original)
+++ branches/bos/projects/bos/m2/allocation-cache.lisp	Fri Jan 18 13:25:24 2008
@@ -104,6 +104,8 @@
 	  (in top (collect region)))))))
 
 ;;; allocation-cache
+(defvar *allocation-cache*)
+
 (defconstant +threshold+ 200
   "Free regions of size N where (<= 1 N +threshold+) are indexed.")
 
@@ -114,22 +116,23 @@
 (defun make-allocation-cache ()
   (make-instance 'allocation-cache))
 
-(defvar *allocation-cache*)
+(defstruct cache-entry
+  area region)
 
 (declaim (inline index-lookup index-pop index-push size-indexed-p))
 (defun index-lookup (n)
-  "Will return the first index region of size N or
+  "Will return the first index cache-entry of size N or
 nil if it does not exist."
   (first (aref (allocation-cache-index *allocation-cache*) (1- n))))
 
 (defun index-pop (n)
-  "As INDEX-LOOKUP, but will remove the region
+  "As INDEX-LOOKUP, but will remove the cache-entry
 from the index."
   (pop (aref (allocation-cache-index *allocation-cache*) (1- n))))
 
-(defun index-push (n region)
-  "Add region (which has to be of size N) to index."
-  (push region (aref (allocation-cache-index *allocation-cache*) (1- n))))
+(defun index-push (n cache-entry)
+  "Add cache-entry (which has to be of size N) to index."
+  (push cache-entry (aref (allocation-cache-index *allocation-cache*) (1- n))))
 
 (defun size-indexed-p (n)
   "Are regions of size N indexed?"
@@ -141,18 +144,27 @@
 matching N can be found, simply returns NIL.
 
 If REMOVE is T then the returned region is removed from
-the cache."
+the cache and FREE-M2S of the affected allocation-area
+is decremented."
   (cond
     ((not (size-indexed-p n)) nil)
-    (remove (index-pop n))
-    (t (index-lookup n))))
+    (remove (let ((cache-entry (index-pop n)))
+	      (when cache-entry
+		(with-slots (area region)
+		    cache-entry
+		  (decf (allocation-area-free-m2s area) n)
+		  region))))
+    (t (let ((cache-entry (index-lookup n)))
+	 (when cache-entry
+	   (cache-entry-region cache-entry))))))
 
 (defun add-area (allocation-area)
   (dolist (region (free-regions allocation-area)
 	   allocation-area)
     (let ((size (length region)))
       (if (size-indexed-p size)
-	  (index-push size region)
+	  (index-push size (make-cache-entry :area allocation-area
+					     :region region))
 	  (incf (ignored-size *allocation-cache*) size)))))
 
 (defun free-regions-count ()

Modified: branches/bos/projects/bos/m2/packages.lisp
==============================================================================
--- branches/bos/projects/bos/m2/packages.lisp	(original)
+++ branches/bos/projects/bos/m2/packages.lisp	Fri Jan 18 13:25:24 2008
@@ -227,7 +227,8 @@
 	:bknr.rss
 	:bos.m2	
 	:bos.m2.config	
-	:iterate)
+	:iterate
+	:arnesi)
   (:import-from :bos.m2 bos.m2::point-in-polygon-p)
   (:export #:find-exact-match
 	   #:add-area

Modified: branches/bos/projects/bos/test/allocation-area.lisp
==============================================================================
--- branches/bos/projects/bos/test/allocation-area.lisp	(original)
+++ branches/bos/projects/bos/test/allocation-area.lisp	Fri Jan 18 13:25:24 2008
@@ -18,11 +18,15 @@
       (finishes (make-contract sponsor m2-count))
       (is (= (- (* 100 100) m2-count) (allocation-area-free-m2s area))))))
 
-(test allocation-area.one-contract.with-cache
+(test allocation-area.one-contract.with-cache.1
   (with-fixture empty-store ()
     (let ((area (make-allocation-rectangle 0 0 2 5))
 	  (sponsor (make-sponsor :login "test-sponsor"))
 	  (m2-count 10))
+      (with-transaction ()
+	(bos.m2::activate-allocation-area area))
+      (is (= 1 (bos.m2.allocation-cache:free-regions-count)))
+      (is-true (bos.m2.allocation-cache:find-exact-match 10))
       (finishes (make-contract sponsor m2-count))
       (is (zerop (allocation-area-free-m2s area))))))