summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorSidney Congard2022-07-05 12:16:36 +0200
committerSidney Congard2022-07-05 12:16:36 +0200
commiteebedf86db68c240fe16cfd74af2cc462b0d9cf9 (patch)
treee79facc5aa78c213e224559bc4dd39442f1fab1c /tests
parentfdbbb82ff89b1d5141ec63bc2385936da3de3616 (diff)
Remove last prints, adapt JSON
Diffstat (limited to 'tests')
-rw-r--r--tests/betree/BetreeMain.Clauses.Template.fst24
-rw-r--r--tests/betree/BetreeMain.Funs.fst359
-rw-r--r--tests/betree/BetreeMain.Types.fsti12
-rw-r--r--tests/betree/Primitives.fst3
4 files changed, 203 insertions, 195 deletions
diff --git a/tests/betree/BetreeMain.Clauses.Template.fst b/tests/betree/BetreeMain.Clauses.Template.fst
index eb26276c..5a9776ab 100644
--- a/tests/betree/BetreeMain.Clauses.Template.fst
+++ b/tests/betree/BetreeMain.Clauses.Template.fst
@@ -42,18 +42,18 @@ let betree_node_apply_upserts_decreases
(key : u64) (st : state) : nat =
admit ()
-(** [betree_main::betree::Internal::{4}::lookup_in_children]: decreases clause *)
-unfold
-let betree_internal_lookup_in_children_decreases (self : betree_internal_t)
- (key : u64) (st : state) : nat =
- admit ()
-
(** [betree_main::betree::Node::{5}::lookup]: decreases clause *)
unfold
let betree_node_lookup_decreases (self : betree_node_t) (key : u64)
(st : state) : nat =
admit ()
+(** [betree_main::betree::Internal::{4}::lookup_in_children]: decreases clause *)
+unfold
+let betree_internal_lookup_in_children_decreases (self : betree_internal_t)
+ (key : u64) (st : state) : nat =
+ admit ()
+
(** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: decreases clause *)
unfold
let betree_node_lookup_mut_in_bindings_decreases (key : u64)
@@ -86,17 +86,17 @@ let betree_node_apply_messages_to_internal_decreases
(new_msgs : betree_list_t (u64 & betree_message_t)) : nat =
admit ()
-(** [betree_main::betree::Internal::{4}::flush]: decreases clause *)
+(** [betree_main::betree::Node::{5}::apply_messages]: decreases clause *)
unfold
-let betree_internal_flush_decreases (self : betree_internal_t)
+let betree_node_apply_messages_decreases (self : betree_node_t)
(params : betree_params_t) (node_id_cnt : betree_node_id_counter_t)
- (content : betree_list_t (u64 & betree_message_t)) (st : state) : nat =
+ (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : nat =
admit ()
-(** [betree_main::betree::Node::{5}::apply_messages]: decreases clause *)
+(** [betree_main::betree::Internal::{4}::flush]: decreases clause *)
unfold
-let betree_node_apply_messages_decreases (self : betree_node_t)
+let betree_internal_flush_decreases (self : betree_internal_t)
(params : betree_params_t) (node_id_cnt : betree_node_id_counter_t)
- (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : nat =
+ (content : betree_list_t (u64 & betree_message_t)) (st : state) : nat =
admit ()
diff --git a/tests/betree/BetreeMain.Funs.fst b/tests/betree/BetreeMain.Funs.fst
index 9b960ce5..4761b6a3 100644
--- a/tests/betree/BetreeMain.Funs.fst
+++ b/tests/betree/BetreeMain.Funs.fst
@@ -80,6 +80,10 @@ let betree_node_id_counter_fresh_id_back
| Return i -> Return (Mkbetree_node_id_counter_t i)
end
+(** [core::num::u64::{9}::MAX] *)
+let core_num_u64_max_body : result u64 = Return 18446744073709551615
+let core_num_u64_max_c : u64 = eval_global core_num_u64_max_body
+
(** [betree_main::betree::upsert_update] *)
let betree_upsert_update_fwd
(prev : option u64) (st : betree_upsert_fun_state_t) : result u64 =
@@ -92,16 +96,17 @@ let betree_upsert_update_fwd
| Some prev0 ->
begin match st with
| BetreeUpsertFunStateAdd v ->
- begin match u64_sub 18446744073709551615 prev0 with
+ let i = core_num_u64_max_c in
+ begin match u64_sub i prev0 with
| Fail -> Fail
| Return margin ->
if margin >= v
then
begin match u64_add prev0 v with
| Fail -> Fail
- | Return i -> Return i
+ | Return i0 -> Return i0
end
- else Return 18446744073709551615
+ else let i0 = core_num_u64_max_c in Return i0
end
| BetreeUpsertFunStateSub v ->
if prev0 >= v
@@ -468,48 +473,8 @@ let rec betree_node_apply_upserts_back
end
end
-(** [betree_main::betree::Internal::{4}::lookup_in_children] *)
-let rec betree_internal_lookup_in_children_fwd
- (self : betree_internal_t) (key : u64) (st : state) :
- Tot (result (state & (option u64)))
- (decreases (betree_internal_lookup_in_children_decreases self key st))
- =
- if key < self.betree_internal_pivot
- then
- begin match betree_node_lookup_fwd self.betree_internal_left key st with
- | Fail -> Fail
- | Return (st0, opt) -> Return (st0, opt)
- end
- else
- begin match betree_node_lookup_fwd self.betree_internal_right key st with
- | Fail -> Fail
- | Return (st0, opt) -> Return (st0, opt)
- end
-
-(** [betree_main::betree::Internal::{4}::lookup_in_children] *)
-and betree_internal_lookup_in_children_back
- (self : betree_internal_t) (key : u64) (st : state) :
- Tot (result betree_internal_t)
- (decreases (betree_internal_lookup_in_children_decreases self key st))
- =
- if key < self.betree_internal_pivot
- then
- begin match betree_node_lookup_back self.betree_internal_left key st with
- | Fail -> Fail
- | Return n ->
- Return (Mkbetree_internal_t self.betree_internal_id
- self.betree_internal_pivot n self.betree_internal_right)
- end
- else
- begin match betree_node_lookup_back self.betree_internal_right key st with
- | Fail -> Fail
- | Return n ->
- Return (Mkbetree_internal_t self.betree_internal_id
- self.betree_internal_pivot self.betree_internal_left n)
- end
-
(** [betree_main::betree::Node::{5}::lookup] *)
-and betree_node_lookup_fwd
+let rec betree_node_lookup_fwd
(self : betree_node_t) (key : u64) (st : state) :
Tot (result (state & (option u64)))
(decreases (betree_node_lookup_decreases self key st))
@@ -723,6 +688,46 @@ and betree_node_lookup_back
end
end
+(** [betree_main::betree::Internal::{4}::lookup_in_children] *)
+and betree_internal_lookup_in_children_fwd
+ (self : betree_internal_t) (key : u64) (st : state) :
+ Tot (result (state & (option u64)))
+ (decreases (betree_internal_lookup_in_children_decreases self key st))
+ =
+ if key < self.betree_internal_pivot
+ then
+ begin match betree_node_lookup_fwd self.betree_internal_left key st with
+ | Fail -> Fail
+ | Return (st0, opt) -> Return (st0, opt)
+ end
+ else
+ begin match betree_node_lookup_fwd self.betree_internal_right key st with
+ | Fail -> Fail
+ | Return (st0, opt) -> Return (st0, opt)
+ end
+
+(** [betree_main::betree::Internal::{4}::lookup_in_children] *)
+and betree_internal_lookup_in_children_back
+ (self : betree_internal_t) (key : u64) (st : state) :
+ Tot (result betree_internal_t)
+ (decreases (betree_internal_lookup_in_children_decreases self key st))
+ =
+ if key < self.betree_internal_pivot
+ then
+ begin match betree_node_lookup_back self.betree_internal_left key st with
+ | Fail -> Fail
+ | Return n ->
+ Return (Mkbetree_internal_t self.betree_internal_id
+ self.betree_internal_pivot n self.betree_internal_right)
+ end
+ else
+ begin match betree_node_lookup_back self.betree_internal_right key st with
+ | Fail -> Fail
+ | Return n ->
+ Return (Mkbetree_internal_t self.betree_internal_id
+ self.betree_internal_pivot self.betree_internal_left n)
+ end
+
(** [betree_main::betree::Node::{5}::lookup_mut_in_bindings] *)
let rec betree_node_lookup_mut_in_bindings_fwd
(key : u64) (bindings : betree_list_t (u64 & u64)) :
@@ -1128,140 +1133,8 @@ let rec betree_node_apply_messages_to_internal_fwd_back
| BetreeListNil -> Return msgs
end
-(** [betree_main::betree::Internal::{4}::flush] *)
-let rec betree_internal_flush_fwd
- (self : betree_internal_t) (params : betree_params_t)
- (node_id_cnt : betree_node_id_counter_t)
- (content : betree_list_t (u64 & betree_message_t)) (st : state) :
- Tot (result (state & (betree_list_t (u64 & betree_message_t))))
- (decreases (betree_internal_flush_decreases self params node_id_cnt content
- st))
- =
- begin match
- betree_list_partition_at_pivot_fwd betree_message_t content
- self.betree_internal_pivot with
- | Fail -> Fail
- | Return p ->
- let (msgs_left, msgs_right) = p in
- begin match betree_list_len_fwd (u64 & betree_message_t) msgs_left with
- | Fail -> Fail
- | Return len_left ->
- if len_left >= params.betree_params_min_flush_size
- then
- begin match
- betree_node_apply_messages_fwd self.betree_internal_left params
- node_id_cnt msgs_left st with
- | Fail -> Fail
- | Return (st0, _) ->
- begin match
- betree_node_apply_messages_back self.betree_internal_left params
- node_id_cnt msgs_left st with
- | Fail -> Fail
- | Return (_, node_id_cnt0) ->
- begin match betree_list_len_fwd (u64 & betree_message_t) msgs_right
- with
- | Fail -> Fail
- | Return len_right ->
- if len_right >= params.betree_params_min_flush_size
- then
- begin match
- betree_node_apply_messages_fwd self.betree_internal_right
- params node_id_cnt0 msgs_right st0 with
- | Fail -> Fail
- | Return (st1, _) ->
- begin match
- betree_node_apply_messages_back self.betree_internal_right
- params node_id_cnt0 msgs_right st0 with
- | Fail -> Fail
- | Return (_, _) -> Return (st1, BetreeListNil)
- end
- end
- else Return (st0, msgs_right)
- end
- end
- end
- else
- begin match
- betree_node_apply_messages_fwd self.betree_internal_right params
- node_id_cnt msgs_right st with
- | Fail -> Fail
- | Return (st0, _) ->
- begin match
- betree_node_apply_messages_back self.betree_internal_right params
- node_id_cnt msgs_right st with
- | Fail -> Fail
- | Return (_, _) -> Return (st0, msgs_left)
- end
- end
- end
- end
-
-(** [betree_main::betree::Internal::{4}::flush] *)
-and betree_internal_flush_back
- (self : betree_internal_t) (params : betree_params_t)
- (node_id_cnt : betree_node_id_counter_t)
- (content : betree_list_t (u64 & betree_message_t)) (st : state) :
- Tot (result (betree_internal_t & betree_node_id_counter_t))
- (decreases (betree_internal_flush_decreases self params node_id_cnt content
- st))
- =
- begin match
- betree_list_partition_at_pivot_fwd betree_message_t content
- self.betree_internal_pivot with
- | Fail -> Fail
- | Return p ->
- let (msgs_left, msgs_right) = p in
- begin match betree_list_len_fwd (u64 & betree_message_t) msgs_left with
- | Fail -> Fail
- | Return len_left ->
- if len_left >= params.betree_params_min_flush_size
- then
- begin match
- betree_node_apply_messages_fwd self.betree_internal_left params
- node_id_cnt msgs_left st with
- | Fail -> Fail
- | Return (st0, _) ->
- begin match
- betree_node_apply_messages_back self.betree_internal_left params
- node_id_cnt msgs_left st with
- | Fail -> Fail
- | Return (n, node_id_cnt0) ->
- begin match betree_list_len_fwd (u64 & betree_message_t) msgs_right
- with
- | Fail -> Fail
- | Return len_right ->
- if len_right >= params.betree_params_min_flush_size
- then
- begin match
- betree_node_apply_messages_back self.betree_internal_right
- params node_id_cnt0 msgs_right st0 with
- | Fail -> Fail
- | Return (n0, node_id_cnt1) ->
- Return (Mkbetree_internal_t self.betree_internal_id
- self.betree_internal_pivot n n0, node_id_cnt1)
- end
- else
- Return (Mkbetree_internal_t self.betree_internal_id
- self.betree_internal_pivot n self.betree_internal_right,
- node_id_cnt0)
- end
- end
- end
- else
- begin match
- betree_node_apply_messages_back self.betree_internal_right params
- node_id_cnt msgs_right st with
- | Fail -> Fail
- | Return (n, node_id_cnt0) ->
- Return (Mkbetree_internal_t self.betree_internal_id
- self.betree_internal_pivot self.betree_internal_left n,
- node_id_cnt0)
- end
- end
- end
-
(** [betree_main::betree::Node::{5}::apply_messages] *)
-and betree_node_apply_messages_fwd
+let rec betree_node_apply_messages_fwd
(self : betree_node_t) (params : betree_params_t)
(node_id_cnt : betree_node_id_counter_t)
(msgs : betree_list_t (u64 & betree_message_t)) (st : state) :
@@ -1450,6 +1323,138 @@ and betree_node_apply_messages_back
end
end
+(** [betree_main::betree::Internal::{4}::flush] *)
+and betree_internal_flush_fwd
+ (self : betree_internal_t) (params : betree_params_t)
+ (node_id_cnt : betree_node_id_counter_t)
+ (content : betree_list_t (u64 & betree_message_t)) (st : state) :
+ Tot (result (state & (betree_list_t (u64 & betree_message_t))))
+ (decreases (betree_internal_flush_decreases self params node_id_cnt content
+ st))
+ =
+ begin match
+ betree_list_partition_at_pivot_fwd betree_message_t content
+ self.betree_internal_pivot with
+ | Fail -> Fail
+ | Return p ->
+ let (msgs_left, msgs_right) = p in
+ begin match betree_list_len_fwd (u64 & betree_message_t) msgs_left with
+ | Fail -> Fail
+ | Return len_left ->
+ if len_left >= params.betree_params_min_flush_size
+ then
+ begin match
+ betree_node_apply_messages_fwd self.betree_internal_left params
+ node_id_cnt msgs_left st with
+ | Fail -> Fail
+ | Return (st0, _) ->
+ begin match
+ betree_node_apply_messages_back self.betree_internal_left params
+ node_id_cnt msgs_left st with
+ | Fail -> Fail
+ | Return (_, node_id_cnt0) ->
+ begin match betree_list_len_fwd (u64 & betree_message_t) msgs_right
+ with
+ | Fail -> Fail
+ | Return len_right ->
+ if len_right >= params.betree_params_min_flush_size
+ then
+ begin match
+ betree_node_apply_messages_fwd self.betree_internal_right
+ params node_id_cnt0 msgs_right st0 with
+ | Fail -> Fail
+ | Return (st1, _) ->
+ begin match
+ betree_node_apply_messages_back self.betree_internal_right
+ params node_id_cnt0 msgs_right st0 with
+ | Fail -> Fail
+ | Return (_, _) -> Return (st1, BetreeListNil)
+ end
+ end
+ else Return (st0, msgs_right)
+ end
+ end
+ end
+ else
+ begin match
+ betree_node_apply_messages_fwd self.betree_internal_right params
+ node_id_cnt msgs_right st with
+ | Fail -> Fail
+ | Return (st0, _) ->
+ begin match
+ betree_node_apply_messages_back self.betree_internal_right params
+ node_id_cnt msgs_right st with
+ | Fail -> Fail
+ | Return (_, _) -> Return (st0, msgs_left)
+ end
+ end
+ end
+ end
+
+(** [betree_main::betree::Internal::{4}::flush] *)
+and betree_internal_flush_back
+ (self : betree_internal_t) (params : betree_params_t)
+ (node_id_cnt : betree_node_id_counter_t)
+ (content : betree_list_t (u64 & betree_message_t)) (st : state) :
+ Tot (result (betree_internal_t & betree_node_id_counter_t))
+ (decreases (betree_internal_flush_decreases self params node_id_cnt content
+ st))
+ =
+ begin match
+ betree_list_partition_at_pivot_fwd betree_message_t content
+ self.betree_internal_pivot with
+ | Fail -> Fail
+ | Return p ->
+ let (msgs_left, msgs_right) = p in
+ begin match betree_list_len_fwd (u64 & betree_message_t) msgs_left with
+ | Fail -> Fail
+ | Return len_left ->
+ if len_left >= params.betree_params_min_flush_size
+ then
+ begin match
+ betree_node_apply_messages_fwd self.betree_internal_left params
+ node_id_cnt msgs_left st with
+ | Fail -> Fail
+ | Return (st0, _) ->
+ begin match
+ betree_node_apply_messages_back self.betree_internal_left params
+ node_id_cnt msgs_left st with
+ | Fail -> Fail
+ | Return (n, node_id_cnt0) ->
+ begin match betree_list_len_fwd (u64 & betree_message_t) msgs_right
+ with
+ | Fail -> Fail
+ | Return len_right ->
+ if len_right >= params.betree_params_min_flush_size
+ then
+ begin match
+ betree_node_apply_messages_back self.betree_internal_right
+ params node_id_cnt0 msgs_right st0 with
+ | Fail -> Fail
+ | Return (n0, node_id_cnt1) ->
+ Return (Mkbetree_internal_t self.betree_internal_id
+ self.betree_internal_pivot n n0, node_id_cnt1)
+ end
+ else
+ Return (Mkbetree_internal_t self.betree_internal_id
+ self.betree_internal_pivot n self.betree_internal_right,
+ node_id_cnt0)
+ end
+ end
+ end
+ else
+ begin match
+ betree_node_apply_messages_back self.betree_internal_right params
+ node_id_cnt msgs_right st with
+ | Fail -> Fail
+ | Return (n, node_id_cnt0) ->
+ Return (Mkbetree_internal_t self.betree_internal_id
+ self.betree_internal_pivot self.betree_internal_left n,
+ node_id_cnt0)
+ end
+ end
+ end
+
(** [betree_main::betree::Node::{5}::apply] *)
let betree_node_apply_fwd
(self : betree_node_t) (params : betree_params_t)
diff --git a/tests/betree/BetreeMain.Types.fsti b/tests/betree/BetreeMain.Types.fsti
index a937c726..aad9cb43 100644
--- a/tests/betree/BetreeMain.Types.fsti
+++ b/tests/betree/BetreeMain.Types.fsti
@@ -24,8 +24,13 @@ type betree_message_t =
(** [betree_main::betree::Leaf] *)
type betree_leaf_t = { betree_leaf_id : u64; betree_leaf_size : u64; }
+(** [betree_main::betree::Node] *)
+type betree_node_t =
+| BetreeNodeInternal : betree_internal_t -> betree_node_t
+| BetreeNodeLeaf : betree_leaf_t -> betree_node_t
+
(** [betree_main::betree::Internal] *)
-type betree_internal_t =
+and betree_internal_t =
{
betree_internal_id : u64;
betree_internal_pivot : u64;
@@ -33,11 +38,6 @@ type betree_internal_t =
betree_internal_right : betree_node_t;
}
-(** [betree_main::betree::Node] *)
-and betree_node_t =
-| BetreeNodeInternal : betree_internal_t -> betree_node_t
-| BetreeNodeLeaf : betree_leaf_t -> betree_node_t
-
(** [betree_main::betree::Params] *)
type betree_params_t =
{
diff --git a/tests/betree/Primitives.fst b/tests/betree/Primitives.fst
index fe351f3a..b3da25c2 100644
--- a/tests/betree/Primitives.fst
+++ b/tests/betree/Primitives.fst
@@ -34,6 +34,9 @@ let bind (#a #b : Type0) (m : result a) (f : a -> result b) : result b =
// Monadic assert(...)
let massert (b:bool) : result unit = if b then Return () else Fail
+// Unwrap a successful result by normalisation (used for globals).
+let eval_global (#a : Type0) (x : result a{Return? (normalize_term x)}) : a = Return?.v x
+
(*** Misc *)
type char = FStar.Char.char
type string = string