Changeset 2891

Timestamp:

04/07/08 16:02:47 (8 months ago)

Author:

ksprotte

Message:

merged fixes to allocate-m2s-for-sale from trunk

Files:

• branches/bos/projects/bos/m2/allocation-test.lisp (modified) (1 diff)
• branches/bos/projects/bos/m2/allocation.lisp (modified) (3 diffs)
• branches/bos/projects/bos/m2/m2.lisp (modified) (1 diff)

branches/bos/projects/bos/m2/allocation-test.lisp

@@ -92 +92 @@
-                (decf total-free size)))))))
-
+(test allocation-area.auto-activation.2
+  (with-fixture empty-store ()
+    (let* ((area1 (make-allocation-rectangle 0 0 8 8))
+           (area2 (make-allocation-rectangle 10 10 8 8))
+           (sponsor (make-sponsor :login "test-sponsor")))
+      (is (not (allocation-area-active-p area1)))
+      (is (not (allocation-area-active-p area2)))
+      (dotimes (i 4)
+        (finishes (make-contract sponsor 16 :paidp t))
+        (is (allocation-area-active-p area1))
+        (is (not (allocation-area-active-p area2))))
+      (finishes (make-contract sponsor 16 :paidp t))
+      (is (allocation-area-active-p area1))
+      (is (allocation-area-active-p area2)))))
+
+
+(test allocation-area.auto-activation.3
+  (dolist (m2-count '(1000 100))
+    (with-fixture empty-store ()
+      (let* ((area1 (make-allocation-rectangle 0 0 8 8))
+             (area2 (make-allocation-rectangle 10 10 8 8))
+             (sponsor (make-sponsor :login "test-sponsor")))
+        (is (not (allocation-area-active-p area1)))
+        (is (not (allocation-area-active-p area2)))
+        (signals error (make-contract sponsor m2-count :paidp t))
+        (is (not (allocation-area-active-p area1))
+            "allocation areas should not be activated as a side effect,
+          when someone asks for too many m2s (~d) (which will result in
+          an error)" m2-count)
+        (is (not (allocation-area-active-p area2))
+            "allocation areas should not be activated as a side effect,
+          when someone asks for too many m2s (~d) (which will result in
+          an error)" m2-count)))))
+
+(test allocation-area.auto-activation.4
+  (labels ((make-allocation-areas (widths)
+             (iter
+               (for w in widths)
+               (for pos initially 0 then (+ pos w))
+               (collect (make-allocation-rectangle pos pos w w))))
+           (request-feasible-p (n areas)
+             (some #'(lambda (area) (<= n (allocation-area-free-m2s area))) areas)))
+    (for-all ((allocation-area-widths  (gen-list :length (gen-integer :min 1 :max 5)
+                                                 :elements (gen-integer :min 1 :max 20)))
+              (n (gen-integer :min 1 :max 100)))
+      (with-fixture empty-store ()
+        (let* ((areas (make-allocation-areas allocation-area-widths))
+               (sponsor (make-sponsor :login "test-sponsor")))
+          (is (notany #'allocation-area-active-p areas))
+          (is (every #'bos.m2::allocation-area-consistent-p areas))
+          (cond
+            ((request-feasible-p n areas)
+             (finishes (make-contract sponsor n :paidp t))
+             (is (= 1 (count-if #'allocation-area-active-p areas)))
+             (is (every #'bos.m2::allocation-area-consistent-p areas)))
+            (t
+             (signals error (make-contract sponsor n :paidp t))
+             (is (notany #'allocation-area-active-p areas))
+             (is (every #'bos.m2::allocation-area-consistent-p areas)))))))))
+
+(test allocation-area.allocate-m2s-for-sale
+  (flet ((m2p (obj)
+           (typep obj 'm2)))
+    (with-fixture empty-store ()
+      (let* ((area1 (make-allocation-rectangle 0 0 8 8))
+             (area2 (make-allocation-rectangle 10 10 9 9)))
+        (for-all ((n (gen-integer :min 1 :max 60)))
+          (let ((m2s (with-transaction () (bos.m2::allocate-m2s-for-sale n))))        
+            (if (null m2s)
+                (pass)
+                (progn
+                  (is (listp m2s))
+                  (is (every #'m2p m2s))
+                  (is (= n (length m2s)))))))))))
+
+(test allocation-area.allocate-m2s-for-sale.2
+  (flet ((m2p (obj)
+           (typep obj 'm2)))
+    (for-all ((n (gen-integer :min 1 :max 290)))
+      (with-fixture empty-store ()
+        (let* ((area1 (make-allocation-rectangle 0 0 8 8))
+               (area2 (make-allocation-rectangle 10 10 9 9))
+               (m2s (with-transaction () (bos.m2::allocate-m2s-for-sale n))))
+          (if (null m2s)
+              (pass)
+              (progn
+                (is (listp m2s))
+                (is (every #'m2p m2s))
+                (is (= n (length m2s))))))))))
+
+
+

branches/bos/projects/bos/m2/allocation.lisp

@@ -183 +183 @@
-  (remove-if-not #'allocation-area-active-p (all-allocation-areas)))
-
-
-
-
-
+
+
+
+
+
-
-(deftransaction activate-allocation-area (area)
@@ -632 +633 @@
-           append (allocation-area-stripes area))))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-(defmethod return-m2s (m2s)
@@ -717 +737 @@
-             (- (stripe-y stripe) (stripe-top stripe)))
-          (* (stripe-width stripe) (stripe-height stripe))))
+
+
+(defun allocation-area-consistent-p (allocation-area)
+  (let ((total (calculate-total-m2-count allocation-area))
+        (allocated (calculate-allocated-m2-count allocation-area))
+        (consistent-p t))
+    (unless (= total (allocation-area-total-m2s allocation-area))
+      (warn "~s's total count is ~d but should be ~d"
+            allocation-area (allocation-area-total-m2s allocation-area) total)
+      (setf consistent-p nil))
+    (unless (= (- total allocated) (allocation-area-free-m2s allocation-area))
+      (warn "~s's free count is ~d but should be ~d"
+            allocation-area (allocation-area-free-m2s allocation-area) (- total allocated))
+      (setf consistent-p nil))
+    consistent-p))
+

branches/bos/projects/bos/m2/m2.lisp

@@ -381 +381 @@
-
-(deftransaction do-make-contract (sponsor m2-count &key date paidp expires download-only)
-find-free-m2s
+allocate-m2s-for-sale 
-    (if m2s
-        (let ((contract (make-object 'contract