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))))) +