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

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Sat Jan 19 06:57:38 2008
New Revision: 2369

Modified:
   branches/bos/projects/bos/m2/allocation-cache.lisp
   branches/bos/projects/bos/m2/allocation-test.lisp
Log:
added test allocation-area.one-contract.notany-m2-contract, which
now also passes based on new function cache-entry-valid-p
in allocation-cache.lisp


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	Sat Jan 19 06:57:38 2008
@@ -119,16 +119,43 @@
 (defstruct cache-entry
   area region)
 
-(declaim (inline index-lookup index-pop index-push size-indexed-p))
-(defun index-lookup (n)
+(defun cache-entry-valid-p (cache-entry)
+  (notany #'m2-contract (cache-entry-region cache-entry)))
+
+(declaim (inline %index-lookup %index-pop index-lookup index-pop index-push size-indexed-p))
+(defun %index-lookup (n)
   "Will return the first index cache-entry of size N or
-nil if it does not exist."
+nil if it does not exist. The entry is not validated!"
   (first (aref (allocation-cache-index *allocation-cache*) (1- n))))
 
+(defun %index-pop (n)
+  "As INDEX-LOOKUP, but will remove the cache-entry
+from the index. The entry is not validated!"
+  (pop (aref (allocation-cache-index *allocation-cache*) (1- n))))
+
+(defun index-ensure-valid-entry-for-n (n)
+  "Ensures that the next available entry (the next
+one that would be popped) is valid. If not, the entry
+is removed recursively until a valid entry is available
+or no entries for N are left."
+  (awhen (%index-lookup n)
+    (if (cache-entry-valid-p it)
+	it
+	(progn
+	  (%index-pop n)
+	  (index-ensure-valid-entry-for-n n)))))
+
+(defun index-lookup (n)
+  "Will return the first valid cache-entry of size N or
+nil if it does not exist."
+  (index-ensure-valid-entry-for-n n))
+
 (defun index-pop (n)
   "As INDEX-LOOKUP, but will remove the cache-entry
 from the index."
-  (pop (aref (allocation-cache-index *allocation-cache*) (1- n))))
+  (awhen (index-lookup n)
+    (%index-pop n)
+    it))
 
 (defun index-push (n cache-entry)
   "Add cache-entry (which has to be of size N) to index."

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	Sat Jan 19 06:57:38 2008
@@ -37,4 +37,13 @@
 	  (m2-count (* 100 100)))
       (finishes (make-contract sponsor m2-count))
       (signals (error) (make-contract sponsor m2-count))
-      (is (zerop (allocation-area-free-m2s area))))))
\ No newline at end of file
+      (is (zerop (allocation-area-free-m2s area))))))
+
+(test allocation-area.one-contract.notany-m2-contract
+  (with-fixture empty-store ()
+    (let ((area (make-allocation-rectangle 0 0 8 8))
+	  (sponsor (make-sponsor :login "test-sponsor")))
+      (finishes (make-contract sponsor 10))      
+      (is (= (- 64 10) (allocation-area-free-m2s area)))
+      (signals (error) (make-contract sponsor 64)))))
+