diff --git a/Gillian-C/lib/Constr.ml b/Gillian-C/lib/Constr.ml index e630e942..979a04b6 100644 --- a/Gillian-C/lib/Constr.ml +++ b/Gillian-C/lib/Constr.ml @@ -3,7 +3,7 @@ open Gil_syntax module Core = struct let pred ga ins outs = let ga_name = LActions.str_ga ga in - Asrt.GA (ga_name, ins, outs) + Asrt.CorePred (ga_name, ins, outs) let single ~loc ~ofs ~chunk ~sval ~perm = let chunk = Expr.Lit (String (ValueTranslation.string_of_chunk chunk)) in diff --git a/Gillian-C/lib/MonadicSMemory.ml b/Gillian-C/lib/MonadicSMemory.ml index 8cbb2d1a..1a0928d4 100644 --- a/Gillian-C/lib/MonadicSMemory.ml +++ b/Gillian-C/lib/MonadicSMemory.ml @@ -24,7 +24,7 @@ let resolve_or_create_loc_name (lvar_loc : Expr.t) : string Delayed.t = match loc_name with | None -> let new_loc_name = ALoc.alloc () in - let learned = [ Formula.Eq (ALoc new_loc_name, lvar_loc) ] in + let learned = [ Expr.BinOp (ALoc new_loc_name, Equal, lvar_loc) ] in Logging.verbose (fun fmt -> fmt "Couldn't resolve loc %a, created %s" Expr.pp lvar_loc new_loc_name); @@ -175,8 +175,8 @@ module Mem = struct let cons_array map loc ofs size chunk = let open DR.Syntax in let** loc_name = resolve_loc_result loc in - let open Formula.Infix in - if%sat size #<= (Expr.int 0) then + let open Expr.Infix in + if%sat size <= Expr.int 0 then DR.ok (map, MonadicSVal.SVArray.empty, Some Perm.Freeable) else let** tree = get_tree_res map loc_name (Some ofs) (Some chunk) in @@ -187,8 +187,8 @@ module Mem = struct let prod_array map loc ofs size chunk array perm = let open DR.Syntax in - let open Formula.Infix in - if%sat size #<= (Expr.int 0) then DR.ok map + let open Expr.Infix in + if%sat size <= Expr.int 0 then DR.ok map else let* loc_name = resolve_or_create_loc_name loc in let* tree = get_or_create_tree map loc_name in @@ -213,9 +213,9 @@ module Mem = struct let cons_simple ~sheap_consumer map loc low high = let open DR.Syntax in - let open Formula.Infix in + let open Expr.Infix in let** loc_name = resolve_loc_result loc in - if%sat high #<= low then DR.ok (map, Some Perm.Freeable) + if%sat high <= low then DR.ok (map, Some Perm.Freeable) else let** tree = get_tree_res map loc_name None None in let++ new_tree, perm = @@ -225,8 +225,8 @@ module Mem = struct let prod_simple ~sheap_producer map loc low high perm = let open DR.Syntax in - let open Formula.Infix in - if%sat high #<= low then DR.ok map + let open Expr.Infix in + if%sat high <= low then DR.ok map else let* loc_name = resolve_or_create_loc_name loc in let* tree = get_or_create_tree map loc_name in @@ -256,7 +256,7 @@ module Mem = struct let prod_bounds map loc bounds = let open DR.Syntax in - let** loc_name = resolve_loc_result loc in + let* loc_name = resolve_or_create_loc_name loc in let* tree = get_or_create_tree map loc_name in let++ tree_set = SHeapTree.prod_bounds tree bounds |> DR.of_result |> map_lift_err loc_name @@ -265,8 +265,8 @@ module Mem = struct let move map dst_loc dst_ofs src_loc src_ofs sz = let open DR.Syntax in - let open Formula.Infix in - if%sat sz #== (Expr.int 0) then DR.ok map + let open Expr.Infix in + if%sat sz == Expr.int 0 then DR.ok map else let** dst_loc_name = resolve_loc_result dst_loc in let** src_loc_name = resolve_loc_result src_loc in @@ -525,7 +525,7 @@ let execute_prod_single heap params = ] -> let perm = ValueTranslation.permission_of_string perm_string in let chunk = ValueTranslation.chunk_of_string chunk_string in - let* sval = SVal.of_gil_expr_exn sval_e in + let* sval = SVal.of_gil_expr_vanish sval_e in let++ mem = Mem.prod_single heap.mem loc ofs chunk sval perm in { heap with mem } | _ -> fail_ungracefully "set_single" params @@ -955,7 +955,7 @@ let get_fixes err = | InvalidLocation loc -> let new_loc = ALoc.alloc () in let new_expr = Expr.ALoc new_loc in - [ [ Asrt.Pure (Eq (new_expr, loc)) ] ] + [ [ Asrt.Pure (BinOp (new_expr, Equal, loc)) ] ] | SHeapTreeErr { at_locations; diff --git a/Gillian-C/lib/MonadicSVal.ml b/Gillian-C/lib/MonadicSVal.ml index 32d3bcf1..12850bc9 100644 --- a/Gillian-C/lib/MonadicSVal.ml +++ b/Gillian-C/lib/MonadicSVal.ml @@ -8,38 +8,38 @@ module DR = Delayed_result exception NotACompCertValue of Expr.t module Patterns = struct - open Formula.Infix + open Expr.Infix let number e = let open Expr in - (typeof e) #== (type_ NumberType) + typeof e == type_ NumberType let integer e = let open Expr in - (typeof e) #== (type_ IntType) + typeof e == type_ IntType let int_typ, float_typ, single_typ, long_typ = let open Expr in let open CConstants.VTypes in let num_typ int_t typ_str x = - (typeof x) #== (type_ ListType) - #&& ((list_length x) #== (int 2)) - #&& ((list_nth x 0) #== (string typ_str)) - #&& ((typeof (list_nth x 1)) #== (type_ int_t)) + typeof x == type_ ListType + && list_length x == int 2 + && list_nth x 0 == string typ_str + && typeof (list_nth x 1) == type_ int_t in ( num_typ IntType int_type, num_typ NumberType float_type, num_typ NumberType single_type, num_typ IntType long_type ) - let undefined x = x #== (Expr.Lit Undefined) + let undefined x = x == Expr.Lit Undefined let obj x = let open Expr in - (typeof x) #== (type_ ListType) - #&& ((list_length x) #== (int 2)) - #&& ((typeof (list_nth x 0)) #== (type_ ObjectType)) - #&& ((typeof (list_nth x 1)) #== (type_ IntType)) + typeof x == type_ ListType + && list_length x == int 2 + && typeof (list_nth x 0) == type_ ObjectType + && typeof (list_nth x 1) == type_ IntType end let of_chunk_and_expr chunk e = @@ -72,11 +72,11 @@ let of_chunk_and_expr chunk e = Expr.pp e)) | Tlong -> return (SVlong e) | Tint -> - let open Formula.Infix in + let open Expr.Infix in let i k = Expr.int k in let learned = match chunk with - | Mint8unsigned -> [ (i 0) #<= e; e #<= (i 255) ] + | Mint8unsigned -> [ i 0 <= e; e <= i 255 ] | _ -> [] in return ~learned (SVint e) @@ -85,13 +85,13 @@ let of_chunk_and_expr chunk e = | Tany32 | Tany64 -> Fmt.failwith "Unhandled chunk: %a" Chunk.pp chunk) let of_gil_expr sval_e = - let open Formula.Infix in + let open Expr.Infix in let open Patterns in Logging.verbose (fun fmt -> fmt "OF_GIL_EXPR : %a" Expr.pp sval_e); let* sval_e = Delayed.reduce sval_e in - match%ent sval_e with - | undefined -> DO.some SUndefined - | obj -> + if%sat undefined sval_e then DO.some SUndefined + else + if%sat obj sval_e then let loc_expr = Expr.list_nth sval_e 0 in let ofs = Expr.list_nth sval_e 1 in let* ofs = Delayed.reduce ofs in @@ -101,15 +101,20 @@ let of_gil_expr sval_e = | Some l -> (l, []) | None -> let aloc = ALoc.alloc () in - let learned = [ loc_expr #== (ALoc aloc) ] in + let learned = [ loc_expr == ALoc aloc ] in (aloc, learned) in DO.some ~learned (Sptr (loc, ofs)) - | int_typ -> DO.some (SVint (Expr.list_nth sval_e 1)) - | float_typ -> DO.some (SVfloat (Expr.list_nth sval_e 1)) - | long_typ -> DO.some (SVlong (Expr.list_nth sval_e 1)) - | single_typ -> DO.some (SVsingle (Expr.list_nth sval_e 1)) - | _ -> DO.none () + else + if%sat int_typ sval_e then DO.some (SVint (Expr.list_nth sval_e 1)) + else + if%sat float_typ sval_e then DO.some (SVfloat (Expr.list_nth sval_e 1)) + else + if%sat long_typ sval_e then DO.some (SVlong (Expr.list_nth sval_e 1)) + else + if%sat single_typ sval_e then + DO.some (SVsingle (Expr.list_nth sval_e 1)) + else DO.none () let of_gil_expr_exn sval_e = let* value_opt = of_gil_expr sval_e in @@ -119,6 +124,12 @@ let of_gil_expr_exn sval_e = if !Gillian.Utils.Config.under_approximation then Delayed.vanish () else raise (NotACompCertValue sval_e) +let of_gil_expr_vanish sval_e = + let* value_opt = of_gil_expr sval_e in + match value_opt with + | Some value -> Delayed.return value + | None -> Delayed.vanish () + let to_gil_expr_undelayed = to_gil_expr let to_gil_expr sval = @@ -127,8 +138,8 @@ let to_gil_expr sval = List.map (fun (e, t) -> let open Expr in - let open Formula.Infix in - (typeof e) #== (type_ t)) + let open Expr.Infix in + typeof e == type_ t) typings in Delayed.return ~learned:typing_pfs exp @@ -163,10 +174,10 @@ module SVArray = struct let empty = Arr (EList []) let is_empty = - let open Formula.Infix in + let open Expr.Infix in function - | Arr e -> (Expr.list_length e) #== (Expr.int 0) - | _ -> False + | Arr e -> Expr.list_length e == Expr.int 0 + | _ -> Expr.false_ let sure_is_all_zeros = function | Arr (EList l) -> @@ -194,8 +205,8 @@ module SVArray = struct in let learned = List.map - (let open Formula.Infix in - fun (e, t) -> (Expr.typeof e) #== (Expr.type_ t)) + (let open Expr.Infix in + fun (e, t) -> Expr.typeof e == Expr.type_ t) gamma in (Expr.EList (List.rev rev_l), learned) @@ -210,7 +221,7 @@ module SVArray = struct | None -> Expr.list_length arr_exp | Some size -> size in - let open Formula.Infix in + let open Expr.Infix in let zero = Expr.int 0 in let size = Engine.Reduction.reduce_lexpr size in match size with @@ -220,7 +231,7 @@ module SVArray = struct let undefs = Expr.Lit (LList (List.init (Z.to_int x) (fun _ -> Literal.Undefined))) in - arr_exp #== undefs + arr_exp == undefs | _ -> Logging.verbose (fun fmt -> fmt "Undefined pf: not as concrete: %a" Expr.pp size); @@ -228,8 +239,8 @@ module SVArray = struct let i_e = Expr.LVar i in forall [ (i, Some IntType) ] - zero #<= i_e #&& (i_e #< size) - #=> ((Expr.list_nth_e arr_exp i_e) #== (Lit Undefined)) + ((zero <= i_e && i_e < size) + ==> (Expr.list_nth_e arr_exp i_e == Lit Undefined)) let zeros_pf ?size arr_exp = let size = @@ -237,7 +248,7 @@ module SVArray = struct | None -> Expr.list_length arr_exp | Some size -> size in - let open Formula.Infix in + let open Expr.Infix in let size = Engine.Reduction.reduce_lexpr size in match size with | Lit (Int x) -> @@ -246,26 +257,24 @@ module SVArray = struct Expr.Lit (LList (List.init (Z.to_int x) (fun _ -> Literal.Int Z.zero))) in - arr_exp #== zeros + arr_exp == zeros | _ -> Logging.verbose (fun fmt -> fmt "Zeros pf: not as concrete: %a" Expr.pp size); - let is_zero e = e #== (Expr.int 0) in let i = LVar.alloc () in let i_e = Expr.LVar i in let zero = Expr.int 0 in forall [ (i, Some IntType) ] - zero #<= i_e #&& (i_e #< size) - #=> (is_zero (Expr.list_nth_e arr_exp i_e)) + ((zero <= i_e && i_e < size) ==> (Expr.list_nth_e arr_exp i_e == zero)) let to_arr_with_size arr s = - let open Formula.Infix in - let allocate_array_lvar (descr : ?size:Expr.t -> Expr.t -> Formula.t) = + let open Expr.Infix in + let allocate_array_lvar (descr : ?size:Expr.t -> Expr.t -> Expr.t) = let x = LVar.alloc () in let learned_types = [ (x, Gil_syntax.Type.ListType) ] in let x = Expr.LVar x in - let learned = [ (Expr.list_length x) #== s; descr ~size:s x ] in + let learned = [ Expr.list_length x == s; descr ~size:s x ] in Delayed.return ~learned ~learned_types x in match arr with @@ -332,14 +341,14 @@ module SVArray = struct | Lit (Int n) -> (Expr.EList (Utils.List_utils.make (Z.to_int n) concrete_single), []) | _ -> - let open Formula.Infix in + let open Expr.Infix in let arr = LVar.alloc () in let arr_e = Expr.LVar arr in let learned = let open Expr in [ - (typeof arr_e) #== (type_ ListType); - (list_length arr_e) #== size; + typeof arr_e == type_ ListType; + list_length arr_e == size; describing_pf arr_e; ] in @@ -347,12 +356,9 @@ module SVArray = struct in match svarr with | Arr e -> - let open Formula.Infix in + let open Expr.Infix in let learned = - [ - (Expr.typeof e) #== (Expr.type_ ListType); - (Expr.list_length e) #== size; - ] + [ Expr.typeof e == Expr.type_ ListType; Expr.list_length e == size ] in (e, learned) | AllZeros -> @@ -387,8 +393,8 @@ module SVArray = struct (function | Expr.Lit Undefined -> [] | x -> - let open Formula.Infix in - [ (i low) #<= x; x #<= (i high) ]) + let open Expr.Infix in + [ i low <= x; x <= i high ]) e in Delayed.return ~learned () @@ -400,8 +406,8 @@ module SVArray = struct List.concat (List.init (Z.to_int n) (fun k -> let x = Expr.list_nth e k in - let open Formula.Infix in - [ (i low) #<= x; x #<= (i high) ])) + let open Expr.Infix in + [ i low <= x; x <= i high ])) in Delayed.return ~learned () | _ -> Delayed.return ()) diff --git a/Gillian-C/lib/SHeapTree.ml b/Gillian-C/lib/SHeapTree.ml index 2e1698b2..76657b09 100644 --- a/Gillian-C/lib/SHeapTree.ml +++ b/Gillian-C/lib/SHeapTree.ml @@ -87,18 +87,18 @@ module Range = struct (low, low + (sz_chunk * size)) let is_equal (la, ha) (lb, hb) = - let open Formula.Infix in - la #== lb #&& (ha #== hb) + let open Expr.Infix in + la == lb && ha == hb let is_inside (la, ha) (lb, hb) = - let open Formula.Infix in - lb #<= la #&& (ha #<= hb) + let open Expr.Infix in + lb <= la && ha <= hb let size (a, b) = Expr.Infix.( - ) b a let point_strictly_inside x (l, h) = - let open Formula.Infix in - l #< x #&& (x #< h) + let open Expr.Infix in + l < x && x < h let split_at (l, h) x = ((l, x), (x, h)) let lvars (a, b) = SS.union (Expr.lvars a) (Expr.lvars b) @@ -326,9 +326,8 @@ module Node = struct | Arr e -> let two_pow_8 i = Int.shift_left 1 (8 * i) in let open Expr.Infix in - let open Formula.Infix in (* FIXME: This assumes big endian *) - if%sat (Expr.list_length e) #== (Expr.int size) then + if%sat Expr.list_length e == Expr.int size then let bytes = List.init size (fun i -> Expr.list_nth e i) in let _, v = List.fold_left @@ -341,8 +340,7 @@ module Node = struct List.filter_map (function | Expr.Lit Undefined -> None - | byte -> - Some byte #>= (Expr.int 0) #&& (byte #<= (Expr.int 255))) + | byte -> Some (byte >= Expr.int 0 && byte <= Expr.int 255)) bytes in let* v = SVal.of_chunk_and_expr chunk v in @@ -655,14 +653,14 @@ module Tree = struct let rec split ~range t : (Node.t * t * t) Delayed.t = (* this function splits a tree and returns the node in the given range *) (* We're assuming that range is inside old_span *) - let open Formula.Infix in + let open Expr.Infix in let open Delayed.Syntax in let old_span = t.span in let ol, oh = old_span in let nl, nh = range in if%sat - log_string "ol #== nl"; - ol #== nl + log_string "ol == nl"; + ol == nl then let at = nh in let* left_node, right_node = Node.split ~span:old_span ~at t.node in @@ -672,8 +670,8 @@ module Tree = struct Delayed.return (left_node, left, right) else if%sat - log_string "oh #== nh"; - oh #== nh + log_string "oh == nh"; + oh == nh then let at = nl in let* left_node, right_node = Node.split ~span:old_span ~at t.node in @@ -694,12 +692,12 @@ module Tree = struct Delayed.return (node, left, right) let extend_if_needed t range = - let open Formula.Infix in + let open Expr.Infix in let open Delayed.Syntax in let rl, rh = range in let sl, sh = t.span in let* t_with_left = - if%sat rl #< sl then + if%sat rl < sl then let new_left_tree = make ~node:(NotOwned Totally) ~span:(rl, sl) () in let children = (new_left_tree, t) in Delayed.return @@ -708,7 +706,7 @@ module Tree = struct in let sl, _ = t_with_left.span in let* result = - if%sat rh #> sh then + if%sat rh > sh then let new_right_tree = make ~node:(NotOwned Totally) ~span:(sh, rh) () in let children = (t_with_left, new_right_tree) in Delayed.return @@ -1062,8 +1060,8 @@ module Tree = struct let sval, types = NSVal.to_gil_expr value in let types = List.map - (let open Formula.Infix in - fun (x, t) -> Asrt.Pure (Expr.typeof x) #== (Expr.type_ t)) + (let open Expr.Infix in + fun (x, t) -> Asrt.Pure (Expr.typeof x == Expr.type_ t)) types in CoreP.single ~loc ~ofs:low ~chunk ~sval ~perm :: types @@ -1169,7 +1167,7 @@ let alocs = function let is_in_bounds range bounds = match bounds with - | None -> Formula.True + | None -> Expr.true_ | Some bounds -> Range.is_inside range bounds let get_perm_at t ofs = @@ -1191,10 +1189,10 @@ let get_perm_at t ofs = let weak_valid_pointer (t : t) (ofs : Expr.t) : (bool, err) DR.t = let is_sure_false bounds ofs = - let open Formula.Infix in + let open Expr.Infix in match bounds with - | None -> Formula.False - | Some (low, high) -> ofs #< low #|| (ofs #> high) + | None -> Expr.false_ + | Some (low, high) -> ofs < low || ofs > high in match t with | Freed -> DR.ok false @@ -1405,8 +1403,8 @@ let _check_valid_alignment chunk ofs = let al = Chunk.align chunk in let al_expr = Expr.int al in let divides x y = - let open Formula.Infix in - Expr.(y #== (int 0)) #|| ((Expr.imod y x) #== (Expr.int 0)) + let open Expr.Infix in + Expr.(y == zero_i || imod y x == zero_i) in if%sat divides al_expr ofs then DR.ok () else DR.error (InvalidAlignment { offset = ofs; alignment = al }) diff --git a/Gillian-C/lib/SHeapTree.mli b/Gillian-C/lib/SHeapTree.mli index 2936bfb9..230f1a5a 100644 --- a/Gillian-C/lib/SHeapTree.mli +++ b/Gillian-C/lib/SHeapTree.mli @@ -85,7 +85,7 @@ val allocated_function : t [dst_tree] after modification *) val move : t -> Expr.t -> t -> Expr.t -> Expr.t -> t d_or_error -val assertions : loc:string -> t -> Asrt.t list +val assertions : loc:string -> t -> Asrt.t val substitution : le_subst:(Expr.t -> Expr.t) -> diff --git a/Gillian-C/lib/SVal.ml b/Gillian-C/lib/SVal.ml index fbf64662..b70db48e 100644 --- a/Gillian-C/lib/SVal.ml +++ b/Gillian-C/lib/SVal.ml @@ -75,11 +75,11 @@ let of_gil_expr_almost_concrete ?(gamma = Type_env.init ()) gexpr = Some (Sptr (loc, offset), []) | EList [ LVar loc; Lit (Int k) ] -> let aloc = ALoc.alloc () in - let new_pf = Formula.Eq (LVar loc, Expr.ALoc aloc) in + let new_pf = Expr.BinOp (LVar loc, Equal, Expr.ALoc aloc) in Some (Sptr (aloc, Lit (Int k)), [ new_pf ]) | EList [ LVar loc; LVar ofs ] when is_loc_ofs gamma loc ofs -> let aloc = ALoc.alloc () in - let new_pf = Formula.Eq (LVar loc, Expr.ALoc aloc) in + let new_pf = Expr.BinOp (LVar loc, Equal, Expr.ALoc aloc) in Some (Sptr (aloc, LVar ofs), [ new_pf ]) | EList [ Lit (String typ); value ] when String.equal typ int_type -> Some (SVint value, []) diff --git a/Gillian-C/lib/gil_logic_gen.ml b/Gillian-C/lib/gil_logic_gen.ml index 0ba80016..03b8a682 100644 --- a/Gillian-C/lib/gil_logic_gen.ml +++ b/Gillian-C/lib/gil_logic_gen.ml @@ -5,9 +5,8 @@ open CLogic open Compcert open CompileState module Str_set = Gillian.Utils.Containers.SS -open Asrt.Infix -open Formula.Infix module CoreP = Constr.Core +open Expr.Infix let id_of_string = Camlcoq.intern_string let true_name = Camlcoq.extern_atom @@ -31,15 +30,16 @@ let rec split3_expr_comp = function | [] -> ([], [], []) | (x, y, z) :: l -> let rx, ry, rz = split3_expr_comp l in - (x :: rx, y @ ry, z :: rz) + (x @ rx, y @ ry, z :: rz) let ( ++ ) = Expr.Infix.( + ) -let ( == ) e1 e2 = - match e1 #== e2 with - | True -> Asrt.Emp +let to_assrt_of_gen_form = function + | Expr.Lit (Bool true) -> Asrt.Emp | f -> Pure f +let ( #== ) e1 e2 = to_assrt_of_gen_form (e1 == e2) + let types t e = let static_error () = Fmt.failwith "Statically infered that %a should be of type %s" Expr.pp e @@ -56,13 +56,6 @@ let types t e = static_error () (* Maybe a more precise message ? *) | _ -> Emp -let fold_and l = List.fold_left (fun a b -> a #&& b) Formula.True l - -let to_assrt_of_gen_form f = - match f with - | Formula.True -> Asrt.Emp - | _ -> Pure f - type gil_annots = { preds : Pred.t list; specs : Spec.t list; @@ -89,7 +82,9 @@ let get_structs_not_annot struct_types = let struct_names = List.map get_name struct_types in let already_annot = !already_annot_structs in let structs_not_annot = - List.filter (fun name -> not (Str_set.mem name already_annot)) struct_names + List.filter + (fun name -> Stdlib.not (Str_set.mem name already_annot)) + struct_names in let newly_annot = Str_set.union already_annot (Str_set.of_list structs_not_annot) @@ -135,83 +130,63 @@ let assert_of_member cenv members id typ = Fmt.failwith "Invalid member offset : %a@?" Driveraux.print_error e in (* The following bit of code should be refactored to be made cleaner ... *) - if - match typ with - | Tstruct _ -> true - | _ -> false - then - let struct_name, struct_id = - match typ with - | Tstruct (id, _) -> (true_name id, id) - | _ -> failwith "impossible" - in - let pred_name = pred_name_of_struct struct_name in - let arg_number = - List.length (Option.get (Maps.PTree.get struct_id cenv)).co_members - in - let args_without_ins = - List.init arg_number (fun k -> - Expr.LVar ("#i__" ^ field_name ^ "_" ^ string_of_int k)) - in - let list_is_components = - let open Formula.Infix in - Asrt.Pure pvmember #== (Expr.list args_without_ins) - in - let ofs = - let open Expr.Infix in - pvofs + fo - in - let args = pvloc :: ofs :: args_without_ins in - let pred_call = Asrt.Pred (pred_name, args) in - list_is_components ** pred_call - else if - match typ with - | Tarray _ -> true - | _ -> false - then - let ty, n = - match typ with - | Tarray (ty, n, _) -> (ty, n) - | _ -> failwith "impossible" - in - let n = ValueTranslation.int_of_z n in - let n_e = Expr.int_z n in - let chunk = - match access_mode_by_value ty with - | Some chunk -> chunk - | _ -> failwith "Array in a structure containing complicated types" - in - Constr.Core.array ~loc:pvloc ~ofs:(pvofs ++ fo) ~chunk ~size:n_e - ~sval_arr:pvmember ~perm:(Some Freeable) - else - let mk t v = Expr.list [ Expr.string t; v ] in - let field_val_name = "#i__" ^ field_name ^ "_v" in - let lvval = Expr.LVar field_val_name in - let e_to_use, getter_or_type_pred = - let open Internal_Predicates in - let open VTypes in - match typ with - | Tint _ -> (mk int_type lvval, Asrt.Pred (int_get, [ pvmember; lvval ])) - | Tlong _ -> - (mk long_type lvval, Asrt.Pred (long_get, [ pvmember; lvval ])) - | Tfloat _ -> - (mk float_type lvval, Asrt.Pred (float_get, [ pvmember; lvval ])) - | Tpointer _ -> (pvmember, Asrt.Pred (is_ptr_opt, [ pvmember ])) - | _ -> - failwith - (Printf.sprintf "unhandled struct field type for now : %s" - (PrintCsyntax.name_cdecl field_name typ)) - in - let chunk = - match access_mode_by_value typ with - | Some chunk -> chunk - | _ -> failwith "Invalid access mode for some type" - in - let ga_asrt = - CoreP.single ~loc:pvloc ~ofs:(pvofs ++ fo) ~chunk ~sval:e_to_use - ~perm:(Some Freeable) - in - getter_or_type_pred ** ga_asrt + match typ with + | Tstruct (struct_id, _) -> + let struct_name = true_name struct_id in + let pred_name = pred_name_of_struct struct_name in + let arg_number = + List.length (Option.get (Maps.PTree.get struct_id cenv)).co_members + in + let args_without_ins = + List.init arg_number (fun k -> + Expr.LVar ("i__" ^ field_name ^ "_" ^ string_of_int k)) + in + let list_is_components = pvmember #== (Expr.list args_without_ins) in + let ofs = Expr.Infix.(pvofs + fo) in + let args = pvloc :: ofs :: args_without_ins in + let pred_call = Asrt.Pred (pred_name, args) in + [ list_is_components; pred_call ] + | Tarray (ty, n, _) -> + let n = ValueTranslation.int_of_z n in + let n_e = Expr.int_z n in + let chunk = + match access_mode_by_value ty with + | Some chunk -> chunk + | _ -> failwith "Array in a structure containing complicated types" + in + [ + Constr.Core.array ~loc:pvloc ~ofs:(pvofs ++ fo) ~chunk ~size:n_e + ~sval_arr:pvmember ~perm:(Some Freeable); + ] + | _ -> + let mk t v = Expr.list [ Expr.string t; v ] in + let field_val_name = "i__" ^ field_name ^ "_v" in + let lvval = Expr.LVar field_val_name in + let e_to_use, getter_or_type_pred = + let open Internal_Predicates in + let open VTypes in + match typ with + | Tint _ -> (mk int_type lvval, Asrt.Pred (int_get, [ pvmember; lvval ])) + | Tlong _ -> + (mk long_type lvval, Asrt.Pred (long_get, [ pvmember; lvval ])) + | Tfloat _ -> + (mk float_type lvval, Asrt.Pred (float_get, [ pvmember; lvval ])) + | Tpointer _ -> (pvmember, Asrt.Pred (is_ptr_opt, [ pvmember ])) + | _ -> + failwith + (Printf.sprintf "unhandled struct field type for now : %s" + (PrintCsyntax.name_cdecl field_name typ)) + in + let chunk = + match access_mode_by_value typ with + | Some chunk -> chunk + | _ -> failwith "Invalid access mode for some type" + in + let ga_asrt = + CoreP.single ~loc:pvloc ~ofs:(pvofs ++ fo) ~chunk ~sval:e_to_use + ~perm:(Some Freeable) + in + [ getter_or_type_pred; ga_asrt ] let assert_of_hole (low, high) = let pvloc = Expr.PVar loc_param_name in @@ -244,22 +219,18 @@ let gen_pred_of_struct cenv ann struct_name = ] in let struct_params = - List.map - (function - | Member_plain (i, _) -> (true_name i, Some Type.ListType) - | Member_bitfield _ -> failwith "Unsupported bitfield members") - comp.co_members + comp.co_members + |> List.map @@ function + | Member_plain (i, _) -> (true_name i, Some Type.ListType) + | Member_bitfield _ -> failwith "Unsupported bitfield members" in let pred_params = first_params @ struct_params in let pred_num_params = List.length pred_params in let def_without_holes = - List.fold_left - (fun asrt member -> - match member with - | Member_plain (id, typ) -> - asrt ** assert_of_member cenv comp.co_members id typ - | Member_bitfield _ -> failwith "Unsupported bitfield members") - Asrt.Emp comp.co_members + comp.co_members + |> List.concat_map @@ function + | Member_plain (id, typ) -> assert_of_member cenv comp.co_members id typ + | Member_bitfield _ -> failwith "Unsupported bitfield members" in let fo idp = match field_offset cenv idp comp.co_members with @@ -278,13 +249,14 @@ let gen_pred_of_struct cenv ann struct_name = | Member_plain (ida, t) :: (Member_plain (idb, _) :: _ as r) -> let end_a = Z.add (fo ida) (sz t) in let start_b = fo idb in - if end_a < start_b then (end_a, start_b) :: get_holes r else get_holes r + if Stdlib.( < ) end_a start_b then (end_a, start_b) :: get_holes r + else get_holes r | _ -> failwith "Unsupported bitfield members" in let holes = get_holes comp.co_members in let holes_asserts = List.map assert_of_hole holes in - let def = Asrt.star holes_asserts ** def_without_holes in + let def = holes_asserts @ def_without_holes in (* TODO (Alexis): How to handle changes in structs? *) let n_pred = Pred. @@ -306,35 +278,31 @@ let gen_pred_of_struct cenv ann struct_name = in { ann with preds = n_pred :: ann.preds } -let trans_binop b = - match b with - | CBinOp.LstCons -> failwith "LstCons shouldn't be compiled that way" +let trans_binop : CBinOp.t -> BinOp.t = function + | LstCons -> failwith "LstCons shouldn't be compiled that way" | LstCat -> failwith "LstCat shouldn't be compiled that way" | PtrPlus -> failwith "PtrPlus shouldn't be compiled that way" - | Plus -> BinOp.IPlus - | Times -> BinOp.ITimes - | Minus -> BinOp.IMinus - | Div -> BinOp.IDiv + | Plus -> IPlus + | Times -> ITimes + | Minus -> IMinus + | Div -> IDiv | Equal -> Equal - | SetSub -> BSetSub + | SetSub -> SetSub | SetDiff -> SetDiff - | SetMem -> BSetMem + | SetMem -> SetMem | LessThan -> ILessThan - | And -> BAnd - | Or -> BOr + | And -> And + | Or -> Or -let trans_unop u = - match u with - | CUnOp.LstLen -> UnOp.LstLen - | Not -> UNot +let trans_unop : CUnOp.t -> UnOp.t = function + | LstLen -> LstLen + | Not -> Not -let trans_nop n = - match n with - | CNOp.SetUnion -> NOp.SetUnion +let trans_nop : CNOp.t -> NOp.t = function + | SetUnion -> SetUnion -let trans_simpl_expr se = - match se with - | CSimplExpr.PVar s -> Expr.PVar s +let trans_simpl_expr : CSimplExpr.t -> Expr.t = function + | PVar s -> PVar s | LVar s -> LVar s | Loc s -> Lit (Loc s) | Int i -> Lit (Int i) @@ -354,112 +322,107 @@ let trans_sval (sv : CSVal.t) : Asrt.t * Var.t list * Expr.t = match sv with | CSVal.Sint se -> let eg = tse se in - (tint eg, [], mk int_type (tse se)) + ([ tint eg ], [], mk int_type (tse se)) | Slong se -> let eg = tse se in - (tint eg, [], mk long_type (tse se)) + ([ tint eg ], [], mk long_type (tse se)) | Ssingle se -> let eg = tse se in - (tnum eg, [], mk single_type (tse se)) + ([ tnum eg ], [], mk single_type (tse se)) | Sfloat se -> let eg = tse se in - (tnum eg, [], mk float_type (tse se)) + ([ tnum eg ], [], mk float_type (tse se)) | Sptr (se1, se2) -> let eg1, eg2 = (tse se1, tse se2) in - (tloc eg1 ** tint eg2, [], Expr.EList [ tse se1; tse se2 ]) + ([ tloc eg1; tint eg2 ], [], Expr.EList [ tse se1; tse se2 ]) | Sfunptr symb -> let loc = Global_env.location_of_symbol symb in let ptr = Expr.EList [ Lit (Loc loc); Expr.zero_i ] in - (Asrt.Emp, [], ptr) + ([], [], ptr) (** Returns assertions that are necessary to define the expression, the created variable for binding when necessary, and the used expression *) let rec trans_expr (e : CExpr.t) : Asrt.t * Var.t list * Expr.t = match e with - | CExpr.SExpr se -> (Asrt.Emp, [], trans_simpl_expr se) + | CExpr.SExpr se -> ([], [], trans_simpl_expr se) | SVal sv -> trans_sval sv | EList el -> - let asrts, vars, elp = split3_expr_comp (List.map trans_expr el) in - let asrt = Asrt.star asrts in + let asrt, vars, elp = split3_expr_comp (List.map trans_expr el) in (asrt, vars, Expr.EList elp) | ESet es -> - let asrts, vars, elp = split3_expr_comp (List.map trans_expr es) in - let asrt = Asrt.star asrts in + let asrt, vars, elp = split3_expr_comp (List.map trans_expr es) in (asrt, vars, Expr.ESet elp) | BinOp (e1, LstCat, e2) -> let a1, v1, eg1 = trans_expr e1 in let a2, v2, eg2 = trans_expr e2 in - (a1 ** a2, v1 @ v2, Expr.list_cat eg1 eg2) + (a1 @ a2, v1 @ v2, Expr.list_cat eg1 eg2) | BinOp (e1, LstCons, e2) -> let a1, v1, eg1 = trans_expr e1 in let a2, v2, eg2 = trans_expr e2 in - (a1 ** a2, v1 @ v2, Expr.list_cat (EList [ eg1 ]) eg2) + (a1 @ a2, v1 @ v2, Expr.list_cat (EList [ eg1 ]) eg2) | BinOp (e1, PtrPlus, e2) -> ( let a1, v1, ptr = trans_expr e1 in let a2, v2, to_add = trans_expr e2 in match ptr with | Expr.EList [ loc; ofs ] -> - (a1 ** a2, v1 @ v2, Expr.EList [ loc; Expr.Infix.( + ) ofs to_add ]) + (a1 @ a2, v1 @ v2, Expr.EList [ loc; Expr.Infix.( + ) ofs to_add ]) | ptr -> let res_lvar = fresh_lvar () in let res = Expr.LVar res_lvar in - ( a1 ** a2 ** Constr.Others.ptr_add ~ptr ~to_add ~res, + ( a1 @ a2 @ [ Constr.Others.ptr_add ~ptr ~to_add ~res ], res_lvar :: (v1 @ v2), res )) | BinOp (e1, b, e2) -> let a1, v1, eg1 = trans_expr e1 in let a2, v2, eg2 = trans_expr e2 in - (a1 ** a2, v1 @ v2, BinOp (eg1, trans_binop b, eg2)) + (a1 @ a2, v1 @ v2, BinOp (eg1, trans_binop b, eg2)) | UnOp (u, e) -> let a, v, eg = trans_expr e in (a, v, UnOp (trans_unop u, eg)) | NOp (nop, el) -> - let asrts, vs, elp = split3_expr_comp (List.map trans_expr el) in - let asrt = Asrt.star asrts in + let asrt, vs, elp = split3_expr_comp (List.map trans_expr el) in let gnop = trans_nop nop in (asrt, vs, Expr.NOp (gnop, elp)) | LstSub (lst, start, len) -> let a1, v1, lst = trans_expr lst in let a2, v2, start = trans_expr start in let a3, v3, len = trans_expr len in - (a1 ** a2 ** a3, v1 @ v2 @ v3, Expr.list_sub ~lst ~start ~size:len) + (a1 @ a2 @ a3, v1 @ v2 @ v3, Expr.list_sub ~lst ~start ~size:len) -let rec trans_form (f : CFormula.t) : Asrt.t * Var.t list * Formula.t = - let open Formula.Infix in - match f with - | CFormula.True -> (Emp, [], Formula.True) - | False -> (Emp, [], False) +let rec trans_form : CFormula.t -> Asrt.t * Var.t list * Expr.t = function + | True -> ([], [], Expr.true_) + | False -> ([], [], Expr.false_) | Eq (ce1, ce2) -> let f1, v1, eg1 = trans_expr ce1 in let f2, v2, eg2 = trans_expr ce2 in - (f1 ** f2, v1 @ v2, eg1 #== eg2) + (f1 @ f2, v1 @ v2, eg1 == eg2) | LessEq (ce1, ce2) -> let f1, v1, eg1 = trans_expr ce1 in let f2, v2, eg2 = trans_expr ce2 in - (f1 ** f2, v1 @ v2, eg1 #<= eg2) + (f1 @ f2, v1 @ v2, eg1 <= eg2) | Less (ce1, ce2) -> let f1, v1, eg1 = trans_expr ce1 in let f2, v2, eg2 = trans_expr ce2 in - (f1 ** f2, v1 @ v2, eg1 #< eg2) + (f1 @ f2, v1 @ v2, eg1 < eg2) | SetMem (ce1, ce2) -> let f1, v1, eg1 = trans_expr ce1 in let f2, v2, eg2 = trans_expr ce2 in - (f1 ** f2, v1 @ v2, SetMem (eg1, eg2)) + (f1 @ f2, v1 @ v2, BinOp (eg1, SetMem, eg2)) | Not fp -> let a, v, fpp = trans_form fp in - (a, v, fnot fpp) + (a, v, not fpp) | Or (f1, f2) -> let a1, v1, fp1 = trans_form f1 in let a2, v2, fp2 = trans_form f2 in - (a1 ** a2, v1 @ v2, fp1 #|| fp2) + (a1 @ a2, v1 @ v2, fp1 || fp2) | And (f1, f2) -> let a1, v1, fp1 = trans_form f1 in let a2, v2, fp2 = trans_form f2 in - (a1 ** a2, v1 @ v2, fp1 #&& fp2) + (a1 @ a2, v1 @ v2, fp1 && fp2) | Implies (f1, f2) -> let a1, v1, fp1 = trans_form f1 in let a2, v2, fp2 = trans_form f2 in - (a1 ** a2, v1 @ v2, fp1 #=> fp2) + (a1 @ a2, v1 @ v2, fp1 ==> fp2) | ForAll (lvts, f) -> let a, v, fp = trans_form f in (a, v, ForAll (lvts, fp)) @@ -511,13 +474,13 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = let loc = Global_env.location_of_symbol symb in let loc = Expr.Lit (Loc loc) in let ofsv = Expr.int 0 in - (Asrt.Emp, loc, ofsv) + ([], loc, ofsv) | _ -> let a_s, _, s_e = trans_expr s in let locv = gen_loc_var () in let ofsv = gen_ofs_var () in let pc = ptr_call s_e locv ofsv in - (pc ** a_s, locv, ofsv) + (pc :: a_s, locv, ofsv) in let to_assert, locv, ofsv = interpret_s ~typ s in let malloc_chunk siz = @@ -526,52 +489,35 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = let mk str v = Expr.list [ Expr.string str; v ] in let mk_ptr l o = Expr.list [ l; o ] in match c with - | CConstructor.ConsExpr (SVal (Sint se)) -> - let e = cse se in - let chunk = Chunk.Mint32 in - let sv = mk int_type e in - let siz = sz (Sint se) in - let ga = - CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) - in - ga ** to_assert ** tint e ** malloc_chunk siz - | ConsExpr (SVal (Sfloat se)) -> - let e = cse se in - let chunk = Chunk.Mfloat32 in - let siz = sz (Sfloat se) in - let sv = mk float_type e in - let ga = - CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) - in - ga ** to_assert ** tnum e ** malloc_chunk siz - | ConsExpr (SVal (Ssingle se)) -> - let e = cse se in - let chunk = Chunk.Mfloat32 in - let siz = sz (Ssingle se) in - let sv = mk single_type e in - let ga = - CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) + | CConstructor.ConsExpr (SVal (Sint v as se)) + | ConsExpr (SVal (Sfloat v as se)) + | ConsExpr (SVal (Ssingle v as se)) + | ConsExpr (SVal (Slong v as se)) -> + let chunk, typ, asrtfn = + match se with + | Sint _ -> (Chunk.Mint32, int_type, tint) + | Sfloat _ -> (Chunk.Mfloat32, float_type, tnum) + | Ssingle _ -> (Chunk.Mfloat32, single_type, tnum) + | Slong _ -> (Chunk.Mint64, long_type, tint) + | _ -> failwith "Impossible" in - ga ** to_assert ** tnum e ** malloc_chunk siz - | ConsExpr (SVal (Slong se)) -> - let e = cse se in - let chunk = Chunk.Mint64 in - let siz = sz (Slong se) in - let sv = mk long_type e in + let e = cse v in + let sval = mk typ e in + let siz = sz se in let ga = - CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) + CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval ~perm:(Some Freeable) in - ga ** to_assert ** tint e ** malloc_chunk siz + [ ga; asrtfn e; malloc_chunk siz ] @ to_assert | ConsExpr (SVal (Sptr (sl, so))) -> let l = cse sl in let o = cse so in let chunk = Chunk.ptr in let siz = sz (Sptr (sl, so)) in - let sv = mk_ptr l o in + let sval = mk_ptr l o in let ga = - CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) + CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval ~perm:(Some Freeable) in - ga ** to_assert ** tloc l ** tint o ** malloc_chunk siz + [ ga; tloc l; tint o; malloc_chunk siz ] @ to_assert | ConsExpr (SVal (Sfunptr fname)) -> let l = Global_env.location_of_symbol fname in let ptr = Expr.EList [ Expr.Lit (Loc l); Expr.zero_i ] in @@ -580,7 +526,7 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = let ga_single = CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:ptr ~perm:(Some Freeable) in - ga_single ** to_assert ** malloc_chunk siz + [ ga_single; malloc_chunk siz ] @ to_assert | ConsExpr _ -> Fmt.failwith "Constructor %a is not handled yet" CConstructor.pp c | ConsStruct (sname, el) -> @@ -597,72 +543,73 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = split3_expr_comp (List.map trans_expr el) in let pr = - Asrt.Pred (struct_pred, [ locv; ofsv ] @ params_fields) - ** Asrt.star more_asrt + Asrt.Pred (struct_pred, [ locv; ofsv ] @ params_fields) :: more_asrt in - pr ** to_assert ** malloc_chunk siz + pr @ to_assert @ [ malloc_chunk siz ] let rec trans_asrt ~fname ~ann asrt = - match asrt with - | CAssert.Star (a1, a2) -> - trans_asrt ~fname ~ann a1 ** trans_asrt ~fname ~ann a2 - | Array { ptr; chunk; size; content; malloced } -> - let a1, _, ptr = trans_expr ptr in - let a2, _, size = trans_expr size in - let a3, _, content = trans_expr content in - let malloc_p = - if malloced then - let open Expr.Infix in - let csize = Expr.int (Chunk.size chunk) in - let total_size = size * csize in - Constr.Others.malloced_abst ~ptr ~total_size - else Asrt.Emp - in - a1 ** a2 ** a3 - ** Constr.Others.array_ptr ~ptr ~chunk ~size ~content - ** malloc_p - | Malloced (e1, e2) -> - let a1, _, ce1 = trans_expr e1 in - let a2, _, ce2 = trans_expr e2 in - a1 ** a2 ** Constr.Others.malloced_abst ~ptr:ce1 ~total_size:ce2 - | Zeros (e1, e2) -> - let a1, _, ce1 = trans_expr e1 in - let a2, _, ce2 = trans_expr e2 in - a1 ** a2 ** Constr.Others.zeros_ptr_size ~ptr:ce1 ~size:ce2 - | Undefs (e1, e2) -> - let a1, _, ce1 = trans_expr e1 in - let a2, _, ce2 = trans_expr e2 in - a1 ** a2 ** Constr.Others.undefs_ptr_size ~ptr:ce1 ~size:ce2 - | Pure f -> - let ma, _, fp = trans_form f in - ma ** Pure fp - | Pred (p, cel) -> - let ap, _, gel = split3_expr_comp (List.map trans_expr cel) in - Asrt.star ap ** Pred (p, gel) - | Emp -> Emp - | PointsTo { ptr = s; constr = c; typ } -> trans_constr ~fname ~typ ann s c + let a = + match asrt with + | CAssert.Star (a1, a2) -> + trans_asrt ~fname ~ann a1 @ trans_asrt ~fname ~ann a2 + | Array { ptr; chunk; size; content; malloced } -> + let a1, _, ptr = trans_expr ptr in + let a2, _, size = trans_expr size in + let a3, _, content = trans_expr content in + let malloc_p = + if malloced then + let open Expr.Infix in + let csize = Expr.int (Chunk.size chunk) in + let total_size = size * csize in + [ Constr.Others.malloced_abst ~ptr ~total_size ] + else [] + in + a1 @ a2 @ a3 + @ [ Constr.Others.array_ptr ~ptr ~chunk ~size ~content ] + @ malloc_p + | Malloced (e1, e2) -> + let a1, _, ce1 = trans_expr e1 in + let a2, _, ce2 = trans_expr e2 in + a1 @ a2 @ [ Constr.Others.malloced_abst ~ptr:ce1 ~total_size:ce2 ] + | Zeros (e1, e2) -> + let a1, _, ce1 = trans_expr e1 in + let a2, _, ce2 = trans_expr e2 in + a1 @ a2 @ [ Constr.Others.zeros_ptr_size ~ptr:ce1 ~size:ce2 ] + | Undefs (e1, e2) -> + let a1, _, ce1 = trans_expr e1 in + let a2, _, ce2 = trans_expr e2 in + a1 @ a2 @ [ Constr.Others.undefs_ptr_size ~ptr:ce1 ~size:ce2 ] + | Pure f -> + let ma, _, fp = trans_form f in + Pure fp :: ma + | Pred (p, cel) -> + let ap, _, gel = split3_expr_comp (List.map trans_expr cel) in + Pred (p, gel) :: ap + | Emp -> [ Asrt.Emp ] + | PointsTo { ptr = s; constr = c; typ } -> trans_constr ~fname ~typ ann s c + in + match List.filter (fun x -> x <> Asrt.Emp) a with + | [] -> [ Asrt.Emp ] + | a -> a let rec trans_lcmd ~fname ~ann lcmd = let trans_lcmd = trans_lcmd ~fname ~ann in let trans_asrt = trans_asrt ~fname ~ann in let make_assert ~bindings = function - | Asrt.Emp -> [] + | [] | [ Asrt.Emp ] -> [] | a -> [ LCmd.SL (SepAssert (a, bindings)) ] in match lcmd with | CLCmd.Apply (pn, el) -> let aps, bindings, gel = split3_expr_comp (List.map trans_expr el) in - let to_assert = Asrt.star aps in - `Normal (make_assert ~bindings to_assert @ [ SL (ApplyLem (pn, gel, [])) ]) + `Normal (make_assert ~bindings aps @ [ SL (ApplyLem (pn, gel, [])) ]) | CLCmd.Fold (pn, el) -> let aps, bindings, gel = split3_expr_comp (List.map trans_expr el) in - let to_assert = Asrt.star aps in - `Normal (make_assert ~bindings to_assert @ [ SL (Fold (pn, gel, None)) ]) + `Normal (make_assert ~bindings aps @ [ SL (Fold (pn, gel, None)) ]) | Unfold { pred; params; bindings; recursive } -> let ap, vs, gel = split3_expr_comp (List.map trans_expr params) in - let to_assert = Asrt.star ap in `Normal - (make_assert ~bindings:vs to_assert + (make_assert ~bindings:vs ap @ [ SL (Unfold (pred, gel, bindings, recursive)) ]) | Unfold_all pred_name -> `Normal [ SL (GUnfold pred_name) ] | Assert (a, ex) -> `Normal [ SL (SepAssert (trans_asrt a, ex)) ] @@ -688,16 +635,14 @@ let rec trans_lcmd ~fname ~ann lcmd = let trans_asrt_annot da = let { label; existentials } = da in let exs, typsb = - List.split - (List.map - (fun (ex, topt) -> - match topt with - | None -> (ex, Asrt.Emp) - | Some t -> (ex, types t (Expr.LVar ex))) - existentials) + existentials + |> ( List.map @@ fun (ex, topt) -> + match topt with + | None -> (ex, Asrt.Emp) + | Some t -> (ex, types t (Expr.LVar ex)) ) + |> List.split in - let a = Asrt.star typsb in - (a, (label, exs)) + (typsb, (label, exs)) let trans_abs_pred ~filepath cl_pred = let CAbsPred. @@ -747,7 +692,7 @@ let trans_pred ~ann ~filepath cl_pred = | None -> (None, trans_asrt ~fname:pred_name ~ann a) | Some da -> let ada, gda = trans_asrt_annot da in - (Some gda, ada ** trans_asrt ~fname:pred_name ~ann a)) + (Some gda, ada @ trans_asrt ~fname:pred_name ~ann a)) definitions in Pred. @@ -778,7 +723,7 @@ let trans_sspec ~ann fname sspecs = let CSpec.{ pre; posts; spec_annot } = sspecs in let tap, spa = match spec_annot with - | None -> (Asrt.Emp, None) + | None -> ([], None) | Some spa -> let a, (label, exs) = trans_asrt_annot spa in (a, Some (label, exs)) @@ -787,7 +732,7 @@ let trans_sspec ~ann fname sspecs = let make_post p = if !Config.allocated_functions then ta p else ta p in Spec. { - ss_pre = tap ** ta pre; + ss_pre = tap @ ta pre; ss_posts = List.map make_post posts; (* FIXME: bring in variant *) ss_variant = None; @@ -839,7 +784,7 @@ let trans_spec ~ann ?(only_spec = false) cl_spec = spec_sspecs = List.map (trans_sspec ~ann fname) sspecs; spec_normalised = false; spec_incomplete = false; - spec_to_verify = not only_spec; + spec_to_verify = Stdlib.not only_spec; } in let _ = @@ -917,7 +862,7 @@ let bit_size = function | IBool -> 1 let bounds signedness bit_size = - let bit_size_m_1 = bit_size - 1 in + let bit_size_m_1 = Stdlib.( - ) bit_size 1 in let open Z in let min, max = match signedness with @@ -948,7 +893,7 @@ let predicate_from_triple (e, csmt, ct) = (PrintAST.name_of_type csmt)) let simple_predicate_from_triple (pn, _, _) = - Asrt.Pure (Eq (Expr.PVar pn, Expr.LVar ("#" ^ pn))) + Asrt.Pure (BinOp (Expr.PVar pn, Equal, Expr.LVar ("" ^ pn))) let generate_bispec clight_prog fname ident f = let rec combine a b c = @@ -962,19 +907,18 @@ let generate_bispec clight_prog fname ident f = let true_params = List.map true_name params in let clight_fun = get_clight_fun clight_prog ident in let cligh_params = clight_fun.Clight.fn_params in - let mk_lvar x = Expr.LVar ("#" ^ x) in + let mk_lvar x = Expr.LVar ("" ^ x) in let lvars = List.map mk_lvar true_params in let equalities = - Asrt.star - (List.map - (fun x -> Asrt.Pure (Formula.Eq (Expr.PVar x, mk_lvar x))) - true_params) + List.map + (fun x -> Asrt.Pure (Expr.BinOp (Expr.PVar x, Equal, mk_lvar x))) + true_params in (* Right now, triples are : (param_name, csharpminor type, c type) The C type will be used to discriminate long/int from pointers *) let triples = combine lvars sig_args cligh_params in let pred_list = List.map predicate_from_triple triples in - let pre = equalities ** Asrt.star pred_list in + let pre = equalities @ pred_list in BiSpec. { bispec_name = fname; diff --git a/Gillian-C/lib/gilgen.ml b/Gillian-C/lib/gilgen.ml index c4d7f8ae..0fd2c4cd 100644 --- a/Gillian-C/lib/gilgen.ml +++ b/Gillian-C/lib/gilgen.ml @@ -525,13 +525,13 @@ let rec trans_stmt ~clight_prog ~fname ~fid ~context stmt : | Scall (None, _, ex, [ e ]) when is_assert_call ex -> let cmds, egil = trans_expr e in let one = Expr.EList [ Lit (String VTypes.int_type); Expr.one_i ] in - let form = Formula.Eq (egil, one) in + let form = Expr.BinOp (egil, Equal, one) in let assert_cmd = Cmd.Logic (Assert form) in (add_annots ~ctx:context (cmds @ [ assert_cmd ]), []) | Scall (None, _, ex, [ e ]) when is_assume_call ex -> let cmds, egil = trans_expr e in let one = Expr.EList [ Lit (String VTypes.int_type); Expr.one_i ] in - let form = Formula.Eq (egil, one) in + let form = Expr.BinOp (egil, Equal, one) in let assume_cmd = Cmd.Logic (Assume form) in (add_annots ~ctx:context (cmds @ [ assume_cmd ]), []) | Scall (Some id, _, ex, []) when is_nondet_int_call ex -> @@ -600,9 +600,9 @@ let rec trans_stmt ~clight_prog ~fname ~fid ~context stmt : | LScons (None, _, r) -> build_isdefault curr r | LScons (Some l, _, r) -> let ne = - Expr.UnOp (UnOp.UNot, Expr.BinOp (guard_expr, BinOp.Equal, num l)) + Expr.UnOp (UnOp.Not, Expr.BinOp (guard_expr, BinOp.Equal, num l)) in - build_isdefault (Expr.BinOp (ne, BinOp.BAnd, curr)) r + build_isdefault (Expr.BinOp (ne, BinOp.And, curr)) r in let rec make_switch had_default l_stmts = match l_stmts with diff --git a/Gillian-C/runtime/logic_archi64.gil b/Gillian-C/runtime/logic_archi64.gil index 44d492f8..20305ee7 100644 --- a/Gillian-C/runtime/logic_archi64.gil +++ b/Gillian-C/runtime/logic_archi64.gil @@ -2,33 +2,33 @@ pred i__is_ptr_to_0_opt (e: List): i__is_ptr_to_0(e), - e == {{ "long", 0i }}; + (e == {{ "long", 0i }}); pred i__is_ptr_opt (e: List): i__is_ptr(e), - e == {{ "long", 0i }}; + (e == {{ "long", 0i }}); pred i__is_ptr_to_int_opt (+e: List): i__ptr_to_0(e, #l) * (#l, 0i, "int32"; {{ "int", #i }}, "Freeable"), - e == {{ "long", 0i }}; + (e == {{ "long", 0i }}); pred i__is_ptr_to_float_opt (+e: List): i__ptr_to_0(e, #l) * (#l, 0i, "float32"; {{ "float", #i }}, "Freeable"), - e == {{ "long", 0i }}; + (e == {{ "long", 0i }}); pred i__is_ptr_to_long_opt (+e: List): i__ptr_to_0(e, #l) * (#l, 0i, "int64"; {{ "long", #i }}, "Freeable"), - e == {{ "long", 0i }}; + (e == {{ "long", 0i }}); pred i__is_ptr_to_single_opt (+e: List): i__ptr_to_0(e, #l) * (#l, 0i, "float32"; {{ "single", #i }}, "Freeable"), - e == {{ "long", 0i }}; + (e == {{ "long", 0i }}); pred i__malloced(+p: List, bytes: Int): i__ptr(p, #l, 0i) * (#l, -8i, "int64"; {{ "long", bytes }}, "Freeable") * - (#l; {{ -8i, bytes }}); \ No newline at end of file + (#l; {{ -8i, bytes }}); diff --git a/Gillian-C2/lib/compiler/compile_expr.ml b/Gillian-C2/lib/compiler/compile_expr.ml index c69da993..d4cfdb32 100644 --- a/Gillian-C2/lib/compiler/compile_expr.ml +++ b/Gillian-C2/lib/compiler/compile_expr.ml @@ -199,13 +199,13 @@ let compile_binop | Some (low, high) -> (low, high)) in let ( <= ) a b = Expr.BinOp (a, ILessThanEqual, b) in - let ( && ) a b = Expr.BinOp (a, BAnd, b) in + let ( && ) a b = Expr.BinOp (a, And, b) in Expr.int_z low <= e && e <= Expr.int_z high in let assert_int_in_bounds ~ty e = let expr_cond = int_in_bounds ~ty e in let formula = - match Formula.lift_logic_expr expr_cond with + match Expr.as_boolean_expr expr_cond with | Some (f, _) -> f | _ -> Error.code_error @@ -344,8 +344,8 @@ let compile_binop | CInteger _ | Unsignedbv _ | Signedbv _ -> GilBinop IMod | Float -> GilBinop FMod | _ -> Unhandled `With_type) - | Or -> GilBinop BinOp.BOr - | And -> GilBinop BinOp.BAnd + | Or -> GilBinop BinOp.Or + | And -> GilBinop BinOp.And | OverflowPlus -> ( let int_check = GilBinop IPlus ||> int_in_bounds ~ty:lty ||> Expr.Infix.not @@ -424,8 +424,8 @@ let rec assume_type ~ctx (type_ : GType.t) (expr : Expr.t) : unit Cs.with_cmds = (* Special case, the bounds are different *) let assume_int = Cmd.Logic (AssumeType (expr, IntType)) in let condition = - let open Formula.Infix in - expr #== Expr.one_i #|| (expr #== Expr.zero_i) + let open Expr.Infix in + expr == Expr.one_i || expr == Expr.zero_i in let assume_range = Cmd.Logic (Assume condition) in Cs.return ~app:[ assume_int; assume_range ] () @@ -438,10 +438,8 @@ let rec assume_type ~ctx (type_ : GType.t) (expr : Expr.t) : unit Cs.with_cmds = match bounds with | None -> [] | Some (low, high) -> - let open Formula.Infix in - let condition = - (Expr.int_z low) #<= expr #&& (expr #<= (Expr.int_z high)) - in + let open Expr.Infix in + let condition = Expr.int_z low <= expr && expr <= Expr.int_z high in [ Cmd.Logic (Assume condition) ] in Cs.unit (assume_int :: assume_range) @@ -454,7 +452,7 @@ let rec assume_type ~ctx (type_ : GType.t) (expr : Expr.t) : unit Cs.with_cmds = let e_loc = Expr.PVar loc in let e_ofs = Expr.PVar ofs in let assume_list = - let f = Formula.Eq (expr, EList [ e_loc; e_ofs ]) in + let f = Expr.BinOp (expr, Equal, EList [ e_loc; e_ofs ]) in Cmd.Logic (Assume f) in let assume_obj = Cmd.Logic (AssumeType (e_loc, ObjectType)) in @@ -544,8 +542,8 @@ let rec nondet_expr ~ctx ~loc ~type_ ~display () : Val_repr.t Cs.with_body = let variant_number = Expr.int variant_amount in let variant_int = LCmd.AssumeType (variant, IntType) in let variant_constraint = - let open Formula.Infix in - Expr.zero_i #<= variant #&& (variant #< variant_number) + let open Expr.Infix in + Expr.zero_i <= variant && variant < variant_number in let variant_value = LCmd.Assume variant_constraint in Cs.return @@ -861,11 +859,11 @@ and compile_call else Cs.return to_assume in let f = - match Formula.lift_logic_expr to_assume with + match Expr.as_boolean_expr to_assume with | None -> Logging.normal ~severity:Warning (fun m -> m "Cannot assume %a, assuming False instead" Expr.pp to_assume); - Formula.False + Expr.false_ | Some (f, _) -> f in by_value ~app:[ b (Logic (Assume f)) ] (Lit Null) @@ -902,11 +900,11 @@ and compile_call else Cs.return to_assert in let f = - match Formula.lift_logic_expr to_assert with + match Expr.as_boolean_expr to_assert with | None -> Logging.normal ~severity:Warning (fun m -> m "Cannot assert %a, asserting False instead" Expr.pp to_assert); - Formula.False + Expr.false_ | Some (f, _) -> f in by_value ~app:[ b (Logic (Assert f)) ] (Expr.Lit Null) @@ -1132,13 +1130,13 @@ and compile_address_of ~ctx ~b (expr : GExpr.t) x = *) assert ctx.machine.null_is_zero; let assume_not_null = - let open Formula.Infix in - b (Cmd.Logic (Assume (fnot ptr #== Expr.zero_i))) + let open Expr.Infix in + b (Cmd.Logic (Assume (not (ptr == Expr.zero_i)))) in let assume_align_8 = - let open Formula.Infix in + let open Expr.Infix in let mod_8 = Expr.BinOp (ptr, IMod, Expr.int 8) in - b (Cmd.Logic (Assume mod_8 #== Expr.zero_i)) + b (Cmd.Logic (Assume (mod_8 == Expr.zero_i))) in Cs.return ~app:[ assume_not_null; assume_align_8 ] (Val_repr.ByValue ptr) (* Should probably just return a long, with a nondet value that has the right offset *) @@ -1474,7 +1472,7 @@ and compile_statement ~ctx (stmt : Stmt.t) : Val_repr.t Cs.with_body = ~subst_with:(Expr.Lit (Bool true)) e in let f = - match Formula.lift_logic_expr e with + match Expr.as_boolean_expr e with | None -> Error.code_error (Fmt.str "Unable to lift: %a" Expr.pp e) | Some (f, _) -> f in @@ -1496,7 +1494,7 @@ and compile_statement ~ctx (stmt : Stmt.t) : Val_repr.t Cs.with_body = ~subst_with:(Expr.Lit (Bool false)) e in let f = - match Formula.lift_logic_expr e with + match Expr.as_boolean_expr e with | None -> Error.code_error (Fmt.str "Unable to lift: %a" Expr.pp e) | Some (f, _) -> f in diff --git a/Gillian-C2/lib/compiler/logics.ml b/Gillian-C2/lib/compiler/logics.ml index 39b2393b..5d481c60 100644 --- a/Gillian-C2/lib/compiler/logics.ml +++ b/Gillian-C2/lib/compiler/logics.ml @@ -2,17 +2,16 @@ open Gil_syntax module GType = Goto_lib.Type let rec asrt_of_scalar_like ~ctx (type_ : GType.t) (expr : Expr.t) : Asrt.t = - let open Asrt.Infix in match type_ with | CInteger I_bool -> (* Special case, the bounds are different *) let assume_int = Asrt.Types [ (expr, IntType) ] in let condition = - let open Formula.Infix in - expr #== Expr.one_i #|| (expr #== Expr.zero_i) + let open Expr.Infix in + expr == Expr.one_i || expr == Expr.zero_i in let asrt_range = Asrt.Pure condition in - assume_int ** asrt_range + [ assume_int; asrt_range ] | CInteger _ | Signedbv _ | Unsignedbv _ -> let assume_int = Asrt.Types [ (expr, IntType) ] in let bounds = @@ -22,26 +21,24 @@ let rec asrt_of_scalar_like ~ctx (type_ : GType.t) (expr : Expr.t) : Asrt.t = match bounds with | None -> Asrt.Emp | Some (low, high) -> - let open Formula.Infix in - let condition = - (Expr.int_z low) #<= expr #&& (expr #<= (Expr.int_z high)) - in + let open Expr.Infix in + let condition = Expr.int_z low <= expr && expr <= Expr.int_z high in Asrt.Pure condition in - assume_int ** assume_range - | Double | Float -> Asrt.Types [ (expr, NumberType) ] + [ assume_int; assume_range ] + | Double | Float -> [ Asrt.Types [ (expr, NumberType) ] ] | Pointer _ -> let loc = LVar.alloc () in let ofs = LVar.alloc () in let e_loc = Expr.LVar loc in let e_ofs = Expr.LVar ofs in let assume_list = - let f = Formula.Eq (expr, EList [ e_loc; e_ofs ]) in + let f = Expr.BinOp (expr, Equal, EList [ e_loc; e_ofs ]) in Asrt.Pure f in let types = Asrt.Types [ (e_loc, ObjectType); (e_ofs, IntType) ] in - assume_list ** types - | Bool -> Asrt.Types [ (expr, BooleanType) ] + [ assume_list; types ] + | Bool -> [ Asrt.Types [ (expr, BooleanType) ] ] | StructTag _ | Struct _ -> let ty = let fields = Ctx.resolve_struct_components ctx type_ in @@ -56,11 +53,10 @@ let rec asrt_of_scalar_like ~ctx (type_ : GType.t) (expr : Expr.t) : Asrt.t = let assumption_of_param ~ctx ~(v : Var.t) ~(ty : GType.t) = (* The logic of what formulaes is generated should be factorised with [Compiled_expr.nondet_expr] *) - let open Asrt.Infix in if Ctx.representable_in_store ctx ty then let e_s = Expr.LVar (LVar.alloc ()) in - let f = Formula.Eq (Expr.PVar v, e_s) in - Asrt.Pure f ** asrt_of_scalar_like ~ctx ty e_s + let f = Expr.BinOp (Expr.PVar v, Equal, e_s) in + Asrt.Pure f :: asrt_of_scalar_like ~ctx ty e_s else failwith "unhandled: composit parameter" let assumption_of_ret_by_copy ~ctx ty = @@ -71,11 +67,11 @@ let assumption_of_ret_by_copy ~ctx ty = ~perm:(Some Freeable) in let types = Asrt.Types [ (loc, ObjectType) ] in - Asrt.Star (types, hole) + [ types; hole ] let bispec ~ctx ~(compiled : (C2_annot.t, string) Proc.t) (f : Program.Func.t) = let ret_type_assume = - if Ctx.representable_in_store ctx f.return_type then Asrt.Emp + if Ctx.representable_in_store ctx f.return_type then [] else assumption_of_ret_by_copy ~ctx f.return_type in let param_names = @@ -88,7 +84,7 @@ let bispec ~ctx ~(compiled : (C2_annot.t, string) Proc.t) (f : Program.Func.t) = (fun v Param.{ type_ = ty; _ } -> assumption_of_param ~ctx ~v ~ty) param_names f.params in - let pre = List.fold_left Asrt.Infix.( ** ) ret_type_assume param_asrts in + let pre = ret_type_assume @ List.flatten param_asrts in BiSpec. { bispec_name = compiled.proc_name; diff --git a/Gillian-C2/lib/memory_model/GEnv.ml b/Gillian-C2/lib/memory_model/GEnv.ml index 6906b027..8b0fef6b 100644 --- a/Gillian-C2/lib/memory_model/GEnv.ml +++ b/Gillian-C2/lib/memory_model/GEnv.ml @@ -16,10 +16,10 @@ module Make (Def_value : sig end) (Delayed_hack : sig type 'a t - val ( #== ) : Def_value.t -> Def_value.t -> Gil_syntax.Formula.t list + val ( #== ) : Def_value.t -> Def_value.t -> Gil_syntax.Expr.t list val return : - ?learned:Gil_syntax.Formula.t list -> + ?learned:Gil_syntax.Expr.t list -> ?learned_types:(string * Gil_syntax.Type.t) list -> 'a -> 'a t @@ -280,8 +280,8 @@ module Symbolic = let ( let+ ) = map let ( #== ) a b = - let open Gil_syntax.Formula.Infix in - [ a #== b ] + let open Gil_syntax.Expr.Infix in + [ a == b ] let resolve_or_create_lt lvar_loc : string t = let open Syntax in diff --git a/Gillian-C2/lib/memory_model/GEnv.mli b/Gillian-C2/lib/memory_model/GEnv.mli index 6723bb82..5e4affdc 100644 --- a/Gillian-C2/lib/memory_model/GEnv.mli +++ b/Gillian-C2/lib/memory_model/GEnv.mli @@ -39,7 +39,7 @@ module Concrete : sig (** {3 Symbolic things} *) val substitution : Gillian.Symbolic.Subst.t -> t -> t - val assertions : t -> string list * Gillian.Gil_syntax.Asrt.t list + val assertions : t -> string list * Gillian.Gil_syntax.Asrt.t end module Symbolic : sig @@ -79,5 +79,5 @@ module Symbolic : sig (** {3 Symbolic things} *) val substitution : Gillian.Symbolic.Subst.t -> t -> t - val assertions : t -> string list * Gillian.Gil_syntax.Asrt.t list + val assertions : t -> string list * Gillian.Gil_syntax.Asrt.t end diff --git a/Gillian-C2/lib/memory_model/MonadicSMemory.ml b/Gillian-C2/lib/memory_model/MonadicSMemory.ml index 1b416490..9122e480 100644 --- a/Gillian-C2/lib/memory_model/MonadicSMemory.ml +++ b/Gillian-C2/lib/memory_model/MonadicSMemory.ml @@ -19,7 +19,7 @@ let resolve_or_create_loc_name (lvar_loc : Expr.t) : string Delayed.t = match loc_name with | None -> let new_loc_name = ALoc.alloc () in - let learned = [ Formula.Eq (ALoc new_loc_name, lvar_loc) ] in + let learned = [ Expr.BinOp (ALoc new_loc_name, Equal, lvar_loc) ] in Logging.verbose (fun fmt -> fmt "Couldn't resolve loc %a, created %s" Expr.pp lvar_loc new_loc_name); @@ -180,8 +180,8 @@ module Mem = struct let open DR.Syntax in let** loc_name = resolve_loc_result loc in - let open Formula.Infix in - if%sat size #<= (Expr.int 0) then DR.error (NonPositiveArraySize size) + let open Expr.Infix in + if%sat size <= Expr.int 0 then DR.error (NonPositiveArraySize size) else let** tree = get_tree_res map loc_name in let++ sarr, perm, new_tree = @@ -193,8 +193,8 @@ module Mem = struct let open DR.Syntax in let** loc_name = resolve_loc_result loc in - let open Formula.Infix in - if%sat size #<= (Expr.int 0) then DR.error (NonPositiveArraySize size) + let open Expr.Infix in + if%sat size <= Expr.int 0 then DR.error (NonPositiveArraySize size) else let** tree = get_tree_res map loc_name in let++ sarr, perm, new_tree = @@ -204,8 +204,8 @@ module Mem = struct let prod_array map loc ofs size chunk array perm = let open DR.Syntax in - let open Formula.Infix in - if%sat size #<= (Expr.int 0) then DR.ok map + let open Expr.Infix in + if%sat size <= Expr.int 0 then DR.ok map else let* loc_name = resolve_or_create_loc_name loc in let* tree = get_or_create_tree map loc_name in @@ -231,9 +231,9 @@ module Mem = struct let cons_simple ~sheap_consumer map loc low high = let open DR.Syntax in - let open Formula.Infix in + let open Expr.Infix in let** loc_name = resolve_loc_result loc in - if%sat high #<= low then DR.ok (map, Some Perm.Freeable) + if%sat high <= low then DR.ok (map, Some Perm.Freeable) else let** tree = get_tree_res map loc_name in let++ new_tree, perm = @@ -243,8 +243,8 @@ module Mem = struct let prod_simple ~sheap_producer map loc low high perm = let open DR.Syntax in - let open Formula.Infix in - if%sat high #<= low then DR.ok map + let open Expr.Infix in + if%sat high <= low then DR.ok map else let* loc_name = resolve_or_create_loc_name loc in let* tree = get_or_create_tree map loc_name in @@ -287,8 +287,8 @@ module Mem = struct let move map dst_loc dst_ofs src_loc src_ofs sz = let open DR.Syntax in - let open Formula.Infix in - if%sat sz #== (Expr.int 0) then DR.ok map + let open Expr.Infix in + if%sat sz == Expr.int 0 then DR.ok map else let** dst_loc_name = resolve_loc_result dst_loc in let** src_loc_name = resolve_loc_result src_loc in diff --git a/Gillian-C2/lib/memory_model/SHeapTree.ml b/Gillian-C2/lib/memory_model/SHeapTree.ml index 453356ac..16560cbc 100644 --- a/Gillian-C2/lib/memory_model/SHeapTree.ml +++ b/Gillian-C2/lib/memory_model/SHeapTree.ml @@ -98,18 +98,18 @@ module Range = struct (low, low + (sz_chunk * size)) let is_equal (la, ha) (lb, hb) = - let open Formula.Infix in - la #== lb #&& (ha #== hb) + let open Expr.Infix in + la == lb && ha == hb let is_inside (la, ha) (lb, hb) = - let open Formula.Infix in - lb #<= la #&& (ha #<= hb) + let open Expr.Infix in + lb <= la && ha <= hb let size (a, b) = Expr.Infix.( - ) b a let point_strictly_inside x (l, h) = - let open Formula.Infix in - l #< x #&& (x #< h) + let open Expr.Infix in + l < x && x < h let split_at (l, h) x = ((l, x), (x, h)) let lvars (a, b) = SS.union (Expr.lvars a) (Expr.lvars b) @@ -259,8 +259,8 @@ module Node = struct let chunk = SVal.leak_chunk sv in let chunk_size = Expr.int (Chunk.size chunk) in let zeros_can_be_converted_to_same_chunk = - let open Formula.Infix in - (Expr.imod size_right chunk_size) #== Expr.zero_i + let open Expr.Infix in + Expr.imod size_right chunk_size == Expr.zero_i in if%ent zeros_can_be_converted_to_same_chunk then let+ zero_array = @@ -287,8 +287,8 @@ module Node = struct let chunk = SVal.leak_chunk sv in let chunk_size = Expr.int (Chunk.size chunk) in let zeros_can_be_converted_to_same_chunk = - let open Formula.Infix in - (Expr.imod size_left chunk_size) #== Expr.zero_i + let open Expr.Infix in + Expr.imod size_left chunk_size == Expr.zero_i in if%ent zeros_can_be_converted_to_same_chunk then let+ zero_array = @@ -317,8 +317,8 @@ module Node = struct let chunk = SVArr.leak_chunk arr in let chunk_size = Expr.int (Chunk.size chunk) in let zeros_can_be_converted_to_same_chunk = - let open Formula.Infix in - (Expr.imod size_left chunk_size) #== Expr.zero_i + let open Expr.Infix in + Expr.imod size_left chunk_size == Expr.zero_i in if%ent zeros_can_be_converted_to_same_chunk then let+ zero_array = @@ -338,8 +338,8 @@ module Node = struct let chunk = SVArr.leak_chunk arr in let chunk_size = Expr.int (Chunk.size chunk) in let zeros_can_be_converted_to_same_chunk = - let open Formula.Infix in - (Expr.imod size_right chunk_size) #== Expr.zero_i + let open Expr.Infix in + Expr.imod size_right chunk_size == Expr.zero_i in if%ent zeros_can_be_converted_to_same_chunk then let+ zero_array = @@ -563,14 +563,14 @@ module Tree = struct let rec split ~range t : (Node.t * t * t) Delayed.t = (* this function splits a tree and returns the node in the given range *) (* We're assuming that range is inside old_span *) - let open Formula.Infix in + let open Expr.Infix in let open Delayed.Syntax in let old_span = t.span in let ol, oh = old_span in let nl, nh = range in if%sat log_string "ol #== nl"; - ol #== nl + ol == nl then let at = nh in let+ left_node, right_node = Node.split ~span:old_span ~at t.node in @@ -581,7 +581,7 @@ module Tree = struct else if%sat log_string "oh #== nh"; - oh #== nh + oh == nh then let at = nl in let+ left_node, right_node = Node.split ~span:old_span ~at t.node in @@ -602,12 +602,12 @@ module Tree = struct (node, left, right) let extend_if_needed t range = - let open Formula.Infix in + let open Expr.Infix in let open Delayed.Syntax in let rl, rh = range in let sl, sh = t.span in let* t_with_left = - if%sat rl #< sl then + if%sat rl < sl then let new_left_tree = make ~node:(NotOwned Totally) ~span:(rl, sl) () in let children = (new_left_tree, t) in Delayed.return @@ -616,7 +616,7 @@ module Tree = struct in let sl, _ = t_with_left.span in let* result = - if%sat rh #> sh then + if%sat rh > sh then let new_right_tree = make ~node:(NotOwned Totally) ~span:(sh, rh) () in let children = (t_with_left, new_right_tree) in Delayed.return @@ -1117,7 +1117,7 @@ let get_root = function let is_in_bounds range bounds = match bounds with - | None -> Formula.True + | None -> Expr.true_ | Some bounds -> Range.is_inside range bounds let get_perm_at t ofs = @@ -1139,10 +1139,10 @@ let get_perm_at t ofs = let weak_valid_pointer (t : t) (ofs : Expr.t) : (bool, err) DR.t = let is_sure_false bounds ofs = - let open Formula.Infix in + let open Expr.Infix in match bounds with - | None -> Formula.False - | Some (low, high) -> ofs #< low #|| (ofs #> high) + | None -> Expr.false_ + | Some (low, high) -> ofs < low || ofs > high in match t with | Freed -> DR.ok false @@ -1360,8 +1360,8 @@ let _check_valid_alignment chunk ofs = let al = Chunk.align chunk in let al_expr = Expr.int al in let divides x y = - let open Formula.Infix in - Expr.(y #== (int 0)) #|| ((Expr.imod y x) #== (Expr.int 0)) + let open Expr.Infix in + y == Expr.int 0 || Expr.imod y x == Expr.int 0 in if%sat divides al_expr ofs then DR.ok () else DR.error (InvalidAlignment { offset = ofs; alignment = al }) diff --git a/Gillian-C2/lib/memory_model/SHeapTree.mli b/Gillian-C2/lib/memory_model/SHeapTree.mli index e0e13f8e..40a91970 100644 --- a/Gillian-C2/lib/memory_model/SHeapTree.mli +++ b/Gillian-C2/lib/memory_model/SHeapTree.mli @@ -74,7 +74,7 @@ val weak_valid_pointer : t -> Expr.t -> bool d_or_error [dst_tree] after modification *) val move : t -> Expr.t -> t -> Expr.t -> Expr.t -> t d_or_error -val assertions : loc:string -> t -> Asrt.t list +val assertions : loc:string -> t -> Asrt.t val substitution : le_subst:(Expr.t -> Expr.t) -> diff --git a/Gillian-C2/lib/memory_model/SVal.ml b/Gillian-C2/lib/memory_model/SVal.ml index b239278a..a67706ab 100644 --- a/Gillian-C2/lib/memory_model/SVal.ml +++ b/Gillian-C2/lib/memory_model/SVal.ml @@ -21,18 +21,18 @@ module SVal = struct { v with value } let unsign_int ~bit_size (e : Expr.t) = - let open Formula.Infix in - if%sat Expr.zero_i #<= e then Delayed.return e + let open Expr.Infix in + if%sat Expr.zero_i <= e then Delayed.return e else let two_power_size = Z.(one lsl bit_size) in let open Expr.Infix in Delayed.return (e + Expr.int_z two_power_size) let sign_int ~bit_size (e : Expr.t) = - let open Formula.Infix in + let open Expr.Infix in let two_power_size = Z.(one lsl bit_size) in let imax = Expr.int_z Z.((two_power_size asr 1) - one) in - if%sat e #<= imax then Delayed.return e + if%sat e <= imax then Delayed.return e else let open Expr.Infix in Delayed.return (e - Expr.int_z two_power_size) @@ -77,8 +77,8 @@ module SVal = struct let learned = match Chunk.bounds chunk with | Some (low, high) -> - let open Formula.Infix in - [ lvar_e #>= (Expr.int_z low); lvar_e #<= (Expr.int_z high) ] + let open Expr.Infix in + [ lvar_e >= Expr.int_z low; lvar_e <= Expr.int_z high ] | None -> [] in (learned_types, learned) @@ -132,8 +132,8 @@ module SVal = struct let all_bytes = List.map (fun lv -> - let open Formula.Infix in - Expr.zero_i #<= lv #&& (lv #<= (Expr.int 255))) + let open Expr.Infix in + Expr.zero_i <= lv && lv <= Expr.int 255) exprs in (* We take the bytes from small to big *) @@ -148,8 +148,8 @@ module SVal = struct (Z.shift_left i 8, res_expr)) (Z.one, Expr.zero_i) exprs in - let open Formula.Infix in - unsigned_value #== (snd total_sum_bytes) + let open Expr.Infix in + unsigned_value == snd total_sum_bytes in let learned = add_to_sval :: all_bytes in let result = @@ -270,7 +270,6 @@ module SVArray = struct else None let make_zeros ~chunk ~size : t Delayed.t = - let open Formula.Infix in let return ?learned ?learned_types values = Delayed.return ?learned ?learned_types { chunk; values } in @@ -286,21 +285,21 @@ module SVArray = struct in return values | _ -> + let open Expr.Infix in Logging.verbose (fun fmt -> fmt "Zeros pf: not as concrete: %a" Expr.pp size); let values_var = LVar.alloc () in let values = Expr.LVar values_var in - let is_zero e = e #== (Expr.int 0) in let i = LVar.alloc () in let i_e = Expr.LVar i in let zero = Expr.zero_i in let learned_types = [ (values_var, Type.ListType) ] in - let correct_length = (Expr.list_length values) #== size in + let correct_length = Expr.list_length values == size in let all_zero = forall [ (i, Some IntType) ] - zero #<= i_e #&& (i_e #< size) - #=> (is_zero (Expr.list_nth_e values i_e)) + ((zero <= i_e && i_e < size) + ==> (Expr.list_nth_e values i_e == zero)) in return ~learned:[ correct_length; all_zero ] ~learned_types values @@ -466,8 +465,8 @@ module SVArray = struct let split_at_byte ~at arr : (t * t) Delayed.t = let chunk_size = Expr.int (Chunk.size arr.chunk) in let can_keep_chunk = - let open Formula.Infix in - (Expr.imod at chunk_size) #== Expr.zero_i + let open Expr.Infix in + Expr.imod at chunk_size == Expr.zero_i in if%ent can_keep_chunk then Delayed.return (split_at_offset ~at:Expr.Infix.(at / chunk_size) arr) diff --git a/Gillian-C2/lib/memory_model/predicates.ml b/Gillian-C2/lib/memory_model/predicates.ml index 26cf9c72..80a296fc 100644 --- a/Gillian-C2/lib/memory_model/predicates.ml +++ b/Gillian-C2/lib/memory_model/predicates.ml @@ -3,7 +3,7 @@ open Gil_syntax module Core = struct let pred ga ins outs = let ga_name = Interface.str_ga ga in - Asrt.GA (ga_name, ins, outs) + Asrt.CorePred (ga_name, ins, outs) let single ~loc ~ofs ~chunk ~sval ~perm = let chunk = Expr.Lit (String (Chunk.to_string chunk)) in diff --git a/Gillian-JS/lib/Compiler/JS2JSIL_Compiler.ml b/Gillian-JS/lib/Compiler/JS2JSIL_Compiler.ml index 63f739d7..a3311476 100644 --- a/Gillian-JS/lib/Compiler/JS2JSIL_Compiler.ml +++ b/Gillian-JS/lib/Compiler/JS2JSIL_Compiler.ml @@ -84,7 +84,7 @@ let prefix_lcmds let is_list_type x = BinOp (UnOp (TypeOf, x), Equal, lit_typ ListType) let is_vref x = BinOp (rtype x, Equal, lit_refv) let is_oref x = BinOp (rtype x, Equal, lit_refo) -let is_ref x = BinOp (is_vref x, BOr, is_oref x) +let is_ref x = BinOp (is_vref x, Or, is_oref x) let rec get_break_lab loop_list lab = match loop_list with @@ -206,14 +206,14 @@ let non_writable_ref_test x = let right_e = BinOp ( BinOp (field x, Equal, lit_str "eval"), - BOr, + Or, BinOp (field x, Equal, Lit (String "arguments")) ) in - BinOp (left_e, BAnd, right_e) + BinOp (left_e, And, right_e) let make_unresolvable_ref_test x = BinOp - (BinOp (base x, Equal, Lit Null), BOr, BinOp (base x, Equal, Lit Undefined)) + (BinOp (base x, Equal, Lit Null), Or, BinOp (base x, Equal, Lit Undefined)) let make_get_value_call x err = (* x_v := getValue (x) with err *) @@ -437,7 +437,7 @@ let translate_binop_plus x1 x2 x1_v x2_v err = let goto_guard_right = BinOp (UnOp (TypeOf, PVar x2_p), Equal, Lit (Type StringType)) in - let goto_guard = BinOp (goto_guard_left, BOr, goto_guard_right) in + let goto_guard = BinOp (goto_guard_left, Or, goto_guard_right) in let cmd_goto = LGuardedGoto (goto_guard, then_lab, else_lab) in (* then: x1_s := i__toString (x1_p) with err *) @@ -598,7 +598,7 @@ let translate_binop_equality _ _ x1_v x2_v non_strict non_negated err = | false -> let x_r2 = fresh_var () in (* x_r2 := (not x_r1) *) - ([ (None, LBasic (Assignment (x_r2, UnOp (UNot, PVar x_r1)))) ], x_r2) + ([ (None, LBasic (Assignment (x_r2, UnOp (Not, PVar x_r1)))) ], x_r2) in let new_cmds = [ (None, cmd_ass_xr1) ] @ cmd_ass_xr2 in @@ -1699,7 +1699,7 @@ let rec translate_expr tr_ctx e : let next1 = fresh_next_label () in let goto_guard_expr = UnOp - ( UNot, + ( Not, BinOp (UnOp (TypeOf, PVar x_f_val), Equal, Lit (Type ObjectType)) ) in let cmd_goto_is_obj = @@ -2075,7 +2075,7 @@ let rec translate_expr tr_ctx e : let le = SSubst.subst_in_expr subst ~partial:true e' in let asrt = - match Formula.lift_logic_expr le with + match Expr.as_boolean_expr le with | Some (asrt_b, _) -> asrt_b | _ -> raise @@ -2119,7 +2119,7 @@ let rec translate_expr tr_ctx e : let le = SSubst.subst_in_expr subst ~partial:true e' in let asrt = - match Formula.lift_logic_expr le with + match Expr.as_boolean_expr le with | Some (asrt_b, _) -> asrt_b | _ -> raise @@ -2143,16 +2143,22 @@ let rec translate_expr tr_ctx e : let cmd1 = (metadata, None, LLogic (LCmd.FreshSVar x_v)) in let x_v = PVar x_v in let cmd2 = - (metadata, None, LLogic (LCmd.Assume (Not (Eq (x_v, Lit Empty))))) + ( metadata, + None, + LLogic (LCmd.Assume (UnOp (Not, BinOp (x_v, Equal, Lit Empty)))) ) in let cmd3 = - (metadata, None, LLogic (LCmd.Assume (Not (Eq (x_v, Lit Nono))))) + ( metadata, + None, + LLogic (LCmd.Assume (UnOp (Not, BinOp (x_v, Equal, Lit Nono)))) ) in let cmd4 = ( metadata, None, LLogic - (LCmd.Assume (Not (Eq (UnOp (TypeOf, x_v), Lit (Type ListType))))) + (LCmd.Assume + (UnOp + (Not, BinOp (UnOp (TypeOf, x_v), Equal, Lit (Type ListType))))) ) in ([ cmd1; cmd2; cmd3; cmd4 ], x_v, []) @@ -2274,7 +2280,7 @@ let rec translate_expr tr_ctx e : let next1 = fresh_next_label () in let goto_guard_expr = UnOp - ( UNot, + ( Not, BinOp (UnOp (TypeOf, PVar x_f_val), Equal, Lit (Type ObjectType)) ) in let cmd_goto_is_obj = @@ -2934,7 +2940,7 @@ let rec translate_expr tr_ctx e : (* x_r := (not x_b) *) let x_r = fresh_var () in - let cmd_xr_ass = LBasic (Assignment (x_r, UnOp (UNot, PVar x_b))) in + let cmd_xr_ass = LBasic (Assignment (x_r, UnOp (Not, PVar x_b))) in let cmds = annotate_first_cmd @@ -3265,7 +3271,7 @@ let rec translate_expr tr_ctx e : tr_ctx.tr_err_lab in let x_r2 = fresh_var () in - let new_cmd = LBasic (Assignment (x_r2, UnOp (UNot, PVar x_r1))) in + let new_cmd = LBasic (Assignment (x_r2, UnOp (Not, PVar x_r1))) in let cmds = annotate_first_cmd (cmds1 @@ -3310,7 +3316,7 @@ let rec translate_expr tr_ctx e : tr_ctx.tr_err_lab in let x_r2 = fresh_var () in - let new_cmd = LBasic (Assignment (x_r2, UnOp (UNot, PVar x_r1))) in + let new_cmd = LBasic (Assignment (x_r2, UnOp (Not, PVar x_r1))) in let cmds = annotate_first_cmd (cmds1 @@ -5325,7 +5331,7 @@ and translate_statement tr_ctx e = let next1 = fresh_next_label () in let next2 = fresh_next_label () in let expr_goto_guard = BinOp (PVar x_ret_2, Equal, Lit Empty) in - let expr_goto_guard = UnOp (UNot, expr_goto_guard) in + let expr_goto_guard = UnOp (Not, expr_goto_guard) in let cmd_goto_empty_test = LGuardedGoto (expr_goto_guard, next1, next2) in (* x_ret_3 := PHI(x_ret_1, x_ret_2) *) @@ -5473,7 +5479,7 @@ and translate_statement tr_ctx e = let next1 = fresh_next_label () in let next2 = fresh_next_label () in let expr_goto_guard = BinOp (PVar x_ret_2, Equal, Lit Empty) in - let expr_goto_guard = UnOp (UNot, expr_goto_guard) in + let expr_goto_guard = UnOp (Not, expr_goto_guard) in let cmd_goto_empty_test = LGuardedGoto (expr_goto_guard, next1, next2) in (* x_ret_3 := PHI(x_ret_1, x_ret_2) *) @@ -5627,7 +5633,7 @@ and translate_statement tr_ctx e = let expr_goto_guard = BinOp ( BinOp (PVar x2_v, Equal, Lit Null), - BOr, + Or, BinOp (PVar x2_v, Equal, Lit Undefined) ) in let cmd_goto_null_undef = LGuardedGoto (expr_goto_guard, next6, next0) in @@ -5717,7 +5723,7 @@ and translate_statement tr_ctx e = (* goto [ not (x_ret_2 = empty) ] next2 next3 *) let expr_goto_guard = BinOp (PVar x_ret_2, Equal, Lit Empty) in - let expr_goto_guard = UnOp (UNot, expr_goto_guard) in + let expr_goto_guard = UnOp (Not, expr_goto_guard) in let cmd_goto_xret2 = LGuardedGoto (expr_goto_guard, next2, next3) in (* x_ret_3 := PHI(x_ret_1, x_ret_2) *) @@ -5952,7 +5958,7 @@ and translate_statement tr_ctx e = let next1 = fresh_next_label () in let next2 = fresh_next_label () in let expr_goto_guard = BinOp (PVar x_ret_2, Equal, Lit Empty) in - let expr_goto_guard = UnOp (UNot, expr_goto_guard) in + let expr_goto_guard = UnOp (Not, expr_goto_guard) in let cmd_goto_empty_test = LGuardedGoto (expr_goto_guard, next1, next2) in (* next2: x_ret_3 := PHI(x_ret_1, x_ret_2) *) @@ -6323,7 +6329,7 @@ and translate_statement tr_ctx e = (* goto [ not x_prev_found ] next1 next2 *) let cmd_goto_1 = - LGuardedGoto (UnOp (UNot, PVar x_prev_found), next1, next2) + LGuardedGoto (UnOp (Not, PVar x_prev_found), next1, next2) in (* x1_v := getValue (x1) with err *) @@ -6428,7 +6434,7 @@ and translate_statement tr_ctx e = (* goto [ not (x_found_b) ] next end_switch *) let next = fresh_next_label () in let cmd_goto = - LGuardedGoto (UnOp (UNot, PVar x_found_b), next, end_switch) + LGuardedGoto (UnOp (Not, PVar x_found_b), next, end_switch) in let cmds_def = add_initial_label cmds_def next metadata in @@ -6800,7 +6806,7 @@ let generate_main e strictness spec : EProc.t = make_final_cmd errs ctx.tr_err_lab Names.return_variable origin_loc in let lab_err_cmd = annotate_cmd LReturnError None in - let global_err_asrt = annotate_cmd (LLogic (LCmd.Assert False)) None in + let global_err_asrt = annotate_cmd (LLogic (LCmd.Assert Expr.false_)) None in let err_cmds = if !Javert_utils.Js_config.cosette then [ cmd_err_phi_node; global_err_asrt; lab_err_cmd ] diff --git a/Gillian-JS/lib/Compiler/JSIL2GIL.ml b/Gillian-JS/lib/Compiler/JSIL2GIL.ml index 24c82b45..31ccae3c 100644 --- a/Gillian-JS/lib/Compiler/JSIL2GIL.ml +++ b/Gillian-JS/lib/Compiler/JSIL2GIL.ml @@ -34,7 +34,7 @@ let fresh_var, reset_var = fresh_sth "gvar_aux_" let resource_error args = if Utils.Exec_mode.is_biabduction_exec !Config.current_exec_mode then - GCmd.Logic (GLCmd.Assume False) + GCmd.Logic (GLCmd.Assume Expr.false_) else Fail (JSILNames.resourceError, args) let reset_generators () = @@ -74,39 +74,20 @@ let rec jsil2gil_expr (e : Expr.t) : Expr.t = ESet es | _ -> e -let rec jsil2gil_formula (f : Gil.Formula.t) : Gil.Formula.t = - let ff = jsil2gil_formula in - let fe = jsil2gil_expr in - match f with - | True | False -> f - | Not f -> Not (ff f) - | And (f1, f2) -> And (ff f1, ff f2) - | Or (f1, f2) -> Or (ff f1, ff f2) - | Impl (f1, f2) -> Impl (ff f1, ff f2) - | Eq (e1, e2) -> Eq (fe e1, fe e2) - | FLess (e1, e2) -> FLess (fe e1, fe e2) - | FLessEq (e1, e2) -> FLessEq (fe e1, fe e2) - | ILess (e1, e2) -> ILess (fe e1, fe e2) - | ILessEq (e1, e2) -> ILessEq (fe e1, fe e2) - | StrLess (e1, e2) -> StrLess (fe e1, fe e2) - | SetMem (e1, e2) -> SetMem (fe e1, fe e2) - | SetSub (e1, e2) -> SetSub (fe e1, fe e2) - | ForAll (qts, f) -> ForAll (qts, ff f) - | IsInt e -> IsInt (fe e) - let rec jsil2gil_asrt (a : Asrt.t) : GAsrt.t = let f = jsil2gil_asrt in let fe = jsil2gil_expr in match a with - | Emp -> Emp - | Star (a1, a2) -> Star (f a1, f a2) + | Emp -> [ Emp ] + | Star (a1, a2) -> f a1 @ f a2 | PointsTo (e1, e2, e3) -> - Asrt_utils.points_to ~loc:(fe e1) ~field:(fe e2) ~value:(fe e3) - | MetaData (e1, e2) -> Asrt_utils.metadata ~loc:(fe e1) ~metadata:(fe e2) - | EmptyFields (e1, e2) -> Asrt_utils.empty_fields ~loc:(fe e1) ~domain:(fe e2) - | Pred (pn, es) -> Pred (pn, List.map fe es) - | Pure f -> Pure (jsil2gil_formula f) - | Types vts -> Types (List.map (fun (v, t) -> (fe v, t)) vts) + [ Asrt_utils.points_to ~loc:(fe e1) ~field:(fe e2) ~value:(fe e3) ] + | MetaData (e1, e2) -> [ Asrt_utils.metadata ~loc:(fe e1) ~metadata:(fe e2) ] + | EmptyFields (e1, e2) -> + [ Asrt_utils.empty_fields ~loc:(fe e1) ~domain:(fe e2) ] + | Pred (pn, es) -> [ Pred (pn, List.map fe es) ] + | Pure f -> [ Pure (jsil2gil_expr f) ] + | Types vts -> [ Types (List.map (fun (v, t) -> (fe v, t)) vts) ] let jsil2gil_slcmd (slcmd : SLCmd.t) : GSLCmd.t = match slcmd with @@ -121,13 +102,12 @@ let rec jsil2gil_lcmd (lcmd : LCmd.t) : GLCmd.t = let f = jsil2gil_lcmd in let fs = List.map f in let fe = jsil2gil_expr in - let ff = jsil2gil_formula in match lcmd with | If (e, lcmds1, lcmds2) -> If (fe e, fs lcmds1, fs lcmds2) - | Branch f -> Branch (ff f) + | Branch f -> Branch (fe f) | Macro (x, es) -> Macro (x, List.map fe es) - | Assert f -> Assert (ff f) - | Assume f -> Assume (ff f) + | Assert f -> Assert (fe f) + | Assume f -> Assume (fe f) | AssumeType (x, t) -> AssumeType (fe x, t) | FreshSVar x -> FreshSVar x | SL slcmd -> SL (jsil2gil_slcmd slcmd) @@ -188,7 +168,7 @@ let jsil2gil_pred (pred : Pred.t) : GPred.t = pred_ins = pred.ins; pred_definitions = List.map (fun (info, asrt) -> (info, jsil2gil_asrt asrt)) pred.definitions; - pred_facts = List.map jsil2gil_formula pred.facts; + pred_facts = List.map jsil2gil_expr pred.facts; pred_guard = None; (* TODO: Support for predicates with tokens *) pred_pure = pred.pure; @@ -382,7 +362,7 @@ let jsil2core (lab : string option) (cmd : LabCmd.t) : let aux3 = fresh_var () in let e = Expr.UnOp - (UNot, BinOp (BinOp (PVar aux3, LstNth, Expr.int 2), Equal, Lit Nono)) + (Not, BinOp (BinOp (PVar aux3, LstNth, Expr.int 2), Equal, Lit Nono)) in let cmd1 : string GCmd.t = Assignment (aux1, fe e1) in let cmd2 : string GCmd.t = Assignment (aux2, fe e2) in diff --git a/Gillian-JS/lib/Compiler/JSIL_PostParser.ml b/Gillian-JS/lib/Compiler/JSIL_PostParser.ml index 5a2e3e57..f253e3f8 100644 --- a/Gillian-JS/lib/Compiler/JSIL_PostParser.ml +++ b/Gillian-JS/lib/Compiler/JSIL_PostParser.ml @@ -86,10 +86,12 @@ let make_sc (vis_list : string list) : Expr.t list = List.map expr_from_fid chopped_vis_list let asrts_js_val (x_val : Expr.t) : Asrt.t list = - let asrt_empty : Asrt.t = Pure (Not (Eq (x_val, Lit Empty))) in - let asrt_none : Asrt.t = Pure (Not (Eq (x_val, Lit Nono))) in + let asrt_empty : Asrt.t = + Pure (UnOp (Not, BinOp (x_val, Equal, Lit Empty))) + in + let asrt_none : Asrt.t = Pure (UnOp (Not, BinOp (x_val, Equal, Lit Nono))) in let asrt_list : Asrt.t = - Pure (Not (Eq (UnOp (TypeOf, x_val), Lit (Type ListType)))) + Pure (UnOp (Not, BinOp (UnOp (TypeOf, x_val), Equal, Lit (Type ListType)))) in [ asrt_empty; asrt_none; asrt_list ] @@ -114,21 +116,22 @@ let var_assertion (fid : string) (x : string) (x_val : Expr.t) : Asrt.t = let make_this_assertion () : Asrt.t = let var_this = JS2JSIL_Helpers.var_this in - let f1 : Formula.t = - Not (Eq (UnOp (TypeOf, LVar "#this"), Lit (Type ListType))) + let f1 : Expr.t = + UnOp (Not, BinOp (UnOp (TypeOf, LVar "#this"), Equal, Lit (Type ListType))) in - let f2 : Formula.t = - Not (Eq (UnOp (TypeOf, LVar "#this"), Lit (Type NumberType))) + let f2 : Expr.t = + UnOp (Not, BinOp (UnOp (TypeOf, LVar "#this"), Equal, Lit (Type NumberType))) in - let f3 : Formula.t = - Not (Eq (UnOp (TypeOf, LVar "#this"), Lit (Type StringType))) + let f3 : Expr.t = + UnOp (Not, BinOp (UnOp (TypeOf, LVar "#this"), Equal, Lit (Type StringType))) in - let f4 : Formula.t = - Not (Eq (UnOp (TypeOf, LVar "#this"), Lit (Type BooleanType))) + let f4 : Expr.t = + UnOp + (Not, BinOp (UnOp (TypeOf, LVar "#this"), Equal, Lit (Type BooleanType))) in - let f5 : Formula.t = Not (Eq (LVar "#this", Lit Empty)) in - let f6 : Formula.t = Eq (LVar "#this", PVar var_this) in - Asrt.Pure (Formula.conjunct [ f1; f2; f3; f4; f5; f6 ]) + let f5 : Expr.t = UnOp (Not, BinOp (LVar "#this", Equal, Lit Empty)) in + let f6 : Expr.t = BinOp (LVar "#this", Equal, PVar var_this) in + Asrt.Pure (Expr.conjunct [ f1; f2; f3; f4; f5; f6 ]) let scope_info_to_assertion (eprog : EProg.t) @@ -144,7 +147,7 @@ let scope_info_to_assertion in let a_schain = - Asrt.Pure (Eq (PVar JS2JSIL_Helpers.var_scope, EList sc_bindings)) + Asrt.Pure (BinOp (PVar JS2JSIL_Helpers.var_scope, Equal, EList sc_bindings)) in let glob_constraints = @@ -152,7 +155,9 @@ let scope_info_to_assertion | _ :: les -> List.map (fun le -> - Asrt.Pure (Not (Eq (le, Lit (Loc JS2JSIL_Helpers.locGlobName))))) + Asrt.Pure + (UnOp + (Not, BinOp (le, Equal, Lit (Loc JS2JSIL_Helpers.locGlobName))))) les | _ -> [] in @@ -190,7 +195,7 @@ let scope_info_to_assertion else if SS.mem x args then let x_val : Expr.t = LVar (Names.make_svar_name x) in let asrts_x = asrts_js_val x_val in - Pure (Eq (PVar x, x_val)) :: asrts_x + Pure (BinOp (PVar x, Equal, x_val)) :: asrts_x else [] in asrts @ new_asrts) @@ -199,8 +204,8 @@ let scope_info_to_assertion let this_asrt = make_this_assertion () in - let init_heap_asrt : Asrt.t = Pred (heap_asrt_name, []) in if fid <> JS2JSIL_Helpers.main_fid then + let init_heap_asrt : Asrt.t = Pred (heap_asrt_name, []) in Asrt.star (glob_constraints @ (this_asrt :: init_heap_asrt :: a_schain :: a_vars)) else Asrt.star (glob_constraints @ (this_asrt :: a_schain :: a_vars)) @@ -219,7 +224,7 @@ let create_pre_scope_pred in let a_schain = - Asrt.Pure (Eq (PVar JS2JSIL_Helpers.var_scope, EList sc_bindings)) + Asrt.Pure (BinOp (PVar JS2JSIL_Helpers.var_scope, Equal, EList sc_bindings)) in let fid_vis_tbl = Jslogic.JSLogicCommon.get_scope_table cc_tbl fid in @@ -425,7 +430,7 @@ let bi_post_parse_cmd (cmd : Annot.Basic.t * string option * LabCmd.t) : None ) in let test = LabCmd.LGuardedGoto (PVar x_r, lab_t, lab_f) in - let t_cmd = LabCmd.LLogic (Assert False) in + let t_cmd = LabCmd.LLogic (Assert Expr.false_) in let f_cmd = LabCmd.LReturnError in [ diff --git a/Gillian-JS/lib/JSIL/Asrt.ml b/Gillian-JS/lib/JSIL/Asrt.ml index aacd543a..9957c82b 100644 --- a/Gillian-JS/lib/JSIL/Asrt.ml +++ b/Gillian-JS/lib/JSIL/Asrt.ml @@ -9,15 +9,15 @@ type t = | MetaData of Expr.t * Expr.t (** MetaData *) | Pred of string * Expr.t list (** Predicates *) | EmptyFields of Expr.t * Expr.t (** emptyFields assertion *) - | Pure of Formula.t (** Pure formula *) + | Pure of Expr.t (** Pure formula *) | Types of (Expr.t * Type.t) list (** Typing assertion *) let compare x y = let cmp = Stdlib.compare in match (x, y) with - | Pure (Eq (PVar x, _)), Pure (Eq (PVar y, _)) -> cmp x y - | Pure (Eq (PVar _, _)), _ -> -1 - | _, Pure (Eq (PVar _, _)) -> 1 + | Pure (BinOp (PVar x, Equal, _)), Pure (BinOp (PVar y, Equal, _)) -> cmp x y + | Pure (BinOp (PVar _, Equal, _)), _ -> -1 + | _, Pure (BinOp (PVar _, Equal, _)) -> 1 | PointsTo _, PointsTo _ -> cmp x y | PointsTo _, _ -> -1 | _, PointsTo _ -> 1 @@ -66,7 +66,7 @@ let rec pp fmt (a : t) : unit = (* MetaData (e1, e2) *) | MetaData (e1, e2) -> Fmt.pf fmt "MetaData (%a, %a)" Expr.pp e1 Expr.pp e2 (* Pure *) - | Pure f -> Formula.pp fmt f + | Pure f -> Expr.pp fmt f let full_pp = pp let pp_list = Fmt.list ~sep:(Fmt.any " ") pp diff --git a/Gillian-JS/lib/JSIL/LCmd.ml b/Gillian-JS/lib/JSIL/LCmd.ml index 71b65d28..041842b9 100644 --- a/Gillian-JS/lib/JSIL/LCmd.ml +++ b/Gillian-JS/lib/JSIL/LCmd.ml @@ -1,6 +1,5 @@ module SSubst = Gillian.Symbolic.Subst module Expr = Gillian.Gil_syntax.Expr -module Formula = Gillian.Gil_syntax.Formula module Type = Gillian.Gil_syntax.Type (***************************************************************) @@ -11,10 +10,10 @@ module Type = Gillian.Gil_syntax.Type (** {b JSIL logic commands}. *) type t = | If of Expr.t * t list * t list (** If-then-else *) - | Branch of Formula.t (** branching on a FO formual *) + | Branch of Expr.t (** branching on a FO formual *) | Macro of string * Expr.t list (** Macro *) - | Assert of Formula.t (** Assert *) - | Assume of Formula.t (** Assume *) + | Assert of Expr.t (** Assert *) + | Assume of Expr.t (** Assume *) | AssumeType of Expr.t * Type.t (** Assume Type *) | FreshSVar of string | SL of SLCmd.t @@ -31,10 +30,10 @@ let rec pp fmt lcmd = else Fmt.pf fmt "if (%a) @[then {@\n%a@]@\n}" Expr.pp le pp_list then_lcmds - | Branch fo -> Fmt.pf fmt "branch (%a)" Formula.pp fo + | Branch fo -> Fmt.pf fmt "branch (%a)" Expr.pp fo | Macro (name, lparams) -> Fmt.pf fmt "%s(%a)" name pp_params lparams - | Assert a -> Fmt.pf fmt "assert (%a)" Formula.pp a - | Assume a -> Fmt.pf fmt "assume (%a)" Formula.pp a + | Assert a -> Fmt.pf fmt "assert (%a)" Expr.pp a + | Assume a -> Fmt.pf fmt "assume (%a)" Expr.pp a | FreshSVar x -> Fmt.pf fmt "%s := fresh_svar()" x | SL sl_cmd -> SLCmd.pp fmt sl_cmd | AssumeType (e, t) -> diff --git a/Gillian-JS/lib/JSIL/Pred.ml b/Gillian-JS/lib/JSIL/Pred.ml index f4cfce34..148d08d9 100644 --- a/Gillian-JS/lib/JSIL/Pred.ml +++ b/Gillian-JS/lib/JSIL/Pred.ml @@ -2,7 +2,6 @@ module SSubst = Gillian.Symbolic.Subst module L = Logging module Type = Gillian.Gil_syntax.Type module Expr = Gillian.Gil_syntax.Expr -module Formula = Gillian.Gil_syntax.Formula (** {b JSIL logic predicate}. *) type t = { @@ -12,7 +11,7 @@ type t = { ins : int list; (** Ins *) definitions : ((string * string list) option * Asrt.t) list; (** Predicate definitions *) - facts : Formula.t list; (** Facts about the predicate *) + facts : Expr.t list; (** Facts about the predicate *) pure : bool; (** Is the predicate pure *) abstract : bool; (** Is the predicate abstract *) nounfold : bool; (** Should the predicate be unfolded? *) @@ -68,9 +67,7 @@ let pp fmt pred = let pp_facts fmt = function | [] -> () | facts -> - Fmt.pf fmt "@\nfacts: %a;" - Fmt.(list ~sep:(any " and ") Formula.pp) - facts + Fmt.pf fmt "@\nfacts: %a;" Fmt.(list ~sep:(any " and ") Expr.pp) facts in Fmt.pf fmt "@[%a%a%apred %s(%a):@\n%a;%a@]" pp_abstract pred.abstract pp_pure pred.pure pp_nounfold pred.nounfold name diff --git a/Gillian-JS/lib/JSLogic/JSAsrt.ml b/Gillian-JS/lib/JSLogic/JSAsrt.ml index 7b64d420..d9472143 100644 --- a/Gillian-JS/lib/JSLogic/JSAsrt.ml +++ b/Gillian-JS/lib/JSLogic/JSAsrt.ml @@ -38,27 +38,27 @@ let star (asrts : t list) : t = if not (a = Emp) then if ac = Emp then a else Star (a, ac) else ac) Emp asrts -let rec js2jsil_pure (scope_le : Expr.t option) (a : pt) : Formula.t = +let rec js2jsil_pure (scope_le : Expr.t option) (a : pt) : Expr.t = let f = js2jsil_pure scope_le in let fe = JSExpr.js2jsil scope_le in (* What about metadata here? Or extensibility *) match a with - | And (a1, a2) -> Formula.And (f a1, f a2) - | Or (a1, a2) -> Formula.Or (f a1, f a2) - | Not a -> Formula.Not (f a) - | True -> Formula.True - | False -> Formula.False - | Eq (le1, le2) -> Formula.Eq (fe le1, fe le2) - | Less (le1, le2) -> Formula.FLess (fe le1, fe le2) - | LessEq (le1, le2) -> Formula.FLessEq (fe le1, fe le2) - | StrLess (le1, le2) -> Formula.StrLess (fe le1, fe le2) + | And (a1, a2) -> Expr.BinOp (f a1, And, f a2) + | Or (a1, a2) -> BinOp (f a1, Or, f a2) + | Not a -> UnOp (Not, f a) + | True -> Expr.true_ + | False -> Expr.false_ + | Eq (le1, le2) -> BinOp (fe le1, Equal, fe le2) + | Less (le1, le2) -> BinOp (fe le1, FLessThan, fe le2) + | LessEq (le1, le2) -> BinOp (fe le1, FLessThanEqual, fe le2) + | StrLess (le1, le2) -> BinOp (fe le1, StrLess, fe le2) | ForAll (s, a) -> let new_binders = List.map (fun (x, t) -> (x, Some t)) s in - Formula.ForAll (new_binders, f a) - | SetMem (le1, le2) -> Formula.SetMem (fe le1, fe le2) - | SetSub (le1, le2) -> Formula.SetSub (fe le1, fe le2) - | IsInt e -> Formula.IsInt (fe e) + ForAll (new_binders, f a) + | SetMem (le1, le2) -> BinOp (fe le1, SetMem, fe le2) + | SetSub (le1, le2) -> BinOp (fe le1, SetSub, fe le2) + | IsInt e -> UnOp (IsInt, fe e) let rec js2jsil (cur_fid : string option) @@ -96,12 +96,14 @@ let rec js2jsil let len = List.length (get_vis_list vis_tbl fid) in let a_len = Asrt.Pure - (Eq (Lit (Num (float_of_int (len - 1))), UnOp (LstLen, fe sch))) + (BinOp + (Lit (Num (float_of_int (len - 1))), Equal, UnOp (LstLen, fe sch))) in let a_lg = Asrt.Pure - (Eq + (BinOp ( Lit (Loc locGlobName), + Equal, Expr.BinOp (fe sch, LstNth, Expr.Lit (Num (float_of_int 0))) )) in let a_pred = @@ -135,21 +137,17 @@ let rec js2jsil | Some i -> let le_x = fe le_x in let le_er = - Expr.BinOp (fe le_sc, LstNth, Expr.Lit (Num (float_of_int i))) + Expr.BinOp (fe le_sc, LstNth, Lit (Num (float_of_int i))) in let not_lg = Asrt.Pure - (Formula.Not (Formula.Eq (le_er, Expr.Lit (Loc locGlobName)))) + (UnOp (Not, BinOp (le_er, Equal, Lit (Loc locGlobName)))) in let not_none = - Asrt.Pure (Formula.Not (Formula.Eq (le_x, Expr.Lit Nono))) + Asrt.Pure (UnOp (Not, BinOp (le_x, Equal, Lit Nono))) in Asrt.star - [ - not_lg; - not_none; - Asrt.PointsTo (le_er, Expr.Lit (String x), le_x); - ] + [ not_lg; not_none; Asrt.PointsTo (le_er, Lit (String x), le_x) ] in (* add_extra_scope_chain_info fid le_sc a'*) a' @@ -165,9 +163,10 @@ let rec js2jsil let le_sc2' = fe le_sc2 in let f j = Asrt.Pure - (Formula.Eq - ( Expr.BinOp (le_sc1', LstNth, Expr.Lit (Num (float_of_int j))), - Expr.BinOp (le_sc2', LstNth, Lit (Num (float_of_int j))) )) + (BinOp + ( BinOp (le_sc1', LstNth, Lit (Num (float_of_int j))), + Equal, + BinOp (le_sc2', LstNth, Lit (Num (float_of_int j))) )) in Asrt.star (List.map f is) (* Tr(scope(x: le_x)) ::= Tr(scope(x: le_x, sc, fid)) *) @@ -256,7 +255,7 @@ let rec js2jsil let scope_chain_list = vislist_2_les vis_list (List.length vis_list - 1) in - Asrt.Pure (Formula.Eq (fe le, EList scope_chain_list)) + Asrt.Pure (BinOp (fe le, Equal, EList scope_chain_list)) let errors_assertion () = Asrt.Star @@ -277,11 +276,13 @@ let js2jsil_tactic in (* x__scope == {{ #x1, ..., #xn }} *) - let a'' = Asrt.Pure (Eq (Expr.PVar scope_var, Expr.EList scope_chain_list)) in + let a'' = + Asrt.Pure (BinOp (Expr.PVar scope_var, Equal, Expr.EList scope_chain_list)) + in (* x__this == #this *) let a_this = - Asrt.Pure (Eq (Expr.PVar var_this, Expr.LVar this_logic_var_name)) + Asrt.Pure (BinOp (Expr.PVar var_this, Equal, Expr.LVar this_logic_var_name)) in Asrt.star [ a'; a''; a_this ] diff --git a/Gillian-JS/lib/JSLogic/JSLCmd.ml b/Gillian-JS/lib/JSLogic/JSLCmd.ml index 3b8fb31f..4ec5aa59 100644 --- a/Gillian-JS/lib/JSLogic/JSLCmd.ml +++ b/Gillian-JS/lib/JSLogic/JSLCmd.ml @@ -1,6 +1,5 @@ open JSLogicCommon open Jsil_syntax -module Formula = Gillian.Gil_syntax.Formula type t = | Fold of JSAsrt.t * (string * (string * JSExpr.t) list) option diff --git a/Gillian-JS/lib/JSLogic/JSPred.ml b/Gillian-JS/lib/JSLogic/JSPred.ml index 056c8dc5..29777907 100644 --- a/Gillian-JS/lib/JSLogic/JSPred.ml +++ b/Gillian-JS/lib/JSLogic/JSPred.ml @@ -1,6 +1,6 @@ open JSLogicCommon module Type = Gillian.Gil_syntax.Type -module Formula = Gillian.Gil_syntax.Formula +module Expr = Gillian.Gil_syntax.Expr module Pred = Jsil_syntax.Pred type t = { @@ -9,7 +9,7 @@ type t = { params : (string * Type.t option) list; ins : int list; definitions : ((string * string list) option * JSAsrt.t) list; - facts : Formula.t list; + facts : Expr.t list; abstract : bool; pure : bool; nounfold : bool; diff --git a/Gillian-JS/lib/JSLogic/JSSpec.ml b/Gillian-JS/lib/JSLogic/JSSpec.ml index 0b096485..e7ecfa47 100644 --- a/Gillian-JS/lib/JSLogic/JSSpec.ml +++ b/Gillian-JS/lib/JSLogic/JSSpec.ml @@ -42,31 +42,33 @@ let js2jsil_st (* x \in params -> (! (x == empty)) *) let params_not_empty : Asrt.t list = List.map - (fun x -> Asrt.Pure (Not (Eq (Expr.PVar x, Expr.Lit Empty)))) + (fun x -> Asrt.Pure (UnOp (Not, BinOp (PVar x, Equal, Lit Empty)))) params in let params_not_none : Asrt.t list = - List.map (fun x -> Asrt.Pure (Not (Eq (Expr.PVar x, Expr.Lit Nono)))) params + List.map + (fun x -> Asrt.Pure (UnOp (Not, BinOp (PVar x, Equal, Lit Nono)))) + params in let params_and_lists : Asrt.t list = List.map (fun x -> - let fml : Formula.t = - Eq (Expr.UnOp (TypeOf, Expr.PVar x), Expr.Lit (Type ListType)) + let fml : Expr.t = + BinOp (UnOp (TypeOf, PVar x), Equal, Lit (Type ListType)) in - let fml : Formula.t = if x = var_scope then fml else Not fml in + let fml = if x = var_scope then fml else UnOp (Not, fml) in Asrt.Pure fml) params in (* x__this == #this *) let a_this = - Asrt.Pure (Eq (Expr.PVar var_this, Expr.LVar this_logic_var_name)) + Asrt.Pure (BinOp (Expr.PVar var_this, Equal, Expr.LVar this_logic_var_name)) in (* x__scope == {{ #x1, ..., #xn }} *) let a_scope = - Asrt.Pure (Eq (Expr.PVar var_scope, Expr.EList scope_chain_list)) + Asrt.Pure (BinOp (Expr.PVar var_scope, Equal, Expr.EList scope_chain_list)) in (* let er_sc_list = (match scope_chain_list with | [] -> [] | _ -> List.tl scope_chain_list) in diff --git a/Gillian-JS/lib/Parsing/Javert_Parser.mly b/Gillian-JS/lib/Parsing/Javert_Parser.mly index 85156e5a..72fa5282 100644 --- a/Gillian-JS/lib/Parsing/Javert_Parser.mly +++ b/Gillian-JS/lib/Parsing/Javert_Parser.mly @@ -269,7 +269,7 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %type binop_target %type nop_target %type expr_target -%type pure_assertion_target +%type pure_assertion_target %type jsil_main_target %start jsil_main_target @@ -338,7 +338,7 @@ lit_target: unop_target: - | NOT { UnOp.UNot } + | NOT { UnOp.Not } | BITWISENOT { UnOp.BitwiseNot } | M_ISNAN { UnOp.M_isNaN } | M_ABS { UnOp.M_abs } @@ -375,14 +375,14 @@ binop_target: | EQUAL { BinOp.Equal } | LESSTHAN { BinOp.FLessThan } | LESSTHANEQUAL { BinOp.FLessThanEqual } - | LESSTHANSTRING { BinOp.SLessThan } + | LESSTHANSTRING { BinOp.StrLess } | PLUS { BinOp.FPlus } | MINUS { BinOp.FMinus } | TIMES { BinOp.FTimes } | DIV { BinOp.FDiv } | MOD { BinOp.FMod } - | AND { BinOp.BAnd } - | OR { BinOp.BOr } + | AND { BinOp.And } + | OR { BinOp.Or } | BITWISEAND { BinOp.BitwiseAndF } | BITWISEOR { BinOp.BitwiseOrF } | BITWISEXOR { BinOp.BitwiseXorF } @@ -393,8 +393,8 @@ binop_target: | M_POW { BinOp.M_pow } | STRCAT { BinOp.StrCat } | SETDIFF { BinOp.SetDiff } - | SETMEM { BinOp.BSetMem } - | SETSUB { BinOp.BSetSub } + | SETMEM { BinOp.SetMem } + | SETSUB { BinOp.SetSub } nop_target: | SETUNION { NOp.SetUnion } @@ -448,27 +448,27 @@ lvar_type_target: pure_assertion_target: | left_ass=pure_assertion_target; LAND; right_ass=pure_assertion_target - { Formula.And (left_ass, right_ass) } + { Expr.BinOp (left_ass, And, right_ass) } | left_ass=pure_assertion_target; LOR; right_ass=pure_assertion_target - { Formula.Or (left_ass, right_ass) } - | LNOT; ass=pure_assertion_target { Formula.Not (ass) } - | ISINT; expr=expr_target { Formula.IsInt (expr) } - | LTRUE { Formula.True } - | LFALSE { Formula.False } + { Expr.BinOp (left_ass, Or, right_ass) } + | LNOT; ass=pure_assertion_target { Expr.UnOp (Not, ass) } + | ISINT; expr=expr_target { Expr.UnOp (IsInt, expr) } + | LTRUE { Expr.Lit (Bool true) } + | LFALSE { Expr.Lit (Bool false) } | left_expr=expr_target; LEQUAL; right_expr=expr_target - { Formula.Eq (left_expr, right_expr) } + { Expr.BinOp (left_expr, Equal, right_expr) } | left_expr=expr_target; LLESSTHAN; right_expr=expr_target - { Formula.FLess (left_expr, right_expr) } + { Expr.BinOp (left_expr, FLessThan, right_expr) } | left_expr=expr_target; LLESSTHANEQUAL; right_expr=expr_target - { Formula.FLessEq (left_expr, right_expr) } + { Expr.BinOp (left_expr, FLessThanEqual, right_expr) } | left_expr=expr_target; LLESSTHANSTRING; right_expr=expr_target - { Formula.StrLess (left_expr, right_expr) } + { Expr.BinOp (left_expr, StrLess, right_expr) } | left_expr=expr_target; LSETMEM; right_expr=expr_target - { Formula.SetMem (left_expr, right_expr) } + { Expr.BinOp (left_expr, SetMem, right_expr) } | left_expr=expr_target; LSETSUB; right_expr=expr_target - { Formula.SetSub (left_expr, right_expr) } + { Expr.BinOp (left_expr, SetSub, right_expr) } | LFORALL; vars = separated_nonempty_list(COMMA, lvar_type_target); DOT; ass = pure_assertion_target - { Formula.ForAll (vars, ass) } + { Expr.ForAll (vars, ass) } | delimited(LBRACE, pure_assertion_target, RBRACE) { $1 } @@ -1274,4 +1274,4 @@ top_level_js_pre_target: lab = option(js_sspec_lab_target); a=js_assertion_target; EOF { (lab, a) } top_level_expr_target: - e = expr_target; EOF { e } \ No newline at end of file + e = expr_target; EOF { e } diff --git a/Gillian-JS/lib/Semantics/JSILSMemory.ml b/Gillian-JS/lib/Semantics/JSILSMemory.ml index 9cf0a69e..746b33cf 100644 --- a/Gillian-JS/lib/Semantics/JSILSMemory.ml +++ b/Gillian-JS/lib/Semantics/JSILSMemory.ml @@ -28,13 +28,13 @@ module M = struct | FLoc of vt | FCell of vt * vt | FMetadata of vt - | FPure of Formula.t + | FPure of Expr.t [@@deriving yojson, show] - type err_t = vt list * i_fix_t list list * Formula.t [@@deriving yojson, show] + type err_t = vt list * i_fix_t list list * Expr.t [@@deriving yojson, show] type action_ret = - ( (t * vt list * Formula.t list * (string * Type.t) list) list, + ( (t * vt list * Expr.t list * (string * Type.t) list) list, err_t list ) result @@ -45,9 +45,9 @@ module M = struct | FCell (loc, prop) -> pf ft "@[MIFCell(%a, %a)@]" SVal.pp loc SVal.pp prop | FMetadata loc -> pf ft "@[MIFMetadata(%a)@]" SVal.pp loc - | FPure f -> pf ft "@[MIFPure(%a)@]" Formula.pp f + | FPure f -> pf ft "@[MIFPure(%a)@]" Expr.pp f - let get_failing_constraint (err : err_t) : Formula.t = + let get_failing_constraint (err : err_t) : Expr.t = let _, _, f = err in f @@ -55,7 +55,7 @@ module M = struct let open Fmt in let vs, fixes, f = err in let pp_fixes ft fix = pf ft "[%a]" (list ~sep:comma pp_i_fix) fix in - pf ft "@[<[%a], %a, %a>@]" (list ~sep:comma SVal.pp) vs Formula.pp f + pf ft "@[<[%a], %a, %a>@]" (list ~sep:comma SVal.pp) vs Expr.pp f (list ~sep:semi pp_fixes) fixes let get_recovery_tactic (heap : t) (err : err_t) = @@ -90,7 +90,7 @@ module M = struct in Recovery_tactic.try_unfold values - let assertions ?to_keep:_ (heap : t) : GAsrt.t list = SHeap.assertions heap + let assertions ?to_keep:_ (heap : t) : GAsrt.t = SHeap.assertions heap let lvars (heap : t) : Containers.SS.t = SHeap.lvars heap let alocs (heap : t) : Containers.SS.t = SHeap.alocs heap @@ -100,7 +100,7 @@ module M = struct let substitution_in_place ~pfs:_ ~gamma:_ (subst : st) (heap : t) = SHeap.substitution_in_place subst heap; - [ (heap, Formula.Set.empty, []) ] + [ (heap, Expr.Set.empty, []) ] let pp fmt (heap : t) : unit = SHeap.pp fmt heap let pp_by_need locs fmt heap = SHeap.pp_by_need locs fmt heap @@ -114,7 +114,7 @@ module M = struct Gillian.Logic.FOSolver.resolve_loc_name ~pfs ~gamma let fresh_loc ?(loc : vt option) (pfs : PFS.t) (gamma : Type_env.t) : - string * vt * Formula.t list = + string * vt * Expr.t list = match loc with | Some loc -> ( let loc_name = get_loc_name pfs gamma loc in @@ -125,7 +125,7 @@ module M = struct else (loc_name, Expr.Lit (Loc loc_name), []) | None -> let al = ALoc.alloc () in - (al, ALoc al, [ Formula.Eq (ALoc al, loc) ])) + (al, ALoc al, [ Expr.BinOp (ALoc al, Equal, loc) ])) | None -> let al = ALoc.alloc () in (al, ALoc al, []) @@ -145,7 +145,7 @@ module M = struct | Some (ALoc loc) -> (loc, ALoc loc) | Some (LVar v) -> let loc_name = ALoc.alloc () in - PFS.extend pfs (Eq (LVar v, ALoc loc_name)); + PFS.extend pfs (BinOp (LVar v, Equal, ALoc loc_name)); (loc_name, ALoc loc_name) | Some le -> raise @@ -188,19 +188,23 @@ module M = struct let loc = Expr.loc_from_loc_name loc_name in (* failing_constraint *) let ff = - Formula.conjunct - (List.map (fun prop' -> Formula.Not (Eq (prop, prop'))) props) + Expr.conjunct + (List.map + (fun prop' -> Expr.UnOp (Not, BinOp (prop, Equal, prop'))) + props) in let fixes_exist_props : i_fix_t list list = - List.map (fun prop' -> [ FPure (Formula.Eq (prop, prop')) ]) props + List.map + (fun prop' -> [ FPure (Expr.BinOp (prop, Equal, prop')) ]) + props in let fix_new_property : i_fix_t list = [ FCell (loc, prop); FPure ff ] in match dom with | Some dom -> - let ff' : Formula.t = SetMem (prop, dom) in - let ff'' : Formula.t = And (ff, ff') in + let ff' : Expr.t = BinOp (prop, SetMem, dom) in + let ff'' : Expr.t = BinOp (ff, And, ff') in let fix_new_property' : i_fix_t list = FPure ff' :: fix_new_property in @@ -233,7 +237,9 @@ module M = struct ] | _, Some (ffn, ffv) -> Ok [ (heap, [ loc; ffn; ffv ], [], []) ] | Some dom, None -> - let a_set_inclusion : Formula.t = Not (SetMem (prop, dom)) in + let a_set_inclusion : Expr.t = + UnOp (Not, BinOp (prop, SetMem, dom)) + in if FOSolver.check_entailment Containers.SS.empty pfs [ a_set_inclusion ] gamma @@ -250,17 +256,18 @@ module M = struct Ok [ (heap, [ loc; prop; Lit Nono ], [], []) ]) else let f_names : Expr.t list = SFVL.field_names fv_list in - let full_knowledge : Formula.t = Eq (dom, ESet f_names) in + let full_knowledge : Expr.t = + BinOp (dom, Equal, ESet f_names) + in if FOSolver.check_entailment Containers.SS.empty pfs [ full_knowledge ] gamma then ( L.verbose (fun m -> m "GET CELL will branch\n"); - let rets : (t * vt list * Formula.t list * 'a) option list - = + let rets : (t * vt list * Expr.t list * 'a) option list = List.map (fun (f_name, f_value) -> - let new_f : Formula.t = Eq (f_name, prop) in + let new_f : Expr.t = BinOp (f_name, Equal, prop) in let sat = FOSolver.check_satisfiability ~time:"JS getCell branch: heap" @@ -284,7 +291,9 @@ module M = struct in (* I need the case in which the prop does not exist *) - let new_f : Formula.t = Not (SetMem (prop, dom)) in + let new_f : Expr.t = + UnOp (Not, BinOp (prop, SetMem, dom)) + in let sat = FOSolver.check_satisfiability ~time:"JS getCell branch: domain" @@ -303,15 +312,13 @@ module M = struct make_gc_error loc_name prop (SFVL.field_names fv_list) (Some dom); ])) - ~none: - (Error [ ([], [ [ FLoc loc; FCell (loc, prop) ] ], Formula.False) ]) + ~none:(Error [ ([], [ [ FLoc loc; FCell (loc, prop) ] ], Expr.false_) ]) (SHeap.get heap loc_name) in let result = Option.fold ~some:get_cell_from_loc - ~none: - (Error [ ([], [ [ FLoc loc; FCell (loc, prop) ] ], Formula.False) ]) + ~none:(Error [ ([], [ [ FLoc loc; FCell (loc, prop) ] ], Expr.false_) ]) loc_name in result @@ -354,7 +361,7 @@ module M = struct let make_gm_error (loc_name : string) : err_t = let loc = Expr.loc_from_loc_name loc_name in - ([ loc ], [ [ FMetadata loc ] ], False) + ([ loc ], [ [ FMetadata loc ] ], Expr.false_) in let f loc_name = @@ -372,8 +379,7 @@ module M = struct in Option.fold ~some:f - ~none: - (Error [ ([ loc ], [ [ FLoc loc; FMetadata loc ] ], Formula.False) ]) + ~none:(Error [ ([ loc ], [ [ FLoc loc; FMetadata loc ] ], Expr.false_) ]) loc_name let set_metadata @@ -391,7 +397,7 @@ module M = struct SHeap.set heap loc_name fv_list dom (Some mtdt) | Some ((fv_list, dom), Some omet) -> if omet <> Option.get (SVal.from_expr (Lit Null)) then - PFS.extend pfs (Eq (mtdt, omet)) + PFS.extend pfs (BinOp (mtdt, Equal, omet)) else SHeap.set heap loc_name fv_list dom (Some mtdt)); L.tmi (fun m -> m "Done setting metadata."); Ok [ (heap, [], new_pfs, []) ] @@ -461,9 +467,7 @@ module M = struct | _ -> raise (Failure "DEATH. get_partial_domain. dom_diff")) in let result = - Option.fold ~some:f - ~none:(Error [ ([ loc ], [], Formula.False) ]) - loc_name + Option.fold ~some:f ~none:(Error [ ([ loc ], [], Expr.false_) ]) loc_name in result @@ -481,7 +485,7 @@ module M = struct raise (Failure "DEATH. TODO. get_full_domain. missing domain") | Some ((fv_list, Some dom), _) -> let props = SFVL.field_names fv_list in - let a_set_equality : Formula.t = Eq (dom, ESet props) in + let a_set_equality : Expr.t = BinOp (dom, Equal, ESet props) in let solver_ret = FOSolver.check_entailment Containers.SS.empty pfs [ a_set_equality ] gamma @@ -495,9 +499,7 @@ module M = struct in let result = - Option.fold ~some:f - ~none:(Error [ ([ loc ], [], Formula.False) ]) - loc_name + Option.fold ~some:f ~none:(Error [ ([ loc ], [], Expr.false_) ]) loc_name in result @@ -589,7 +591,7 @@ module M = struct else if a_id = JSILNames.aProps then JSILNames.delProps else raise (Failure "DEATH. ga_to_setter") - let mem_constraints (state : t) : Formula.t list = SHeap.wf_assertions state + let mem_constraints (state : t) : Expr.t list = SHeap.wf_assertions state let is_overlapping_asrt (a : string) : bool = if a = JSILNames.aMetadata then true else false @@ -597,9 +599,7 @@ module M = struct let prop_abduce_none_in_js = [ "@call" ] let prop_abduce_both_in_js = [ "hasOwnProperty" ] - type fix_result = Asrt.t list - - let complete_fix_js (i_fix : i_fix_t) : fix_result list = + let complete_fix_js (i_fix : i_fix_t) : Asrt.t list = match i_fix with | FLoc v -> (* Get a fresh location *) @@ -607,19 +607,19 @@ module M = struct however it only seemed to add the binding without creating any state, so did it really "do" anything? Bi-abduction is broken for Gillian-JS anyways. *) let al = ALoc.alloc () in - [ [ Asrt.Pure (Eq (ALoc al, v)) ] ] + [ [ Asrt.Pure (BinOp (ALoc al, Equal, v)) ] ] | FCell (l, p) -> ( let none_fix () = - [ Asrt.GA (JSILNames.aCell, [ l; p ], [ Lit Nono ]) ] + [ Asrt.CorePred (JSILNames.aCell, [ l; p ], [ Lit Nono ]) ] in let some_fix () = let vvar = LVar.alloc () in let v : vt = LVar vvar in - let asrt_empty : Formula.t = Not (Eq (v, Lit Empty)) in - let asrt_none : Formula.t = Not (Eq (v, Lit Nono)) in - let asrt_list : Formula.t = - Not (Eq (UnOp (TypeOf, v), Lit (Type ListType))) + let asrt_empty : Expr.t = UnOp (Not, BinOp (v, Equal, Lit Empty)) in + let asrt_none : Expr.t = UnOp (Not, BinOp (v, Equal, Lit Nono)) in + let asrt_list : Expr.t = + UnOp (Not, BinOp (UnOp (TypeOf, v), Equal, Lit (Type ListType))) in let descriptor : Expr.t = EList @@ -632,7 +632,7 @@ module M = struct ] in [ - Asrt.GA (JSILNames.aCell, [ l; p ], [ descriptor ]); + Asrt.CorePred (JSILNames.aCell, [ l; p ], [ descriptor ]); Asrt.Pure asrt_empty; Asrt.Pure asrt_none; Asrt.Pure asrt_list; @@ -650,18 +650,18 @@ module M = struct let mloc = Expr.ALoc al in [ [ - Asrt.Pure (Eq (ALoc al, l)); - Asrt.GA (JSILNames.aMetadata, [ l ], [ mloc ]); - Asrt.GA (JSILNames.aMetadata, [ mloc ], [ Lit Null ]); - Asrt.GA + Asrt.Pure (BinOp (ALoc al, Equal, l)); + Asrt.CorePred (JSILNames.aMetadata, [ l ], [ mloc ]); + Asrt.CorePred (JSILNames.aMetadata, [ mloc ], [ Lit Null ]); + Asrt.CorePred ( JSILNames.aCell, [ mloc; Lit (String "@class") ], [ Lit (String "Object") ] ); - Asrt.GA + Asrt.CorePred ( JSILNames.aCell, [ mloc; Lit (String "@extensible") ], [ Lit (Bool true) ] ); - Asrt.GA + Asrt.CorePred ( JSILNames.aCell, [ mloc; Lit (String "@proto") ], [ Lit (Loc JS2JSIL_Helpers.locObjPrototype) ] ); @@ -670,32 +670,41 @@ module M = struct | FPure f -> [ [ Asrt.Pure f ] ] (* Fix completion: simple *) - let complete_fix_jsil (i_fix : i_fix_t) : fix_result list = + let complete_fix_jsil (i_fix : i_fix_t) : Asrt.t list = match i_fix with | FLoc v -> (* Get a fresh location *) let al = ALoc.alloc () in - [ [ Asrt.Pure (Eq (ALoc al, v)) ] ] + [ [ Asrt.Pure (BinOp (ALoc al, Equal, v)) ] ] | FCell (l, p) -> (* Fresh variable to denote the property value *) let vvar = LVar.alloc () in let v : vt = LVar vvar in (* Value is not none - we always bi-abduce presence *) - let not_none : Formula.t = Not (Eq (v, Lit Nono)) in - [ [ Asrt.GA (JSILNames.aCell, [ l; p ], [ v ]); Asrt.Pure not_none ] ] + let not_none : Expr.t = UnOp (Not, BinOp (v, Equal, Lit Nono)) in + [ + [ + Asrt.CorePred (JSILNames.aCell, [ l; p ], [ v ]); Asrt.Pure not_none; + ]; + ] | FMetadata l -> (* Fresh variable to denote the property value *) let vvar = LVar.alloc () in let v : vt = LVar vvar in - let not_none : Formula.t = Not (Eq (v, Lit Nono)) in - [ [ Asrt.GA (JSILNames.aMetadata, [ l ], [ v ]); Asrt.Pure not_none ] ] + let not_none : Expr.t = UnOp (Not, BinOp (v, Equal, Lit Nono)) in + [ + [ + Asrt.CorePred (JSILNames.aMetadata, [ l ], [ v ]); + Asrt.Pure not_none; + ]; + ] | FPure f -> [ [ Asrt.Pure f ] ] (* An error can have multiple fixes *) - let get_fixes (err : err_t) : fix_result list = - let pp_fix_result ft res = + let get_fixes (err : err_t) : Asrt.t list = + let pp_fix ft res = let open Fmt in - pf ft "@[@[[[ %a ]]@]@\n@]" (list ~sep:comma Asrt.pp) res + pf ft "@[@[[[ %a ]]@]@\n@]" Asrt.pp res in let _, fixes, _ = err in L.verbose (fun m -> @@ -709,10 +718,10 @@ module M = struct if !Js_config.js then complete_fix_js else complete_fix_jsil in - let complete_ifixes (ifixes : i_fix_t list) : fix_result list = + let complete_ifixes (ifixes : i_fix_t list) : Asrt.t list = let completed_ifixes = List.map complete ifixes in let completed_ifixes = List_utils.list_product completed_ifixes in - let completed_ifixes : fix_result list = + let completed_ifixes : Asrt.t list = List.map (fun fixes -> List.fold_right List.append fixes []) completed_ifixes @@ -721,16 +730,14 @@ module M = struct L.verbose (fun m -> m "@[Memory: i-fixes completed: %d@\n%a" (List.length completed_ifixes) - Fmt.(list ~sep:(any "@\n") pp_fix_result) + Fmt.(list ~sep:(any "@\n") pp_fix) completed_ifixes); completed_ifixes in (* Fixes hold lists of lists of i_fixes, *) - let completed_fixes = List.concat (List.map complete_ifixes fixes) in - - completed_fixes + List.concat_map complete_ifixes fixes let can_fix _ = true diff --git a/Gillian-JS/lib/Semantics/SFVL.ml b/Gillian-JS/lib/Semantics/SFVL.ml index 610d9949..ae5aa6ef 100644 --- a/Gillian-JS/lib/Semantics/SFVL.ml +++ b/Gillian-JS/lib/Semantics/SFVL.ml @@ -75,10 +75,10 @@ let alocs (sfvl : t) : SS.t = SS.union ac (SS.union (Expr.alocs e_field) (Expr.alocs e_val))) sfvl SS.empty -let assertions (loc : Expr.t) (sfvl : t) : Asrt.t list = +let assertions (loc : Expr.t) (sfvl : t) : Asrt.t = List.rev (Expr.Map.fold - (fun field value (ac : Asrt.t list) -> + (fun field value (ac : Asrt.t) -> Asrt_utils.points_to ~loc ~field ~value :: ac) sfvl []) @@ -105,8 +105,8 @@ let selective_substitution (subst : SSubst.t) (partial : bool) (fv_list : t) : t (* Correctness of field-value lists *) let is_well_formed (_ : t) : bool = true -let wf_assertions (sfvl : t) : Formula.t list = +let wf_assertions (sfvl : t) : Expr.t list = let props = field_names sfvl in let props' = List_utils.cross_product props props (fun x y -> (x, y)) in let props' = List.filter (fun (x, y) -> x <> y) props' in - List.map (fun (x, y) : Formula.t -> Not (Eq (x, y))) props' + List.map (fun (x, y) : Expr.t -> UnOp (Not, BinOp (x, Equal, y))) props' diff --git a/Gillian-JS/lib/Semantics/SFVL.mli b/Gillian-JS/lib/Semantics/SFVL.mli index 2a4cdee4..02341521 100644 --- a/Gillian-JS/lib/Semantics/SFVL.mli +++ b/Gillian-JS/lib/Semantics/SFVL.mli @@ -23,9 +23,9 @@ val pp : Format.formatter -> t -> unit val union : t -> t -> t val lvars : t -> Containers.SS.t val alocs : t -> Containers.SS.t -val assertions : Expr.t -> t -> Asrt.t list +val assertions : Expr.t -> t -> Asrt.t val substitution : Subst.t -> bool -> t -> t val selective_substitution : Subst.t -> bool -> t -> t val is_well_formed : t -> bool -val wf_assertions : t -> Formula.t list +val wf_assertions : t -> Expr.t list val to_list : t -> (field_name * field_value) list diff --git a/Gillian-JS/lib/Semantics/SHeap.ml b/Gillian-JS/lib/Semantics/SHeap.ml index d0c7e1fc..a160b310 100644 --- a/Gillian-JS/lib/Semantics/SHeap.ml +++ b/Gillian-JS/lib/Semantics/SHeap.ml @@ -338,7 +338,7 @@ let to_list (heap : t) : (string * s_object) list = SS.fold (fun loc ac -> (loc, Option.get (get heap loc)) :: ac) domain [] (** converts a symbolic heap to a list of assertions *) -let assertions (heap : t) : Asrt.t list = +let assertions (heap : t) : Asrt.t = let make_loc_lexpr loc = if Names.is_aloc_name loc then Expr.ALoc loc else Expr.Lit (Loc loc) in @@ -359,10 +359,9 @@ let assertions (heap : t) : Asrt.t list = fv_assertions @ domain @ metadata in - List.sort Asrt.compare - (List.concat (List.map assertions_of_object (to_list heap))) + to_list heap |> List.concat_map assertions_of_object |> List.sort Asrt.compare -let wf_assertions_of_obj (heap : t) (loc : string) : Formula.t list = +let wf_assertions_of_obj (heap : t) (loc : string) : Expr.t list = let cfvl = Option.value ~default:SFVL.empty (Hashtbl.find_opt heap.cfvl loc) in @@ -373,9 +372,9 @@ let wf_assertions_of_obj (heap : t) (loc : string) : Formula.t list = let spps = SFVL.field_names sfvl in let props = List_utils.cross_product spps (cpps @ spps) (fun x y -> (x, y)) in let props = List.filter (fun (x, y) -> x <> y) props in - List.map (fun (x, y) : Formula.t -> Not (Eq (x, y))) props + List.map (fun (x, y) : Expr.t -> UnOp (Not, BinOp (x, Equal, y))) props -let wf_assertions (heap : t) : Formula.t list = +let wf_assertions (heap : t) : Expr.t list = let domain = domain heap in SS.fold (fun loc ac -> wf_assertions_of_obj heap loc @ ac) domain [] diff --git a/Gillian-JS/lib/utils/asrt_utils.ml b/Gillian-JS/lib/utils/asrt_utils.ml index 4513c7f7..a90cf487 100644 --- a/Gillian-JS/lib/utils/asrt_utils.ml +++ b/Gillian-JS/lib/utils/asrt_utils.ml @@ -1,6 +1,6 @@ open JSILNames open Gillian.Gil_syntax.Asrt -let points_to ~loc ~field ~value = GA (aCell, [ loc; field ], [ value ]) -let metadata ~loc ~metadata = GA (aMetadata, [ loc ], [ metadata ]) -let empty_fields ~loc ~domain = GA (aProps, [ loc; domain ], []) +let points_to ~loc ~field ~value = CorePred (aCell, [ loc; field ], [ value ]) +let metadata ~loc ~metadata = CorePred (aMetadata, [ loc ], [ metadata ]) +let empty_fields ~loc ~domain = CorePred (aProps, [ loc; domain ], []) diff --git a/GillianCore/GIL_Syntax/Asrt.ml b/GillianCore/GIL_Syntax/Asrt.ml index e47e70a1..2450fa3d 100644 --- a/GillianCore/GIL_Syntax/Asrt.ml +++ b/GillianCore/GIL_Syntax/Asrt.ml @@ -1,24 +1,28 @@ (** {b GIL logic assertions}. *) -type t = TypeDef__.assertion = +type atom = TypeDef__.assertion_atom = | Emp (** Empty heap *) - | Star of t * t (** Separating conjunction *) | Pred of string * Expr.t list (** Predicates *) - | Pure of Formula.t (** Pure formula *) + | Pure of Expr.t (** Pure formula *) | Types of (Expr.t * Type.t) list (** Typing assertion *) - | GA of string * Expr.t list * Expr.t list (** Core assertion *) + | CorePred of string * Expr.t list * Expr.t list + (** Core assertion *) | Wand of { lhs : string * Expr.t list; rhs : string * Expr.t list } (** Magic wand of the form [P(...) -* Q(...)] *) [@@deriving eq] +type t = TypeDef__.assertion [@@deriving eq] + +let atom_to_yojson = TypeDef__.assertion_atom_to_yojson +let atom_of_yojson = TypeDef__.assertion_atom_of_yojson let to_yojson = TypeDef__.assertion_to_yojson let of_yojson = TypeDef__.assertion_of_yojson let compare x y = let cmp = Stdlib.compare in match (x, y) with - | Pure (Eq (PVar x, _)), Pure (Eq (PVar y, _)) -> cmp x y - | Pure (Eq (PVar _, _)), _ -> -1 - | _, Pure (Eq (PVar _, _)) -> 1 + | Pure (BinOp (PVar x, Equal, _)), Pure (BinOp (PVar y, Equal, _)) -> cmp x y + | Pure (BinOp (PVar _, Equal, _)), _ -> -1 + | _, Pure (BinOp (PVar _, Equal, _)) -> 1 | Pure _, Pure _ -> cmp x y | Pure _, _ -> -1 | _, Pure _ -> 1 @@ -27,7 +31,7 @@ let compare x y = | _, Types _ -> 1 | _, _ -> cmp x y -let prioritise (a1 : t) (a2 : t) = +let prioritise (a1 : atom) (a2 : atom) = let lloc_aloc_pvar_lvar e1 e2 = match ((e1 : Expr.t), (e2 : Expr.t)) with | Lit (Loc _), Lit (Loc _) -> 0 @@ -65,65 +69,38 @@ end module Set = Set.Make (MyAssertion) (** Deprecated, use {!Visitors.endo} instead. *) -let rec map - (f_a_before : (t -> t * bool) option) - (f_a_after : (t -> t) option) - (f_e : (Expr.t -> Expr.t) option) - (f_p : (Formula.t -> Formula.t) option) - (a : t) : t = - (* Map recursively to assertions and expressions *) - let map_a = map f_a_before f_a_after f_e f_p in - let map_e = Option.value ~default:(fun x -> x) f_e in - let map_p = Option.value ~default:(Formula.map None None (Some map_e)) f_p in - let f_a_before = Option.value ~default:(fun x -> (x, true)) f_a_before in - let f_a_after = Option.value ~default:(fun x -> x) f_a_after in - let a', recurse = f_a_before a in - - if not recurse then a' - else - let a'' = - match a' with - | Star (a1, a2) -> Star (map_a a1, map_a a2) - | Emp -> Emp - | Pred (s, le) -> Pred (s, List.map map_e le) - | Pure form -> Pure (map_p form) - | Types lt -> Types (List.map (fun (exp, typ) -> (map_e exp, typ)) lt) - | GA (x, es1, es2) -> GA (x, List.map map_e es1, List.map map_e es2) - | Wand { lhs = lhs_pred, lhs_args; rhs = rhs_pred, rhs_args } -> - Wand - { - lhs = (lhs_pred, List.map map_e lhs_args); - rhs = (rhs_pred, List.map map_e rhs_args); - } - in - f_a_after a'' - -(* Get all the logical expressions of --a-- that denote a list - and are not logical variables *) -let list_lexprs (a : t) : Expr.Set.t = - Formula.list_lexprs_collector#visit_assertion () a +let map (f_e : Expr.t -> Expr.t) : t -> t = + List.map (function + | Emp -> Emp + | Pred (s, le) -> Pred (s, List.map f_e le) + | Pure form -> Pure (f_e form) + | Types lt -> Types (List.map (fun (exp, typ) -> (f_e exp, typ)) lt) + | CorePred (x, es1, es2) -> CorePred (x, List.map f_e es1, List.map f_e es2) + | Wand { lhs = lhs_pred, lhs_args; rhs = rhs_pred, rhs_args } -> + Wand + { + lhs = (lhs_pred, List.map f_e lhs_args); + rhs = (rhs_pred, List.map f_e rhs_args); + }) (* Get all the logical variables in --a-- *) -let lvars (a : t) : SS.t = - Visitors.Collectors.lvar_collector#visit_assertion SS.empty a +let lvars : t -> SS.t = + Visitors.Collectors.lvar_collector#visit_assertion SS.empty (* Get all the program variables in --a-- *) -let pvars (a : t) : SS.t = - Visitors.Collectors.pvar_collector#visit_assertion () a +let pvars : t -> SS.t = Visitors.Collectors.pvar_collector#visit_assertion () (* Get all the abstract locations in --a-- *) -let alocs (a : t) : SS.t = - Visitors.Collectors.aloc_collector#visit_assertion () a +let alocs : t -> SS.t = Visitors.Collectors.aloc_collector#visit_assertion () (* Get all the concrete locations in [a] *) -let clocs (a : t) : SS.t = - Visitors.Collectors.cloc_collector#visit_assertion () a +let clocs : t -> SS.t = Visitors.Collectors.cloc_collector#visit_assertion () (* Get all the concrete locations in [a] *) -let locs (a : t) : SS.t = Visitors.Collectors.loc_collector#visit_assertion () a +let locs : t -> SS.t = Visitors.Collectors.loc_collector#visit_assertion () (* Returns a list with the names of the predicates that occur in --a-- *) -let pred_names (a : t) : string list = +let pred_names : t -> string list = let collector = object inherit [_] Visitors.reduce @@ -131,10 +108,10 @@ let pred_names (a : t) : string list = method! visit_Pred () name _ = [ name ] end in - collector#visit_assertion () a + collector#visit_assertion () (* Returns a list with the pure assertions that occur in --a-- *) -let pure_asrts (a : t) : Formula.t list = +let pure_asrts : t -> Expr.t list = let collector = object inherit [_] Visitors.reduce @@ -142,122 +119,60 @@ let pure_asrts (a : t) : Formula.t list = method! visit_Pure () f = [ f ] end in - collector#visit_assertion () a - -(* Returns a list with the simple assertions that occur in --a-- *) -let rec simple_asrts (a : t) : t list = - match a with - | Emp -> [] - | Star (a1, a2) -> simple_asrts a1 @ simple_asrts a2 - | _ -> [ a ] + collector#visit_assertion () (* Check if --a-- is a pure assertion *) -let rec is_pure_asrt (a : t) : bool = - match a with - | Pred _ | GA _ -> false - | Star (a1, a2) -> is_pure_asrt a1 && is_pure_asrt a2 +let is_pure_asrt : atom -> bool = function + | Pred _ | CorePred _ | Wand _ -> false | _ -> true -(* Check if --a-- is a pure assertion & non-recursive assertion. - It assumes that only pure assertions are universally quantified *) -let is_pure_non_rec_asrt (a : t) : bool = - match a with - | Pure _ | Types _ | Emp -> true - | _ -> false - -(* Eliminate LStar and LTypes assertions. - LTypes disappears. LStar is replaced by LAnd. +(* Eliminate Emp assertions. + Pure assertions are converted to a single formula. This function expects its argument to be a PURE assertion. *) -let make_pure (a : t) : Formula.t = - let s_asrts = simple_asrts a in - let all_pure = List.for_all is_pure_non_rec_asrt s_asrts in - if all_pure then - let fs = - List.map - (fun a -> - match a with - | Pure f -> f - | _ -> raise (Failure "DEATH. make_pure")) - s_asrts - in - Formula.conjunct fs - else raise (Failure "DEATH. make_pure") - -let rec full_pp fmt a = - match a with - | Star (a1, a2) -> Fmt.pf fmt "%a *@ %a" full_pp a1 full_pp a2 - | Emp -> Fmt.string fmt "emp" - | Pred (name, params) -> - let name = Pp_utils.maybe_quote_ident name in - Fmt.pf fmt "@[%s(%a)@]" name - (Fmt.list ~sep:Fmt.comma Expr.full_pp) - params - | Types tls -> - let pp_tl f (e, t) = Fmt.pf f "%a : %s" Expr.full_pp e (Type.str t) in - Fmt.pf fmt "types(@[%a@])" (Fmt.list ~sep:Fmt.comma pp_tl) tls - | Pure f -> Formula.full_pp fmt f - | GA (a, ins, outs) -> - let pp_e_l = Fmt.list ~sep:Fmt.comma Expr.full_pp in - Fmt.pf fmt "@[<%s>(%a; %a)@]" a pp_e_l ins pp_e_l outs - | Wand { lhs = lname, largs; rhs = rname, rargs } -> - let lname = Pp_utils.maybe_quote_ident lname in - let rname = Pp_utils.maybe_quote_ident rname in - Fmt.pf fmt "(%s(%a) -* %s(%a))" lname - (Fmt.list ~sep:Fmt.comma Expr.full_pp) - largs rname - (Fmt.list ~sep:Fmt.comma Expr.full_pp) - rargs +let make_pure (a : t) : Expr.t = + a + |> List.filter_map (function + | Pure f -> Some f + | Emp -> None + | _ -> raise (Failure "DEATH. make_pure received unpure assertion")) + |> Expr.conjunct (** GIL logic assertions *) -let rec pp fmt a = - match a with - | Star (a1, a2) -> Fmt.pf fmt "%a *@ %a" pp a1 pp a2 +let _pp_atom ?(e_pp : Format.formatter -> Expr.t -> unit = Expr.pp) fmt = + function | Emp -> Fmt.string fmt "emp" | Pred (name, params) -> let name = Pp_utils.maybe_quote_ident name in - Fmt.pf fmt "@[%s(%a)@]" name (Fmt.list ~sep:Fmt.comma Expr.pp) params + Fmt.pf fmt "@[%s(%a)@]" name (Fmt.list ~sep:Fmt.comma e_pp) params | Types tls -> - let pp_tl f (e, t) = Fmt.pf f "%a : %s" Expr.pp e (Type.str t) in + let pp_tl f (e, t) = Fmt.pf f "%a : %s" e_pp e (Type.str t) in Fmt.pf fmt "types(@[%a@])" (Fmt.list ~sep:Fmt.comma pp_tl) tls - | Pure f -> Formula.pp fmt f - | GA (a, ins, outs) -> - let pp_e_l = Fmt.list ~sep:Fmt.comma Expr.pp in + | Pure f -> e_pp fmt f + | CorePred (a, ins, outs) -> + let pp_e_l = Fmt.list ~sep:Fmt.comma e_pp in Fmt.pf fmt "@[<%s>(%a; %a)@]" a pp_e_l ins pp_e_l outs | Wand { lhs = lname, largs; rhs = rname, rargs } -> let lname = Pp_utils.maybe_quote_ident lname in let rname = Pp_utils.maybe_quote_ident rname in Fmt.pf fmt "(%s(%a) -* %s(%a))" lname - (Fmt.list ~sep:Fmt.comma Expr.pp) + (Fmt.list ~sep:Fmt.comma e_pp) largs rname - (Fmt.list ~sep:Fmt.comma Expr.pp) + (Fmt.list ~sep:Fmt.comma e_pp) rargs -let subst_clocs (subst : string -> Expr.t) (a : t) : t = - map None None - (Some (Expr.subst_clocs subst)) - (Some (Formula.subst_clocs subst)) - a +let _pp ~(e_pp : Format.formatter -> Expr.t -> unit) (fmt : Format.formatter) : + t -> unit = + Fmt.list ~sep:(Fmt.any " *@ ") (_pp_atom ~e_pp) fmt -let subst_expr_for_expr ~(to_subst : Expr.t) ~(subst_with : Expr.t) (a : t) : t - = - map None None - (Some (Expr.subst_expr_for_expr ~to_subst ~subst_with)) - (Some (Formula.subst_expr_for_expr ~to_subst ~subst_with)) - a +let pp_atom = _pp_atom ~e_pp:Expr.pp +let pp_atom_full = _pp_atom ~e_pp:Expr.full_pp +let pp = _pp ~e_pp:Expr.pp +let full_pp = _pp ~e_pp:Expr.full_pp -module Infix = struct - let ( ** ) a b = - match (a, b) with - | Pure True, x | x, Pure True | Emp, x | x, Emp -> x - | (Pure False as fl), _ | _, (Pure False as fl) -> fl - | _ -> Star (a, b) - - let ( --* ) lhs rhs = Wand { lhs; rhs } -end +let subst_clocs (subst : string -> Expr.t) : t -> t = + map (Expr.subst_clocs subst) -let star (asrts : t list) : t = List.fold_left Infix.( ** ) Emp asrts +let subst_expr_for_expr ~(to_subst : Expr.t) ~(subst_with : Expr.t) : t -> t = + map (Expr.subst_expr_for_expr ~to_subst ~subst_with) -let pvars_to_lvars (a : t) : t = - let ff = Formula.pvars_to_lvars in - let fe = Expr.pvars_to_lvars in - map None None (Some fe) (Some ff) a +let pvars_to_lvars : t -> t = map Expr.pvars_to_lvars diff --git a/GillianCore/GIL_Syntax/BinOp.ml b/GillianCore/GIL_Syntax/BinOp.ml index 9fc089b4..d2a168df 100644 --- a/GillianCore/GIL_Syntax/BinOp.ml +++ b/GillianCore/GIL_Syntax/BinOp.ml @@ -17,11 +17,10 @@ type t = TypeDef__.binop = | FTimes (** Float multiplication *) | FDiv (** Float division *) | FMod (** Float modulus *) - | SLessThan (** Less or equal for strings *) (* Boolean *) - | BAnd (** Boolean conjunction *) - | BOr (** Boolean disjunction *) - | BImpl (** Boolean implication *) + | And (** Boolean conjunction *) + | Or (** Boolean disjunction *) + | Impl (** Boolean implication *) (* Bitwise *) | BitwiseAnd (** Bitwise conjunction *) | BitwiseOr (** Bitwise disjunction *) @@ -51,10 +50,11 @@ type t = TypeDef__.binop = (* Strings *) | StrCat (** String concatenation *) | StrNth (** Nth element of a string *) + | StrLess (** Less or equal for strings *) (* Sets *) | SetDiff (** Set difference *) - | BSetMem (** Set membership *) - | BSetSub (** Subset *) + | SetMem (** Set membership *) + | SetSub (** Subset *) [@@deriving eq, ord] let to_yojson = TypeDef__.binop_to_yojson @@ -62,7 +62,7 @@ let of_yojson = TypeDef__.binop_of_yojson let str (x : t) = match x with - | Equal -> "=" + | Equal -> "==" | ILessThan -> "i<" | ILessThanEqual -> "i<=" | IPlus -> "i+" @@ -77,10 +77,10 @@ let str (x : t) = | FTimes -> "*" | FDiv -> "/" | FMod -> "%" - | SLessThan -> "s<" - | BAnd -> "and" - | BOr -> "or" - | BImpl -> "==>" + | StrLess -> "s<" + | And -> "and" + | Or -> "or" + | Impl -> "==>" | BitwiseAnd -> "&" | BitwiseOr -> "|" | BitwiseXor -> "^" @@ -106,5 +106,5 @@ let str (x : t) = | StrCat -> "++" | StrNth -> "s-nth" | SetDiff -> "-d-" - | BSetMem -> "-e-" - | BSetSub -> "-s-" + | SetMem -> "-e-" + | SetSub -> "-s-" diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index 76bbda5d..063f1422 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -13,8 +13,9 @@ type t = TypeDef__.expr = | EList of t list (** Lists of expressions *) | ESet of t list (** Sets of expressions *) | Exists of (string * Type.t option) list * t - (** Existential quantification. This is now a circus because the separation between Formula and Expr doesn't make sense anymore. *) - | EForall of (string * Type.t option) list * t + (** Existential quantification. *) + | ForAll of (string * Type.t option) list * t + (** Universal quantification. *) [@@deriving eq, ord] let to_yojson = TypeDef__.expr_to_yojson @@ -29,6 +30,8 @@ let int n = lit (Int (Z.of_int n)) let int_z z = lit (Int z) let string s = lit (String s) let bool b = lit (Bool b) +let false_ = Lit (Bool false) +let true_ = Lit (Bool true) let zero_i = int_z Z.zero let one_i = int_z Z.one @@ -112,21 +115,15 @@ let list_cons el r = list_cat sgl r let list el = - if - List.for_all - (function - | Lit _ -> true - | _ -> false) - el - then - Lit - (LList - (List.map - (function - | Lit l -> l - | _ -> assert false) - el)) - else EList el + let rec aux l = + match l with + | [] -> Some [] + | Lit l :: r -> Option.map (fun x -> l :: x) (aux r) + | _ -> None + in + match aux el with + | Some l -> Lit (LList l) + | None -> EList el let fmod a b = match (a, b) with @@ -239,14 +236,96 @@ module Infix = struct | UnOp (IUnaryMinus, z) -> z | z -> UnOp (IUnaryMinus, z) + let forall params f = ForAll (params, f) + let not a = match a with | Lit (Bool a) -> Lit (Bool (not a)) - | x -> UnOp (UNot, x) + | x -> UnOp (Not, x) + + let ( == ) a b = + match (a, b) with + | Lit la, Lit lb -> bool (Literal.equal la lb) + | a, b when equal a b -> Lit (Bool true) + | _ -> BinOp (a, Equal, b) + + let lt = Stdlib.( < ) + let lte = Stdlib.( <= ) + let gt = Stdlib.( > ) + let gte = Stdlib.( >= ) + + let ( < ) a b = + match (a, b) with + | Lit (Int x), Lit (Int y) -> bool (lt x y) + | _ -> BinOp (a, ILessThan, b) + + let ( <= ) a b = + match (a, b) with + | Lit (Int x), Lit (Int y) -> bool (lte x y) + | _ -> BinOp (a, ILessThanEqual, b) + + let ( > ) a b = + match (a, b) with + | Lit (Int x), Lit (Int y) -> bool (gt x y) + | _ -> BinOp (b, ILessThan, a) + + let ( >= ) a b = + match (a, b) with + | Lit (Int x), Lit (Int y) -> bool (gte x y) + | _ -> BinOp (b, ILessThanEqual, a) + + let ( <. ) a b = + match (a, b) with + | Lit (Num x), Lit (Num y) -> bool (lt x y) + | _ -> BinOp (a, FLessThan, b) + + let ( <=. ) a b = + match (a, b) with + | Lit (Num x), Lit (Num y) -> bool (lte x y) + | _ -> BinOp (a, FLessThanEqual, b) + + let ( >. ) a b = + match (a, b) with + | Lit (Num x), Lit (Num y) -> bool (gt x y) + | _ -> BinOp (b, FLessThan, a) + + let ( >=. ) a b = + match (a, b) with + | Lit (Num x), Lit (Num y) -> bool (gte x y) + | _ -> BinOp (b, FLessThanEqual, a) + + let ( && ) a b = + match (a, b) with + | Lit (Bool true), x | x, Lit (Bool true) -> x + | Lit (Bool false), _ | _, Lit (Bool false) -> Lit (Bool false) + | _ -> BinOp (a, And, b) + + let ( || ) a b = + match (a, b) with + | Lit (Bool false), x | x, Lit (Bool false) -> x + | Lit (Bool true), _ | _, Lit (Bool true) -> Lit (Bool true) + | _ -> BinOp (a, Or, b) + + let ( ==> ) a b = + match (a, b) with + | Lit (Bool true), x -> x + | Lit (Bool false), _ | _, Lit (Bool true) -> Lit (Bool true) + | x, Lit (Bool false) -> not x + | _ -> BinOp (a, Impl, b) let ( @+ ) = list_cat end +let conjunct = function + | [] -> Lit (Bool true) + | [ x ] -> x + | hd :: tl -> List.fold_left (fun acc x -> Infix.( && ) acc x) hd tl + +let disjunct = function + | [] -> Lit (Bool false) + | [ x ] -> x + | hd :: tl -> List.fold_left (fun acc x -> Infix.( || ) acc x) hd tl + module MyExpr = struct type nonrec t = t @@ -258,30 +337,6 @@ end module Set = Set.Make (MyExpr) module Map = Map.Make (MyExpr) -(** Map over expressions *) - -(* let rec map (f_before : t -> t * bool) (f_after : (t -> t) option) (expr : t) : - t = - (* Apply the mapping *) - let map_e = map f_before f_after in - let f_after = Option.value ~default:(fun x -> x) f_after in - - let mapped_expr, recurse = f_before expr in - if not recurse then mapped_expr - else - (* Map recursively to expressions *) - let mapped_expr = - match mapped_expr with - | Lit _ | PVar _ | LVar _ | ALoc _ -> mapped_expr - | UnOp (op, e) -> UnOp (op, map_e e) - | BinOp (e1, op, e2) -> BinOp (map_e e1, op, map_e e2) - | LstSub (e1, e2, e3) -> LstSub (map_e e1, map_e e2, map_e e3) - | NOp (op, es) -> NOp (op, List.map map_e es) - | EList es -> EList (List.map map_e es) - | ESet es -> ESet (List.map map_e es) - in - f_after mapped_expr *) - (** Optional map over expressions *) let rec map_opt @@ -318,9 +373,9 @@ let rec map_opt match map_e e with | Some e' -> Some (Exists (bt, e')) | _ -> None) - | EForall (bt, e) -> ( + | ForAll (bt, e) -> ( match map_e e with - | Some e' -> Some (EForall (bt, e')) + | Some e' -> Some (ForAll (bt, e')) | _ -> None) in Option.map f_after mapped_expr @@ -339,6 +394,7 @@ let rec pp fmt e = match op with | LstNth | StrNth | LstRepeat -> Fmt.pf fmt "%s(%a, %a)" (BinOp.str op) pp e1 pp e2 + | Equal -> Fmt.pf fmt "@[(%a %s %a)@]" pp e1 (BinOp.str op) pp e2 | _ -> Fmt.pf fmt "(%a %s %a)" pp e1 (BinOp.str op) pp e2) | LstSub (e1, e2, e3) -> Fmt.pf fmt "l-sub(%a, %a, %a)" pp e1 pp e2 pp e3 (* (uop e) *) @@ -354,7 +410,7 @@ let rec pp fmt e = Fmt.pf fmt "(exists %a . %a)" (Fmt.list ~sep:Fmt.comma pp_var_with_type) bt pp e - | EForall (bt, e) -> + | ForAll (bt, e) -> Fmt.pf fmt "(forall %a . %a)" (Fmt.list ~sep:Fmt.comma pp_var_with_type) bt pp e @@ -378,8 +434,7 @@ let rec full_pp fmt e = let to_expr (le : t) : t = le (** From expression to list, if possible *) -let to_list (le : t) : t list option = - match le with +let to_list : t -> t list option = function | EList les -> Some les | Lit (LList les) -> Some (List.map (fun x -> Lit x) les) | _ -> None @@ -392,20 +447,19 @@ let to_literal = function | _ -> None (** Get all the logical variables in --e-- *) -let lvars (le : t) : SS.t = - Visitors.Collectors.lvar_collector#visit_expr SS.empty le +let lvars : t -> SS.t = Visitors.Collectors.lvar_collector#visit_expr SS.empty (** Get all the abstract locations in --e-- *) -let alocs (le : t) : SS.t = Visitors.Collectors.aloc_collector#visit_expr () le +let alocs : t -> SS.t = Visitors.Collectors.aloc_collector#visit_expr () (** Get all the concrete locations in --e-- *) -let clocs (le : t) : SS.t = Visitors.Collectors.cloc_collector#visit_expr () le +let clocs : t -> SS.t = Visitors.Collectors.cloc_collector#visit_expr () -let locs (le : t) : SS.t = Visitors.Collectors.loc_collector#visit_expr () le +let locs : t -> SS.t = Visitors.Collectors.loc_collector#visit_expr () (** Get all substitutables in --e-- *) -let substitutables (le : t) : SS.t = - Visitors.Collectors.substitutable_collector#visit_expr () le +let substitutables : t -> SS.t = + Visitors.Collectors.substitutable_collector#visit_expr () let rec is_concrete (le : t) : bool = let f = is_concrete in @@ -418,25 +472,23 @@ let rec is_concrete (le : t) : bool = match le with | Lit _ | PVar _ -> true - | LVar _ | ALoc _ | Exists _ | EForall _ -> false + | LVar _ | ALoc _ | Exists _ | ForAll _ -> false | UnOp (_, e) -> loop [ e ] | BinOp (e1, _, e2) -> loop [ e1; e2 ] | LstSub (e1, e2, e3) -> loop [ e1; e2; e3 ] | NOp (_, les) | EList les | ESet les -> loop les -let is_concrete_zero_i (le : t) : bool = - match le with +let is_concrete_zero_i : t -> bool = function | Lit (Int z) -> Z.equal Z.zero z | _ -> false (** Get all the variables in --e-- *) -let vars (le : t) : SS.t = Visitors.Collectors.var_collector#visit_expr () le +let vars : t -> SS.t = Visitors.Collectors.var_collector#visit_expr () (** Are all expressions in the list literals? *) let all_literals les = List.for_all - (fun x -> - match x with + (function | Lit _ -> true | _ -> false) les @@ -466,6 +518,78 @@ let loc_from_loc_name (loc_name : string) : t = (** {2 Visitors} *) +let rec push_in_negations_off (a : t) : t = + let f_off = push_in_negations_off in + let f_on = push_in_negations_on in + match a with + | BinOp (a1, And, a2) -> BinOp (f_off a1, And, f_off a2) + | BinOp (a1, Or, a2) -> BinOp (f_off a1, Or, f_off a2) + | UnOp (Not, a1) -> f_on a1 + | ForAll (bt, a) -> ForAll (bt, f_off a) + | _ -> a + +and push_in_negations_on (a : t) : t = + let f_off = push_in_negations_off in + let f_on = push_in_negations_on in + match a with + | BinOp (a1, And, a2) -> BinOp (f_on a1, Or, f_on a2) + | BinOp (a1, Or, a2) -> BinOp (f_on a1, And, f_on a2) + | Lit (Bool b) -> Lit (Bool (not b)) + | UnOp (Not, a) -> f_off a + | _ -> UnOp (Not, a) + +and push_in_negations (a : t) : t = push_in_negations_off a + +(** Converts the given expression to a boolean expression, returning it and its negation. + Returns none if the expression cannot evaluate to a boolean. *) +let rec as_boolean_expr (e : t) : (t * t) option = + let open Syntaxes.Option in + let f = as_boolean_expr in + match e with + (* TODO: Do these two cases ever happen? If not, then this fn just does two things: + - types an Expr as a boolean expression + - negates this expr + And in this case we can simplify this into two differents fns, one for typing it and one + for negating it, because often we us this fn without using the negated expr, so it's + wasted work. *) + | LVar _ | PVar _ -> Some (BinOp (e, Equal, true_), BinOp (e, Equal, false_)) + | Lit (Bool b) -> Some (e, bool (not b)) + | BinOp (e1, FLessThan, e2) -> Some (e, BinOp (e2, FLessThanEqual, e1)) + | BinOp (e1, ILessThan, e2) -> Some (e, BinOp (e2, ILessThanEqual, e1)) + | BinOp (e1, FLessThanEqual, e2) -> Some (e, BinOp (e2, FLessThan, e1)) + | BinOp (e1, ILessThanEqual, e2) -> Some (e, BinOp (e2, ILessThan, e1)) + | BinOp (_, SetMem, _) + | BinOp (_, Equal, _) + | BinOp (_, StrLess, _) + | BinOp (_, SetSub, _) -> Some (e, UnOp (Not, e)) + | BinOp (e1, And, e2) -> + let* a1, na1 = f e1 in + let+ a2, na2 = f e2 in + (BinOp (a1, And, a2), BinOp (na1, Or, na2)) + | BinOp (e1, Or, e2) -> + let* a1, na1 = f e1 in + let+ a2, na2 = f e2 in + (BinOp (a1, Or, a2), BinOp (na1, And, na2)) + | BinOp (e1, Impl, e2) -> + let* a1, _ = f e1 in + let+ a2, na2 = f e2 in + (BinOp (a1, Impl, a2), BinOp (a1, And, na2)) + | UnOp (IsInt, _) -> Some (e, UnOp (Not, e)) + | UnOp (Not, e') -> + let+ a, na = f e' in + (na, a) + | Exists (bt, inner) -> + let+ inner, inner_neg = f inner in + let pos = Exists (bt, inner) in + let neg = ForAll (bt, inner_neg) in + (BinOp (pos, Equal, true_), neg) + | ForAll (bt, e) -> + let+ inner, inner_neg = f e in + let pos = ForAll (bt, inner) in + let neg = Exists (bt, inner_neg) in + (pos, BinOp (neg, Equal, true_)) + | _ -> None + let subst_expr_for_expr ~to_subst ~subst_with expr = let v = object @@ -494,7 +618,7 @@ let base_elements (expr : t) : t list = in v#visit_expr () expr -let pvars (e : t) : SS.t = Visitors.Collectors.pvar_collector#visit_expr () e +let pvars : t -> SS.t = Visitors.Collectors.pvar_collector#visit_expr () let var_to_expr (x : string) : t = if Names.is_lvar_name x then LVar x @@ -502,8 +626,7 @@ let var_to_expr (x : string) : t = else if is_pvar_name x then PVar x else raise (Failure ("var_to_expr: Impossible matchable: " ^ x)) -let is_matchable (e : t) : bool = - match e with +let is_matchable = function | PVar _ | LVar _ | ALoc _ | UnOp (LstLen, PVar _) | UnOp (LstLen, LVar _) -> true | _ -> false diff --git a/GillianCore/GIL_Syntax/Formula.ml b/GillianCore/GIL_Syntax/Formula.ml deleted file mode 100644 index ae52b295..00000000 --- a/GillianCore/GIL_Syntax/Formula.ml +++ /dev/null @@ -1,455 +0,0 @@ -type t = TypeDef__.formula = - | True (** Logical true *) - | False (** Logical false *) - | Not of t (** Logical negation *) - | And of t * t (** Logical conjunction *) - | Or of t * t (** Logical disjunction *) - | Eq of Expr.t * Expr.t (** Expression equality *) - | Impl of t * t (** Logical implication *) - | FLess of Expr.t * Expr.t (** Expression less-than for numbers *) - | FLessEq of Expr.t * Expr.t (** Expression less-than-or-equal for numbers *) - | ILess of Expr.t * Expr.t (** Expression less-than for integers *) - | ILessEq of Expr.t * Expr.t - (** Expression less-than-or-equal for integeres *) - | StrLess of Expr.t * Expr.t (** Expression less-than for strings *) - | SetMem of Expr.t * Expr.t (** Set membership *) - | SetSub of Expr.t * Expr.t (** Set subsetness *) - | ForAll of (string * Type.t option) list * t (** Forall *) - | IsInt of Expr.t (** IsInt e <=> (e : float) /\ (e % 1. == 0) *) -[@@deriving eq] - -let to_yojson = TypeDef__.formula_to_yojson -let of_yojson = TypeDef__.formula_of_yojson -let compare = Stdlib.compare -let of_bool b = if b then True else False - -module MyFormula = struct - type nonrec t = t - - let compare = Stdlib.compare -end - -module Set = Set.Make (MyFormula) - -let list_lexprs_collector = - object (self) - inherit [_] Visitors.reduce as super - method private zero = Expr.Set.empty - method private plus = Expr.Set.union - method! visit_'label () (_ : int) = self#zero - method! visit_'annot () () = self#zero - - method! visit_expr () e = - match e with - | Lit (LList _) - | EList _ - | NOp (LstCat, _) - | UnOp ((Car | Cdr | LstLen), _) -> Expr.Set.singleton e - | _ -> super#visit_expr () e - end - -(** Apply function f to the logic expressions in an assertion, recursively when f_a returns (new_asrt, true). *) -let rec map - (f_a_before : (t -> t * bool) option) - (f_a_after : (t -> t) option) - (f_e : (Expr.t -> Expr.t) option) - (a : t) : t = - (* Map recursively to assertions and expressions *) - let map_a = map f_a_before f_a_after f_e in - let map_e = Option.value ~default:(fun x -> x) f_e in - let f_a_before = Option.value ~default:(fun x -> (x, true)) f_a_before in - let f_a_after = Option.value ~default:(fun x -> x) f_a_after in - let a', recurse = f_a_before a in - - if not recurse then a' - else - let a'' = - match a' with - | And (a1, a2) -> And (map_a a1, map_a a2) - | Or (a1, a2) -> Or (map_a a1, map_a a2) - | Impl (a1, a2) -> Impl (map_a a1, map_a a2) - | Not a -> Not (map_a a) - | True -> True - | False -> False - | Eq (e1, e2) -> Eq (map_e e1, map_e e2) - | FLess (e1, e2) -> FLess (map_e e1, map_e e2) - | FLessEq (e1, e2) -> FLessEq (map_e e1, map_e e2) - | ILess (e1, e2) -> ILess (map_e e1, map_e e2) - | ILessEq (e1, e2) -> ILessEq (map_e e1, map_e e2) - | StrLess (e1, e2) -> StrLess (map_e e1, map_e e2) - | SetMem (e1, e2) -> SetMem (map_e e1, map_e e2) - | SetSub (e1, e2) -> SetSub (map_e e1, map_e e2) - | ForAll (bt, a) -> ForAll (bt, map_a a) - | IsInt e -> IsInt (map_e e) - in - f_a_after a'' - -let rec map_opt - (f_a_before : (t -> t option * bool) option) - (f_a_after : (t -> t) option) - (f_e : (Expr.t -> Expr.t option) option) - (a : t) : t option = - (* Map recursively to assertions and expressions *) - let map_a = map_opt f_a_before f_a_after f_e in - let map_e = Option.value ~default:(fun x -> Some x) f_e in - let f_a_before = Option.value ~default:(fun x -> (Some x, true)) f_a_before in - let f_a_after = Option.value ~default:(fun x -> x) f_a_after in - let a', recurse = f_a_before a in - - let aux_a_single a f = - let ma = map_a a in - Option.map f ma - in - - let aux_a_double a1 a2 f = - let ma1, ma2 = (map_a a1, map_a a2) in - if ma1 = None || ma2 = None then None - else Some (f (Option.get ma1) (Option.get ma2)) - in - - let aux_e e1 e2 f = - let me1, me2 = (map_e e1, map_e e2) in - if me1 = None || me2 = None then None - else Some (f (Option.get me1) (Option.get me2)) - in - - match a' with - | None -> None - | Some a' -> - if not recurse then Some a' - else - let a'' = - match a' with - | And (a1, a2) -> aux_a_double a1 a2 (fun a1 a2 -> And (a1, a2)) - | Or (a1, a2) -> aux_a_double a1 a2 (fun a1 a2 -> Or (a1, a2)) - | Impl (a1, a2) -> aux_a_double a1 a2 (fun a1 a2 -> Impl (a1, a2)) - | Not a -> aux_a_single a (fun a -> Not a) - | True -> Some True - | False -> Some False - | Eq (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> Eq (e1, e2)) - | ILess (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> ILess (e1, e2)) - | ILessEq (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> ILessEq (e1, e2)) - | FLess (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> FLess (e1, e2)) - | FLessEq (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> FLessEq (e1, e2)) - | StrLess (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> StrLess (e1, e2)) - | SetMem (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> SetMem (e1, e2)) - | SetSub (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> SetSub (e1, e2)) - | ForAll (bt, a) -> aux_a_single a (fun a -> ForAll (bt, a)) - | IsInt e -> map_e e |> Option.map (fun e -> IsInt e) - in - Option.map f_a_after a'' - -(* Get all the logical variables in --a-- *) -let lvars (f : t) : SS.t = - Visitors.Collectors.lvar_collector#visit_formula SS.empty f - -(* Get all the program variables in --a-- *) -let pvars (f : t) : SS.t = Visitors.Collectors.pvar_collector#visit_formula () f - -(* Get all the abstract locations in --a-- *) -let alocs (f : t) : SS.t = Visitors.Collectors.aloc_collector#visit_formula () f - -(* Get all the concrete locations in [a] *) -let clocs (f : t) : SS.t = Visitors.Collectors.cloc_collector#visit_formula () f - -(* Get all the locations in [a] *) -let locs (f : t) : SS.t = Visitors.Collectors.cloc_collector#visit_formula () f -let get_print_info (a : t) = (pvars a, lvars a, locs a) - -(* Get all the logical expressions of --a-- of the form (Lit (LList lst)) and (EList lst) *) -let lists (f : t) : Expr.t list = - Visitors.Collectors.list_collector#visit_formula () f - -(* Get all the logical expressions of --a-- that denote a list - and are not logical variables *) -let list_lexprs (f : t) : Expr.Set.t = list_lexprs_collector#visit_formula () f - -let rec push_in_negations_off (a : t) : t = - let f_off = push_in_negations_off in - let f_on = push_in_negations_on in - match a with - | And (a1, a2) -> And (f_off a1, f_off a2) - | Or (a1, a2) -> Or (f_off a1, f_off a2) - | Not a1 -> f_on a1 - | ForAll (bt, a) -> ForAll (bt, f_off a) - | _ -> a - -and push_in_negations_on (a : t) : t = - let f_off = push_in_negations_off in - let f_on = push_in_negations_on in - match a with - | And (a1, a2) -> Or (f_on a1, f_on a2) - | Or (a1, a2) -> And (f_on a1, f_on a2) - | True -> False - | False -> True - | Not a -> f_off a - | _ -> Not a - -and push_in_negations (a : t) : t = push_in_negations_off a - -let rec split_conjunct_formulae (f : t) : t list = - match f with - | And (f1, f2) -> split_conjunct_formulae f1 @ split_conjunct_formulae f2 - | Not (Or (f1, f2)) -> split_conjunct_formulae (And (Not f1, Not f2)) - | f -> [ f ] - -(****** Pretty Printing *********) - -(* To avoid code redundancy, we write a pp function parametric on the Expr printing function. - We then instantiate the function with Expr.pp and Expr.full_pp *) -let rec pp_parametric pp_expr fmt f = - let pp_var_with_type fmt (x, t_opt) = - Fmt.pf fmt "%s%a" x - (Fmt.option (fun fm t -> Fmt.pf fm " : %s" (Type.str t))) - t_opt - in - let pp = pp_parametric pp_expr in - match f with - (* a1 /\ a2 *) - | And (a1, a2) -> Fmt.pf fmt "(%a /\\@ %a)" pp a1 pp a2 - (* a1 \/ a2 *) - | Or (a1, a2) -> Fmt.pf fmt "(%a \\/@ %a)" pp a1 pp a2 - (* a1 ==> a2 *) - | Impl (a1, a2) -> Fmt.pf fmt "(%a ==> %a)" pp a1 pp a2 - (* ! a *) - | Not a -> Fmt.pf fmt "(! %a)" pp a - (* true *) - | True -> Fmt.string fmt "True" - (* false *) - | False -> Fmt.string fmt "False" - (* e1 == e2 *) - | Eq (e1, e2) -> Fmt.pf fmt "@[(%a ==@ %a)@]" pp_expr e1 pp_expr e2 - (* e1 <#e2 *) - | FLess (e1, e2) -> Fmt.pf fmt "(%a <# %a)" pp_expr e1 pp_expr e2 - (* e1 <=# e2 *) - | FLessEq (e1, e2) -> Fmt.pf fmt "(%a <=# %a)" pp_expr e1 pp_expr e2 - (* e1 i<# e2 *) - | ILess (e1, e2) -> Fmt.pf fmt "(%a i<# %a)" pp_expr e1 pp_expr e2 - (* e1 i<=# e2 *) - | ILessEq (e1, e2) -> Fmt.pf fmt "(%a i<=# %a)" pp_expr e1 pp_expr e2 - (* e1 Fmt.pf fmt "(%a s<# %a)" pp_expr e1 pp_expr e2 - (* forall vars . a *) - | ForAll (lvars, a) -> - Fmt.pf fmt "(forall %a . %a)" - (Fmt.list ~sep:Fmt.comma pp_var_with_type) - lvars pp a - (* e1 --e-- e2 *) - | SetMem (e1, e2) -> Fmt.pf fmt "(%a --e-- %a)" pp_expr e1 pp_expr e2 - (* e1 --s-- e2 *) - | SetSub (e1, e2) -> Fmt.pf fmt "(%a --s-- %a)" pp_expr e1 pp_expr e2 - | IsInt e -> Fmt.pf fmt "(is_int %a)" pp_expr e - -let pp = pp_parametric Expr.pp -let full_pp = pp_parametric Expr.full_pp - -let rec lift_logic_expr (e : Expr.t) : (t * t) option = - let open Syntaxes.Option in - let f = lift_logic_expr in - match e with - | LVar _ | PVar _ -> Some (Eq (e, Lit (Bool true)), Eq (e, Lit (Bool false))) - | Lit (Bool true) -> Some (True, False) - | Lit (Bool false) -> Some (False, True) - | BinOp (e1, Equal, e2) -> - let a = Eq (e1, e2) in - Some (a, Not a) - | BinOp (e1, FLessThan, e2) -> - let a = FLess (e1, e2) in - Some (a, Not a) - | BinOp (e1, ILessThan, e2) -> - let a = ILess (e1, e2) in - Some (a, Not a) - | BinOp (e1, SLessThan, e2) -> - let a = StrLess (e1, e2) in - Some (a, Not a) - | BinOp (e1, FLessThanEqual, e2) -> - let a = FLessEq (e1, e2) in - Some (a, Not a) - | BinOp (e1, ILessThanEqual, e2) -> - let a = ILessEq (e1, e2) in - Some (a, Not a) - | BinOp (e1, BSetMem, e2) -> - let a = SetMem (e1, e2) in - Some (a, Not a) - | BinOp (e1, BSetSub, e2) -> - let a = SetSub (e1, e2) in - Some (a, Not a) - | BinOp (e1, BAnd, e2) -> - let* a1, na1 = f e1 in - let+ a2, na2 = f e2 in - (And (a1, a2), Or (na1, na2)) - | BinOp (e1, BOr, e2) -> - let* a1, na1 = f e1 in - let+ a2, na2 = f e2 in - (Or (a1, a2), And (na1, na2)) - | BinOp (e1, BImpl, e2) -> - let* a1, _ = f e1 in - let+ a2, na2 = f e2 in - (Impl (a1, a2), And (a1, na2)) - | UnOp (UNot, e') -> - let+ a, na = f e' in - (na, a) - | Exists (bt, inner) as e -> - let+ _, inner_neg = f inner in - let neg = ForAll (bt, inner_neg) in - (Eq (e, Expr.bool true), neg) - | EForall (bt, e) -> - let+ inner, _ = f e in - let pos = ForAll (bt, inner) in - let inner_neg = Expr.Infix.not e in - let neg = Expr.Exists (bt, inner_neg) in - (pos, Eq (neg, Expr.bool true)) - | _ -> None - -let rec to_expr (a : t) : Expr.t option = - let f = to_expr in - match a with - | True -> Some (Expr.Lit (Bool true)) - | False -> Some (Expr.Lit (Bool false)) - | Not a' -> Option.map (fun a -> Expr.UnOp (UnOp.UNot, a)) (f a') - | And (a1, a2) -> ( - match (f a1, f a2) with - | Some le1, Some le2 -> Some (Expr.BinOp (le1, BinOp.BAnd, le2)) - | _ -> None) - | Or (a1, a2) -> ( - match (f a1, f a2) with - | Some le1, Some le2 -> Some (Expr.BinOp (le1, BinOp.BOr, le2)) - | _ -> None) - | Impl (a1, a2) -> ( - match (f (Not a1), f a2) with - | Some e1, Some e2 -> Some (Expr.BinOp (e1, BinOp.BOr, e2)) - | _ -> None) - | ForAll _ -> None - | Eq (le1, le2) -> Some (Expr.BinOp (le1, BinOp.Equal, le2)) - | FLess (le1, le2) -> Some (Expr.BinOp (le1, BinOp.FLessThan, le2)) - | FLessEq (le1, le2) -> Some (Expr.BinOp (le1, BinOp.FLessThanEqual, le2)) - | ILess (le1, le2) -> Some (Expr.BinOp (le1, BinOp.ILessThan, le2)) - | ILessEq (le1, le2) -> Some (Expr.BinOp (le1, BinOp.ILessThanEqual, le2)) - | StrLess (le1, le2) -> Some (Expr.BinOp (le1, BinOp.SLessThan, le2)) - | SetMem (le1, le2) -> Some (Expr.BinOp (le1, BinOp.BSetMem, le2)) - | SetSub (le1, le2) -> Some (Expr.BinOp (le1, BinOp.BSetSub, le2)) - | IsInt e -> - let is_float = Expr.type_eq e Type.NumberType in - let is_whole = - Expr.BinOp (Expr.fmod e (Expr.num 1.), BinOp.Equal, Expr.num 0.) - in - Some (Expr.BinOp (is_float, BinOp.BAnd, is_whole)) - -let rec disjunct (asrts : t list) : t = - match asrts with - | [] -> True - | [ a ] -> a - | a :: r_asrts -> Or (a, disjunct r_asrts) - -let subst_expr_for_expr ~(to_subst : Expr.t) ~(subst_with : Expr.t) (a : t) : t - = - map None None (Some (Expr.subst_expr_for_expr ~to_subst ~subst_with)) a - -let subst_clocs (subst : string -> Expr.t) (f : t) : t = - map None None (Some (Expr.subst_clocs subst)) f - -let rec get_disjuncts (fo : t) : t list = - (* Printf.printf "I am getting disjuncts every day!!\n"; *) - match fo with - | Or (fo1, fo2) -> - (* Printf.printf "More than one disjunct!\n"; *) - get_disjuncts fo1 @ get_disjuncts fo2 - | _ -> [ fo ] - -let strings_and_numbers = - let v = - object - inherit [_] Visitors.reduce - inherit Visitors.Utils.two_list_monoid - method! visit_Num _ n = ([], [ n ]) - method! visit_String _ s = ([ s ], []) - end - in - v#visit_formula () - -module Infix = struct - let fnot a = - match a with - | True -> False - | False -> True - | Not x -> x - | _ -> Not a - - let forall params f = ForAll (params, f) - - let ( #== ) a b = - match (a, b) with - | Expr.Lit la, Expr.Lit lb -> of_bool (Literal.equal la lb) - | a, b when Expr.equal a b -> True - | _ -> Eq (a, b) - - let ( #|| ) a b = - match (a, b) with - | True, _ | _, True -> True - | False, f | f, False -> f - | _ -> Or (a, b) - - let ( #&& ) a b = - match (a, b) with - | True, f | f, True -> f - | False, _ | _, False -> False - | _ -> And (a, b) - - let ( #< ) a b = - match (a, b) with - | Expr.Lit (Int x), Expr.Lit (Int y) -> of_bool (x < y) - | _ -> ILess (a, b) - - let ( #<= ) a b = - match (a, b) with - | Expr.Lit (Int x), Expr.Lit (Int y) -> of_bool (x <= y) - | _ -> ILessEq (a, b) - - let ( #> ) a b = - match (a, b) with - | Expr.Lit (Int x), Expr.Lit (Int y) -> of_bool (x > y) - | _ -> fnot a #<= b - - let ( #>= ) a b = - match (a, b) with - | Expr.Lit (Int x), Expr.Lit (Int y) -> of_bool (x >= y) - | _ -> fnot a #< b - - let ( #<. ) a b = - match (a, b) with - | Expr.Lit (Num x), Expr.Lit (Num y) -> of_bool (x < y) - | _ -> FLess (a, b) - - let ( #<=. ) a b = - match (a, b) with - | Expr.Lit (Num x), Expr.Lit (Num y) -> of_bool (x <= y) - | _ -> FLessEq (a, b) - - let ( #>. ) a b = - match (a, b) with - | Expr.Lit (Num x), Expr.Lit (Num y) -> of_bool (x > y) - | _ -> fnot a #<= b - - let ( #>=. ) a b = - match (a, b) with - | Expr.Lit (Num x), Expr.Lit (Num y) -> of_bool (x >= y) - | _ -> fnot a #< b - - let ( #=> ) fa fb = - match (fa, fb) with - | True, _ -> fb - | False, _ -> True - | _, True -> True - | _, False -> fnot fa - | _ -> Impl (fa, fb) -end - -let pvars_to_lvars (pf : t) : t = - let fe = Expr.pvars_to_lvars in - map None None (Some fe) pf - -let rec conjunct (asrts : t list) : t = - match asrts with - | [] -> True - | [ a ] -> a - | a :: r_asrts -> Infix.( #&& ) a (conjunct r_asrts) diff --git a/GillianCore/GIL_Syntax/Gil_syntax.ml b/GillianCore/GIL_Syntax/Gil_syntax.ml index 8f646982..656d5903 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.ml +++ b/GillianCore/GIL_Syntax/Gil_syntax.ml @@ -8,7 +8,6 @@ module Cmd = Cmd module Constant = Constant module Expr = Expr module Flag = Flag -module Formula = Formula module LCmd = LCmd module Lemma = Lemma module Literal = Literal diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 42466841..3d4ca0d3 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -129,7 +129,7 @@ module UnOp : sig type t = | IUnaryMinus (** Integer unary minus *) | FUnaryMinus (** Float unary minus *) - | UNot (** Negation *) + | Not (** Negation *) | BitwiseNot (** Bitwise negation *) | M_isNaN (** Test for NaN *) | M_abs (** Absolute value *) @@ -167,6 +167,7 @@ module UnOp : sig (* Integer vs Number *) | NumToInt (** Number to Integer - actual cast *) | IntToNum (** Integer to Number - actual cast *) + | IsInt (** IsInt e <=> (e : float) /\ (e % 1. == 0) *) [@@deriving yojson, eq] (** Printer *) @@ -193,10 +194,9 @@ module BinOp : sig | FTimes (** Float multiplication *) | FDiv (** Float division *) | FMod (** Float modulus *) - | SLessThan (** Less or equal for strings *) - | BAnd (** Boolean conjunction *) - | BOr (** Boolean disjunction *) - | BImpl (** Boolean implication *) + | And (** Boolean conjunction *) + | Or (** Boolean disjunction *) + | Impl (** Boolean implication *) | BitwiseAnd (** Bitwise conjunction *) | BitwiseOr (** Bitwise disjunction *) | BitwiseXor (** Bitwise exclusive disjunction *) @@ -208,7 +208,7 @@ module BinOp : sig | BitwiseXorL (** Bitwise exclusive disjunction 64bit *) | LeftShiftL (** Left bitshift 64bit *) | SignedRightShiftL (** Signed right bitshift 64bit *) - | UnsignedRightShiftL (** Unsigned right bitshift 64bit *) + | UnsignedRightShiftL (** Right bitshift 64bit *) | BitwiseAndF (** Bitwise conjunction float *) | BitwiseOrF (** Bitwise disjunction float *) | BitwiseXorF (** Bitwise exclusive disjunction float *) @@ -218,12 +218,14 @@ module BinOp : sig | M_atan2 (** Arctangent y/x *) | M_pow (** Power *) | LstNth (** Nth element of a string *) - | LstRepeat (** Nth element of a string *) + | LstRepeat + (* [[a; b]] is the list that contains [b] times the element [a] *) | StrCat (** String concatenation *) | StrNth (** Nth element of a string *) + | StrLess (** Less or equal for strings *) | SetDiff (** Set difference *) - | BSetMem (** Set membership *) - | BSetSub (** Subset *) + | SetMem (** Set membership *) + | SetSub (** Subset *) [@@deriving yojson, eq] (** Printer *) @@ -260,8 +262,8 @@ module Expr : sig | EList of t list (** Lists of expressions *) | ESet of t list (** Sets of expressions *) | Exists of (string * Type.t option) list * t - (** Existential quantification. This is now a circus because the separation between Formula and Expr doesn't make sense anymore. *) - | EForall of (string * Type.t option) list * t + (** Existential quantification. *) + | ForAll of (string * Type.t option) list * t [@@deriving yojson] (** {2: Helpers for building expressions} @@ -274,6 +276,8 @@ module Expr : sig val int_z : Z.t -> t val string : string -> t val bool : bool -> t + val false_ : t + val true_ : t val to_literal : t -> Literal.t option (** Lit (Int Z.zero) *) @@ -318,13 +322,33 @@ module Expr : sig (** {2: } *) - (** Boolean not *) + (** Comparison *) + + val ( < ) : t -> t -> t + val ( > ) : t -> t -> t + val ( <= ) : t -> t -> t + val ( >= ) : t -> t -> t + val ( <. ) : t -> t -> t + val ( >. ) : t -> t -> t + val ( <=. ) : t -> t -> t + val ( >=. ) : t -> t -> t + + (** Booleans *) + val not : t -> t + val forall : (string * Type.t option) list -> t -> t + val ( == ) : t -> t -> t + val ( && ) : t -> t -> t + val ( || ) : t -> t -> t + val ( ==> ) : t -> t -> t (** List concatenation *) val ( @+ ) : t -> t -> t end + val conjunct : t list -> t + val disjunct : t list -> t + (** Sets of expressions *) module Set : Set.S with type elt := t @@ -370,6 +394,13 @@ module Expr : sig (** [vars e] returns all variables in [e] (includes lvars, pvars, alocs and clocs) *) val vars : t -> SS.t + (** [push_in_negations e] negates e, recursively *) + val push_in_negations : t -> t + + (** Converts the given expression to a boolean expression, returning it and its negation. + Returns none if the expression cannot evaluate to a boolean. *) + val as_boolean_expr : t -> (t * t) option + (** [substitutables e] returns all lvars and alocs *) val substitutables : t -> SS.t @@ -409,192 +440,33 @@ module Expr : sig val is_matchable : t -> bool end -(** @canonical Gillian.Gil_syntax.Formula *) -module Formula : sig - (** GIL Formulae *) - - type t = - | True (** Logical true *) - | False (** Logical false *) - | Not of t (** Logical negation *) - | And of t * t (** Logical conjunction *) - | Or of t * t (** Logical disjunction *) - | Eq of Expr.t * Expr.t (** Expression equality *) - | Impl of t * t (** Logical implication *) - | FLess of Expr.t * Expr.t (** Expression less-than for numbers *) - | FLessEq of Expr.t * Expr.t - (** Expression less-than-or-equal for numbers *) - | ILess of Expr.t * Expr.t (** Expression less-than for integers *) - | ILessEq of Expr.t * Expr.t - (** Expression less-than-or-equal for integeres *) - | StrLess of Expr.t * Expr.t (** Expression less-than for strings *) - | SetMem of Expr.t * Expr.t (** Set membership *) - | SetSub of Expr.t * Expr.t (** Set subsetness *) - | ForAll of (string * Type.t option) list * t (** Forall *) - | IsInt of Expr.t (** IsInt e <=> (e : float) /\ (e % 1. == 0) *) - [@@deriving yojson, eq] - - val of_bool : bool -> t - - (** Sets of formulae *) - module Set : Set.S with type elt := t - - (** @deprecated Use {!Visitors.endo} instead *) - val map : - (t -> t * bool) option -> - (t -> t) option -> - (Expr.t -> Expr.t) option -> - t -> - t - - val map_opt : - (t -> t option * bool) option -> - (t -> t) option -> - (Expr.t -> Expr.t option) option -> - t -> - t option - - (** Get all the logical variables*) - val lvars : t -> SS.t - - (** Get all the program variables *) - val pvars : t -> SS.t - - (** Get all the abstract locations *) - val alocs : t -> SS.t - - (** Get all the concrete locations *) - val clocs : t -> SS.t - - (** Get all locations *) - val locs : t -> SS.t - - (** Get print info *) - val get_print_info : t -> SS.t * SS.t * SS.t - - (** Get all the logical expressions of the formula of the form (Lit (LList lst)) and (EList lst) *) - val lists : t -> Expr.t list - - (** Get all the list expressions *) - val list_lexprs : t -> Expr.Set.t - - (** [push_in_negations a] takes negations off the toplevel of [a] and pushes them in the leaves. - For example [push_in_negations (Not (And (True, False)))] returns [Or (False, False)] *) - val push_in_negations : t -> t - - (** Turns [f1 /\ f2 /\ f3] into [\[f1; f2; f3\]] *) - val split_conjunct_formulae : t -> t list - - (** Pretty-printer *) - val pp : Format.formatter -> t -> unit - - (** Pretty-printer with constructors (will not parse) *) - val full_pp : Format.formatter -> t -> unit - - (** Lifts an expression to a formula, if possible. It returns - the lifted expression and its negation *) - val lift_logic_expr : Expr.t -> (t * t) option - - (** Unlifts the formula to an expression, if possible *) - val to_expr : t -> Expr.t option - - (** [conjunct \[a1; ...; an\]] returns [a1 /\ ... /\ an] *) - val conjunct : t list -> t - - (** [disjunct \[a1; ...; an\]] returns [a1 \/ ... \/ an] *) - val disjunct : t list -> t - - val subst_expr_for_expr : to_subst:Expr.t -> subst_with:Expr.t -> t -> t - - (** [subst_clocs subst e] Substitutes expressions of the form [Lit (Loc l)] with [subst l] in [e] *) - val subst_clocs : (string -> Expr.t) -> t -> t - - (** [get_disjuncts (a1 \/ ... \/ an)] returns [\[a1; ...; an\]] *) - val get_disjuncts : t -> t list - - (** Returns a list of strings and a list of numbers that are contained in the formula *) - val strings_and_numbers : t -> string list * float list - - module Infix : sig - (** Same as Not *) - val fnot : t -> t - - (** Same as Forall *) - val forall : (string * Type.t option) list -> t -> t - - (** Same as Or *) - val ( #|| ) : t -> t -> t - - (** Same as And *) - val ( #&& ) : t -> t -> t - - (** Same as Eq *) - val ( #== ) : Expr.t -> Expr.t -> t - - (** Same as ILess *) - val ( #< ) : Expr.t -> Expr.t -> t - - (** [a #> b] if [Not ILess (b, a)]*) - val ( #> ) : Expr.t -> Expr.t -> t - - (** Same as ILessEq *) - val ( #<= ) : Expr.t -> Expr.t -> t - - (** [a #>= b] is [Not ILess (b, a)] *) - val ( #>= ) : Expr.t -> Expr.t -> t - - (** Same as FLess *) - val ( #<. ) : Expr.t -> Expr.t -> t - - (** [a #>. b] if [Not FLess (b, a)]*) - val ( #>. ) : Expr.t -> Expr.t -> t - - (** Same as FLessEq *) - val ( #<=. ) : Expr.t -> Expr.t -> t - - (** [a #>=. b] is [Not FLess (b, a)] *) - val ( #>=. ) : Expr.t -> Expr.t -> t - - val ( #=> ) : t -> t -> t - end -end - (** @canonical Gillian.Gil_syntax.Asrt *) module Asrt : sig (** GIL Assertions *) - type t = + type atom = | Emp (** Empty heap *) - | Star of t * t (** Separating conjunction *) | Pred of string * Expr.t list (** Predicates *) - | Pure of Formula.t (** Pure formula *) + | Pure of Expr.t (** Pure formula *) | Types of (Expr.t * Type.t) list (** Typing assertion *) - | GA of string * Expr.t list * Expr.t list (** Core assertion *) + | CorePred of string * Expr.t list * Expr.t list (** Core assertion *) | Wand of { lhs : string * Expr.t list; rhs : string * Expr.t list } (** Magic wand of the form [P(...) -* Q(...)] *) [@@deriving yojson, eq] + type t = atom list [@@deriving yojson, eq] + (** Comparison of assertions *) - val compare : t -> t -> int + val compare : atom -> atom -> int (** Sorting of assertions *) - val prioritise : t -> t -> int + val prioritise : atom -> atom -> int (** Sets of assertions *) module Set : Set.S with type elt := t (** @deprecated Use {!Visitors.endo} instead *) - val map : - (t -> t * bool) option -> - (t -> t) option -> - (Expr.t -> Expr.t) option -> - (Formula.t -> Formula.t) option -> - t -> - t - - (** Get all the logical expressions of [a] that denote a list - and are not logical variables *) - val list_lexprs : t -> Expr.Set.t + val map : (Expr.t -> Expr.t) -> t -> t (** Get all the logical variables in [a] *) val lvars : t -> SS.t @@ -615,31 +487,25 @@ module Asrt : sig val pred_names : t -> string list (** Returns a list with the pure assertions that occur in [a] *) - val pure_asrts : t -> Formula.t list - - (** Returns a list with the pure assertions that occur in [a] *) - val simple_asrts : t -> t list + val pure_asrts : t -> Expr.t list (** Check if [a] is a pure assertion *) - val is_pure_asrt : t -> bool + val is_pure_asrt : atom -> bool - (** Check if [a] is a pure assertion & non-recursive assertion. - It assumes that only pure assertions are universally quantified *) - val is_pure_non_rec_asrt : t -> bool - - (** Eliminate LStar and LTypes assertions. - LTypes disappears. LStar is replaced by LAnd. - This function expects its argument to be a PURE assertion. *) - val make_pure : t -> Formula.t + (** Eliminate Emp assertions. + Pure assertions are converted to a single formula. + This function expects its argument to be a PURE assertion. *) + val make_pure : t -> Expr.t (** Pretty-printer *) val pp : Format.formatter -> t -> unit + val pp_atom : Format.formatter -> atom -> unit + (** Full pretty-printer *) val full_pp : Format.formatter -> t -> unit - (** [star \[a1; a2; ...; an\] will return \[a1 * a2 * ... * an\]] *) - val star : t list -> t + val pp_atom_full : Format.formatter -> atom -> unit (** [subst_clocs subst a] Substitutes expressions of the form [Lit (Loc l)] with [subst l] in [a] *) val subst_clocs : (string -> Expr.t) -> t -> t @@ -649,11 +515,6 @@ module Asrt : sig (** Move pvars to lvars *) val pvars_to_lvars : t -> t - - module Infix : sig - (** Star constructor *) - val ( ** ) : t -> t -> t - end end (** @canonical Gillian.Gil_syntax.SLCmd *) @@ -676,12 +537,7 @@ module SLCmd : sig | SymbExec (** @deprecated Use {!Visitors.endo} instead *) - val map : - (t -> t) option -> - (Asrt.t -> Asrt.t) option -> - (Expr.t -> Expr.t) option -> - t -> - t + val map : (Asrt.t -> Asrt.t) -> (Expr.t -> Expr.t) -> t -> t (** Pretty-printer of folding info *) val pp_folding_info : (string * (string * Expr.t) list) option Fmt.t @@ -698,22 +554,16 @@ module LCmd : sig type t = | If of Expr.t * t list * t list (** If-then-else *) - | Branch of Formula.t (** Branching on a FO formual *) + | Branch of Expr.t (** Branching on a FO formual *) | Macro of string * Expr.t list (** Macros *) - | Assert of Formula.t (** Assert *) - | Assume of Formula.t (** Assume *) + | Assert of Expr.t (** Assert *) + | Assume of Expr.t (** Assume *) | AssumeType of Expr.t * Type.t (** Assume Type *) | FreshSVar of string (** x := fresh_svar() *) | SL of SLCmd.t (** Separation-logic command *) (** @deprecated Use {!Visitors.endo} instead *) - val map : - (t -> t) option -> - (Expr.t -> Expr.t) option -> - (Formula.t -> Formula.t) option -> - (SLCmd.t -> SLCmd.t) option -> - t -> - t + val map : (Expr.t -> Expr.t) -> (SLCmd.t -> SLCmd.t) -> t -> t (** Pretty-printer *) val pp : t Fmt.t @@ -783,7 +633,7 @@ module Pred : sig pred_ins : int list; (** Ins *) pred_definitions : ((string * string list) option * Asrt.t) list; (** Predicate definitions *) - pred_facts : Formula.t list; (** Facts that hold for every definition *) + pred_facts : Expr.t list; (** Facts that hold for every definition *) pred_guard : Asrt.t option; (** Cost for unfolding the predicate *) pred_pure : bool; (** Is the predicate pure? *) pred_abstract : bool; (** Is the predicate abstract? *) @@ -845,7 +695,7 @@ module Pred : sig (** Given a guarded predicate, return a "call" to its close token. The arguments given are PVars with the same name as the ins of the predicate. *) - val close_token_call : t -> Asrt.t + val close_token_call : t -> Asrt.atom (** Given a name, if it's a close_token name, returns the name of the corresponding predicate, otherwise return None. *) @@ -1269,22 +1119,17 @@ module Visitors : sig 'b = < visit_'annot : 'c -> 'd -> 'd ; visit_'label : 'c -> 'f -> 'f ; visit_ALoc : 'c -> Expr.t -> string -> Expr.t - ; visit_And : 'c -> Formula.t -> Formula.t -> Formula.t -> Formula.t - ; visit_Impl : 'c -> Formula.t -> Formula.t -> Formula.t -> Formula.t + ; visit_And : 'c -> BinOp.t -> BinOp.t + ; visit_Impl : 'c -> BinOp.t -> BinOp.t ; visit_Apply : 'c -> 'f Cmd.t -> string -> Expr.t -> 'f option -> 'f Cmd.t ; visit_ApplyLem : 'c -> SLCmd.t -> string -> Expr.t list -> string list -> SLCmd.t ; visit_Arguments : 'c -> 'f Cmd.t -> string -> 'f Cmd.t - ; visit_Assert : 'c -> LCmd.t -> Formula.t -> LCmd.t + ; visit_Assert : 'c -> LCmd.t -> Expr.t -> LCmd.t ; visit_Assignment : 'c -> 'f Cmd.t -> string -> Expr.t -> 'f Cmd.t - ; visit_Assume : 'c -> LCmd.t -> Formula.t -> LCmd.t + ; visit_Assume : 'c -> LCmd.t -> Expr.t -> LCmd.t ; visit_AssumeType : 'c -> LCmd.t -> Expr.t -> Type.t -> LCmd.t - ; visit_BAnd : 'c -> BinOp.t -> BinOp.t - ; visit_BOr : 'c -> BinOp.t -> BinOp.t - ; visit_BImpl : 'c -> BinOp.t -> BinOp.t - ; visit_BSetMem : 'c -> BinOp.t -> BinOp.t - ; visit_BSetSub : 'c -> BinOp.t -> BinOp.t ; visit_BinOp : 'c -> Expr.t -> Expr.t -> BinOp.t -> Expr.t -> Expr.t ; visit_BitwiseAnd : 'c -> BinOp.t -> BinOp.t ; visit_BitwiseAndL : 'c -> BinOp.t -> BinOp.t @@ -1298,7 +1143,7 @@ module Visitors : sig ; visit_BitwiseXorF : 'c -> BinOp.t -> BinOp.t ; visit_Bool : 'c -> Literal.t -> bool -> Literal.t ; visit_BooleanType : 'c -> Type.t -> Type.t - ; visit_Branch : 'c -> LCmd.t -> Formula.t -> LCmd.t + ; visit_Branch : 'c -> LCmd.t -> Expr.t -> LCmd.t ; visit_Bug : 'c -> Flag.t -> Flag.t ; visit_Call : 'c -> @@ -1324,13 +1169,10 @@ module Visitors : sig ; visit_ESet : 'c -> Expr.t -> Expr.t list -> Expr.t ; visit_Exists : 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - ; visit_EForall : - 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - ; visit_Emp : 'c -> Asrt.t -> Asrt.t + ; visit_Emp : 'c -> Asrt.atom -> Asrt.atom ; visit_Empty : 'c -> Literal.t -> Literal.t ; visit_EmptyType : 'c -> Type.t -> Type.t ; visit_Epsilon : 'c -> Constant.t -> Constant.t - ; visit_Eq : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t ; visit_Equal : 'c -> BinOp.t -> BinOp.t ; visit_Error : 'c -> Flag.t -> Flag.t ; visit_FDiv : 'c -> BinOp.t -> BinOp.t @@ -1338,11 +1180,12 @@ module Visitors : sig ; visit_FLessThanEqual : 'c -> BinOp.t -> BinOp.t ; visit_FMinus : 'c -> BinOp.t -> BinOp.t ; visit_FMod : 'c -> BinOp.t -> BinOp.t + ; visit_ForAll : + 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t ; visit_FPlus : 'c -> BinOp.t -> BinOp.t ; visit_FTimes : 'c -> BinOp.t -> BinOp.t ; visit_FUnaryMinus : 'c -> UnOp.t -> UnOp.t ; visit_Fail : 'c -> 'f Cmd.t -> string -> Expr.t list -> 'f Cmd.t - ; visit_False : 'c -> Formula.t -> Formula.t ; visit_Fold : 'c -> SLCmd.t -> @@ -1350,20 +1193,19 @@ module Visitors : sig Expr.t list -> (string * (string * Expr.t) list) option -> SLCmd.t - ; visit_ForAll : + ; visit_CorePred : 'c -> - Formula.t -> - (string * Type.t option) list -> - Formula.t -> - Formula.t - ; visit_GA : - 'c -> Asrt.t -> string -> Expr.t list -> Expr.t list -> Asrt.t + Asrt.atom -> + string -> + Expr.t list -> + Expr.t list -> + Asrt.atom ; visit_Wand : 'c -> - Asrt.t -> + Asrt.atom -> string * Expr.t list -> string * Expr.t list -> - Asrt.t + Asrt.atom ; visit_GUnfold : 'c -> SLCmd.t -> string -> SLCmd.t ; visit_Goto : 'c -> 'f Cmd.t -> 'f -> 'f Cmd.t ; visit_GuardedGoto : 'c -> 'f Cmd.t -> Expr.t -> 'f -> 'f -> 'f Cmd.t @@ -1389,11 +1231,7 @@ module Visitors : sig ; visit_LeftShift : 'c -> BinOp.t -> BinOp.t ; visit_LeftShiftL : 'c -> BinOp.t -> BinOp.t ; visit_LeftShiftF : 'c -> BinOp.t -> BinOp.t - ; visit_FLess : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - ; visit_FLessEq : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - ; visit_ILess : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - ; visit_ILessEq : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - ; visit_IsInt : 'c -> Formula.t -> Expr.t -> Formula.t + ; visit_IsInt : 'c -> UnOp.t -> UnOp.t ; visit_ListType : 'c -> Type.t -> Type.t ; visit_Lit : 'c -> Expr.t -> Literal.t -> Expr.t ; visit_Loc : 'c -> Literal.t -> string -> Literal.t @@ -1430,29 +1268,28 @@ module Visitors : sig ; visit_NoneType : 'c -> Type.t -> Type.t ; visit_Nono : 'c -> Literal.t -> Literal.t ; visit_Normal : 'c -> Flag.t -> Flag.t - ; visit_Not : 'c -> Formula.t -> Formula.t -> Formula.t + ; visit_Not : 'c -> UnOp.t -> UnOp.t ; visit_Null : 'c -> Literal.t -> Literal.t ; visit_NullType : 'c -> Type.t -> Type.t ; visit_Num : 'c -> Literal.t -> float -> Literal.t ; visit_NumberType : 'c -> Type.t -> Type.t ; visit_ObjectType : 'c -> Type.t -> Type.t - ; visit_Or : 'c -> Formula.t -> Formula.t -> Formula.t -> Formula.t + ; visit_Or : 'c -> BinOp.t -> BinOp.t ; visit_PVar : 'c -> Expr.t -> string -> Expr.t ; visit_PhiAssignment : 'c -> 'f Cmd.t -> (string * Expr.t list) list -> 'f Cmd.t ; visit_Pi : 'c -> Constant.t -> Constant.t - ; visit_Pred : 'c -> Asrt.t -> string -> Expr.t list -> Asrt.t - ; visit_Pure : 'c -> Asrt.t -> Formula.t -> Asrt.t + ; visit_Pred : 'c -> Asrt.atom -> string -> Expr.t list -> Asrt.atom + ; visit_Pure : 'c -> Asrt.atom -> Expr.t -> Asrt.atom ; visit_Random : 'c -> Constant.t -> Constant.t ; visit_ReturnError : 'c -> 'f Cmd.t -> 'f Cmd.t ; visit_ReturnNormal : 'c -> 'f Cmd.t -> 'f Cmd.t ; visit_SL : 'c -> LCmd.t -> SLCmd.t -> LCmd.t - ; visit_SLessThan : 'c -> BinOp.t -> BinOp.t ; visit_SepAssert : 'c -> SLCmd.t -> Asrt.t -> string list -> SLCmd.t ; visit_SetDiff : 'c -> BinOp.t -> BinOp.t ; visit_SetInter : 'c -> NOp.t -> NOp.t - ; visit_SetMem : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - ; visit_SetSub : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t + ; visit_SetMem : 'c -> BinOp.t -> BinOp.t + ; visit_SetSub : 'c -> BinOp.t -> BinOp.t ; visit_SetToList : 'c -> UnOp.t -> UnOp.t ; visit_SetType : 'c -> Type.t -> Type.t ; visit_SetUnion : 'c -> NOp.t -> NOp.t @@ -1461,12 +1298,12 @@ module Visitors : sig ; visit_SignedRightShiftF : 'c -> BinOp.t -> BinOp.t ; visit_Skip : 'c -> 'f Cmd.t -> 'f Cmd.t ; visit_FreshSVar : 'c -> LCmd.t -> string -> LCmd.t - ; visit_Star : 'c -> Asrt.t -> Asrt.t -> Asrt.t -> Asrt.t ; visit_StrCat : 'c -> BinOp.t -> BinOp.t ; visit_StrLen : 'c -> UnOp.t -> UnOp.t + ; visit_StrLess : 'c -> BinOp.t -> BinOp.t ; visit_NumToInt : 'c -> UnOp.t -> UnOp.t ; visit_IntToNum : 'c -> UnOp.t -> UnOp.t - ; visit_StrLess : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t + ; visit_StrLess : 'c -> BinOp.t -> BinOp.t ; visit_StrNth : 'c -> BinOp.t -> BinOp.t ; visit_String : 'c -> Literal.t -> string -> Literal.t ; visit_StringType : 'c -> Type.t -> Type.t @@ -1477,12 +1314,10 @@ module Visitors : sig ; visit_ToStringOp : 'c -> UnOp.t -> UnOp.t ; visit_ToUint16Op : 'c -> UnOp.t -> UnOp.t ; visit_ToUint32Op : 'c -> UnOp.t -> UnOp.t - ; visit_True : 'c -> Formula.t -> Formula.t ; visit_Type : 'c -> Literal.t -> Type.t -> Literal.t ; visit_TypeOf : 'c -> UnOp.t -> UnOp.t ; visit_TypeType : 'c -> Type.t -> Type.t - ; visit_Types : 'c -> Asrt.t -> (Expr.t * Type.t) list -> Asrt.t - ; visit_UNot : 'c -> UnOp.t -> UnOp.t + ; visit_Types : 'c -> Asrt.atom -> (Expr.t * Type.t) list -> Asrt.atom ; visit_UTCTime : 'c -> Constant.t -> Constant.t ; visit_UnOp : 'c -> Expr.t -> UnOp.t -> Expr.t -> Expr.t ; visit_Undefined : 'c -> Literal.t -> Literal.t @@ -1504,6 +1339,7 @@ module Visitors : sig ; visit_UnsignedRightShift : 'c -> BinOp.t -> BinOp.t ; visit_UnsignedRightShiftL : 'c -> BinOp.t -> BinOp.t ; visit_UnsignedRightShiftF : 'c -> BinOp.t -> BinOp.t + ; visit_assertion_atom : 'c -> Asrt.atom -> Asrt.atom ; visit_assertion : 'c -> Asrt.t -> Asrt.t ; visit_bindings : 'c -> @@ -1515,7 +1351,6 @@ module Visitors : sig ; visit_constant : 'c -> Constant.t -> Constant.t ; visit_expr : 'c -> Expr.t -> Expr.t ; visit_flag : 'c -> Flag.t -> Flag.t - ; visit_formula : 'c -> Formula.t -> Formula.t ; visit_lcmd : 'c -> LCmd.t -> LCmd.t ; visit_lemma : 'c -> Lemma.t -> Lemma.t ; visit_lemma_spec : 'c -> Lemma.spec -> Lemma.spec @@ -1534,8 +1369,8 @@ module Visitors : sig method visit_'annot : 'c -> 'd -> 'd method visit_'label : 'c -> 'f -> 'f method visit_ALoc : 'c -> Expr.t -> string -> Expr.t - method visit_And : 'c -> Formula.t -> Formula.t -> Formula.t -> Formula.t - method visit_Impl : 'c -> Formula.t -> Formula.t -> Formula.t -> Formula.t + method visit_And : 'c -> BinOp.t -> BinOp.t + method visit_Impl : 'c -> BinOp.t -> BinOp.t method visit_Apply : 'c -> 'f Cmd.t -> string -> Expr.t -> 'f option -> 'f Cmd.t @@ -1544,15 +1379,10 @@ module Visitors : sig 'c -> SLCmd.t -> string -> Expr.t list -> string list -> SLCmd.t method visit_Arguments : 'c -> 'f Cmd.t -> string -> 'f Cmd.t - method visit_Assert : 'c -> LCmd.t -> Formula.t -> LCmd.t + method visit_Assert : 'c -> LCmd.t -> Expr.t -> LCmd.t method visit_Assignment : 'c -> 'f Cmd.t -> string -> Expr.t -> 'f Cmd.t - method visit_Assume : 'c -> LCmd.t -> Formula.t -> LCmd.t + method visit_Assume : 'c -> LCmd.t -> Expr.t -> LCmd.t method visit_AssumeType : 'c -> LCmd.t -> Expr.t -> Type.t -> LCmd.t - method visit_BAnd : 'c -> BinOp.t -> BinOp.t - method visit_BOr : 'c -> BinOp.t -> BinOp.t - method visit_BImpl : 'c -> BinOp.t -> BinOp.t - method visit_BSetMem : 'c -> BinOp.t -> BinOp.t - method visit_BSetSub : 'c -> BinOp.t -> BinOp.t method visit_BinOp : 'c -> Expr.t -> Expr.t -> BinOp.t -> Expr.t -> Expr.t method visit_BitwiseAnd : 'c -> BinOp.t -> BinOp.t method visit_BitwiseAndL : 'c -> BinOp.t -> BinOp.t @@ -1566,7 +1396,7 @@ module Visitors : sig method visit_BitwiseXorF : 'c -> BinOp.t -> BinOp.t method visit_Bool : 'c -> Literal.t -> bool -> Literal.t method visit_BooleanType : 'c -> Type.t -> Type.t - method visit_Branch : 'c -> LCmd.t -> Formula.t -> LCmd.t + method visit_Branch : 'c -> LCmd.t -> Expr.t -> LCmd.t method visit_Bug : 'c -> Flag.t -> Flag.t method visit_Call : @@ -1592,14 +1422,10 @@ module Visitors : sig method visit_Exists : 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - method visit_EForall : - 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - - method visit_Emp : 'c -> Asrt.t -> Asrt.t + method visit_Emp : 'c -> Asrt.atom -> Asrt.atom method visit_Empty : 'c -> Literal.t -> Literal.t method visit_EmptyType : 'c -> Type.t -> Type.t method visit_Epsilon : 'c -> Constant.t -> Constant.t - method visit_Eq : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t method visit_Equal : 'c -> BinOp.t -> BinOp.t method visit_Error : 'c -> Flag.t -> Flag.t method visit_FDiv : 'c -> BinOp.t -> BinOp.t @@ -1611,7 +1437,6 @@ module Visitors : sig method visit_FTimes : 'c -> BinOp.t -> BinOp.t method visit_FUnaryMinus : 'c -> UnOp.t -> UnOp.t method visit_Fail : 'c -> 'f Cmd.t -> string -> Expr.t list -> 'f Cmd.t - method visit_False : 'c -> Formula.t -> Formula.t method visit_Fold : 'c -> @@ -1622,13 +1447,17 @@ module Visitors : sig SLCmd.t method visit_ForAll : - 'c -> Formula.t -> (string * Type.t option) list -> Formula.t -> Formula.t + 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - method visit_GA : - 'c -> Asrt.t -> string -> Expr.t list -> Expr.t list -> Asrt.t + method visit_CorePred : + 'c -> Asrt.atom -> string -> Expr.t list -> Expr.t list -> Asrt.atom method visit_Wand : - 'c -> Asrt.t -> string * Expr.t list -> string * Expr.t list -> Asrt.t + 'c -> + Asrt.atom -> + string * Expr.t list -> + string * Expr.t list -> + Asrt.atom method visit_GUnfold : 'c -> SLCmd.t -> string -> SLCmd.t method visit_Goto : 'c -> 'f Cmd.t -> 'f -> 'f Cmd.t @@ -1659,11 +1488,7 @@ module Visitors : sig method visit_LeftShift : 'c -> BinOp.t -> BinOp.t method visit_LeftShiftL : 'c -> BinOp.t -> BinOp.t method visit_LeftShiftF : 'c -> BinOp.t -> BinOp.t - method visit_FLess : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - method visit_FLessEq : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - method visit_ILess : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - method visit_ILessEq : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - method visit_IsInt : 'c -> Formula.t -> Expr.t -> Formula.t + method visit_IsInt : 'c -> UnOp.t -> UnOp.t method visit_ListType : 'c -> Type.t -> Type.t method visit_Lit : 'c -> Expr.t -> Literal.t -> Expr.t method visit_Loc : 'c -> Literal.t -> string -> Literal.t @@ -1700,31 +1525,30 @@ module Visitors : sig method visit_NoneType : 'c -> Type.t -> Type.t method visit_Nono : 'c -> Literal.t -> Literal.t method visit_Normal : 'c -> Flag.t -> Flag.t - method visit_Not : 'c -> Formula.t -> Formula.t -> Formula.t + method visit_Not : 'c -> UnOp.t -> UnOp.t method visit_Null : 'c -> Literal.t -> Literal.t method visit_NullType : 'c -> Type.t -> Type.t method visit_Num : 'c -> Literal.t -> float -> Literal.t method visit_NumberType : 'c -> Type.t -> Type.t method visit_ObjectType : 'c -> Type.t -> Type.t - method visit_Or : 'c -> Formula.t -> Formula.t -> Formula.t -> Formula.t + method visit_Or : 'c -> BinOp.t -> BinOp.t method visit_PVar : 'c -> Expr.t -> string -> Expr.t method visit_PhiAssignment : 'c -> 'f Cmd.t -> (string * Expr.t list) list -> 'f Cmd.t method visit_Pi : 'c -> Constant.t -> Constant.t - method visit_Pred : 'c -> Asrt.t -> string -> Expr.t list -> Asrt.t - method visit_Pure : 'c -> Asrt.t -> Formula.t -> Asrt.t + method visit_Pred : 'c -> Asrt.atom -> string -> Expr.t list -> Asrt.atom + method visit_Pure : 'c -> Asrt.atom -> Expr.t -> Asrt.atom method visit_Random : 'c -> Constant.t -> Constant.t method visit_ReturnError : 'c -> 'f Cmd.t -> 'f Cmd.t method visit_ReturnNormal : 'c -> 'f Cmd.t -> 'f Cmd.t method visit_SL : 'c -> LCmd.t -> SLCmd.t -> LCmd.t - method visit_SLessThan : 'c -> BinOp.t -> BinOp.t method visit_SepAssert : 'c -> SLCmd.t -> Asrt.t -> string list -> SLCmd.t method visit_SetDiff : 'c -> BinOp.t -> BinOp.t method visit_SetInter : 'c -> NOp.t -> NOp.t - method visit_SetMem : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - method visit_SetSub : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t + method visit_SetMem : 'c -> BinOp.t -> BinOp.t + method visit_SetSub : 'c -> BinOp.t -> BinOp.t method visit_SetToList : 'c -> UnOp.t -> UnOp.t method visit_SetType : 'c -> Type.t -> Type.t method visit_SetUnion : 'c -> NOp.t -> NOp.t @@ -1733,12 +1557,12 @@ module Visitors : sig method visit_SignedRightShiftF : 'c -> BinOp.t -> BinOp.t method visit_Skip : 'c -> 'f Cmd.t -> 'f Cmd.t method visit_FreshSVar : 'c -> LCmd.t -> string -> LCmd.t - method visit_Star : 'c -> Asrt.t -> Asrt.t -> Asrt.t -> Asrt.t method visit_StrCat : 'c -> BinOp.t -> BinOp.t method visit_StrLen : 'c -> UnOp.t -> UnOp.t + method visit_StrLess : 'c -> BinOp.t -> BinOp.t method visit_IntToNum : 'c -> UnOp.t -> UnOp.t method visit_NumToInt : 'c -> UnOp.t -> UnOp.t - method visit_StrLess : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t + method visit_StrLess : 'c -> BinOp.t -> BinOp.t method visit_StrNth : 'c -> BinOp.t -> BinOp.t method visit_String : 'c -> Literal.t -> string -> Literal.t method visit_StringType : 'c -> Type.t -> Type.t @@ -1749,12 +1573,10 @@ module Visitors : sig method visit_ToStringOp : 'c -> UnOp.t -> UnOp.t method visit_ToUint16Op : 'c -> UnOp.t -> UnOp.t method visit_ToUint32Op : 'c -> UnOp.t -> UnOp.t - method visit_True : 'c -> Formula.t -> Formula.t method visit_Type : 'c -> Literal.t -> Type.t -> Literal.t method visit_TypeOf : 'c -> UnOp.t -> UnOp.t method visit_TypeType : 'c -> Type.t -> Type.t - method visit_Types : 'c -> Asrt.t -> (Expr.t * Type.t) list -> Asrt.t - method visit_UNot : 'c -> UnOp.t -> UnOp.t + method visit_Types : 'c -> Asrt.atom -> (Expr.t * Type.t) list -> Asrt.atom method visit_UTCTime : 'c -> Constant.t -> Constant.t method visit_UnOp : 'c -> Expr.t -> UnOp.t -> Expr.t -> Expr.t method visit_Undefined : 'c -> Literal.t -> Literal.t @@ -1779,6 +1601,7 @@ module Visitors : sig method private visit_array : 'env 'a. ('env -> 'a -> 'a) -> 'env -> 'a array -> 'a array + method visit_assertion_atom : 'c -> Asrt.atom -> Asrt.atom method visit_assertion : 'c -> Asrt.t -> Asrt.t method visit_bindings : @@ -1794,7 +1617,6 @@ module Visitors : sig method visit_expr : 'c -> Expr.t -> Expr.t method visit_flag : 'c -> Flag.t -> Flag.t method private visit_float : 'env. 'env -> float -> float - method visit_formula : 'c -> Formula.t -> Formula.t method private visit_int : 'env. 'env -> int -> int method private visit_int32 : 'env. 'env -> int32 -> int32 method private visit_int64 : 'env. 'env -> int64 -> int64 @@ -1845,20 +1667,15 @@ module Visitors : sig 'b = < visit_'annot : 'c -> 'd -> 'f ; visit_'label : 'c -> 'g -> 'f ; visit_ALoc : 'c -> ALoc.t -> 'f - ; visit_And : 'c -> Formula.t -> Formula.t -> 'f - ; visit_Impl : 'c -> Formula.t -> Formula.t -> 'f + ; visit_And : 'c -> 'f + ; visit_Impl : 'c -> 'f ; visit_Apply : 'c -> string -> Expr.t -> 'g option -> 'f ; visit_ApplyLem : 'c -> string -> Expr.t list -> string list -> 'f ; visit_Arguments : 'c -> string -> 'f - ; visit_Assert : 'c -> Formula.t -> 'f + ; visit_Assert : 'c -> Expr.t -> 'f ; visit_Assignment : 'c -> string -> Expr.t -> 'f - ; visit_Assume : 'c -> Formula.t -> 'f + ; visit_Assume : 'c -> Expr.t -> 'f ; visit_AssumeType : 'c -> Expr.t -> Type.t -> 'f - ; visit_BAnd : 'c -> 'f - ; visit_BOr : 'c -> 'f - ; visit_BImpl : 'c -> 'f - ; visit_BSetMem : 'c -> 'f - ; visit_BSetSub : 'c -> 'f ; visit_BinOp : 'c -> Expr.t -> BinOp.t -> Expr.t -> 'f ; visit_BitwiseAnd : 'c -> 'f ; visit_BitwiseAndL : 'c -> 'f @@ -1872,7 +1689,7 @@ module Visitors : sig ; visit_BitwiseXorF : 'c -> 'f ; visit_Bool : 'c -> bool -> 'f ; visit_BooleanType : 'c -> 'f - ; visit_Branch : 'c -> Formula.t -> 'f + ; visit_Branch : 'c -> Expr.t -> 'f ; visit_Bug : 'c -> 'f ; visit_Call : 'c -> @@ -1892,24 +1709,21 @@ module Visitors : sig ; visit_EList : 'c -> Expr.t list -> 'f ; visit_ESet : 'c -> Expr.t list -> 'f ; visit_Exists : 'c -> (string * Type.t option) list -> Expr.t -> 'f - ; visit_EForall : 'c -> (string * Type.t option) list -> Expr.t -> 'f ; visit_Emp : 'c -> 'f ; visit_Empty : 'c -> 'f ; visit_EmptyType : 'c -> 'f ; visit_Epsilon : 'c -> 'f - ; visit_Eq : 'c -> Expr.t -> Expr.t -> 'f ; visit_Equal : 'c -> 'f ; visit_Error : 'c -> 'f ; visit_Fail : 'c -> string -> Expr.t list -> 'f - ; visit_False : 'c -> 'f ; visit_Fold : 'c -> string -> Expr.t list -> (string * (string * Expr.t) list) option -> 'f - ; visit_ForAll : 'c -> (string * Type.t option) list -> Formula.t -> 'f - ; visit_GA : 'c -> string -> Expr.t list -> Expr.t list -> 'f + ; visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> 'f + ; visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> 'f ; visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> 'f ; visit_GUnfold : 'c -> string -> 'f ; visit_Goto : 'c -> 'g -> 'f @@ -1924,16 +1738,11 @@ module Visitors : sig ; visit_LeftShift : 'c -> 'f ; visit_LeftShiftL : 'c -> 'f ; visit_LeftShiftF : 'c -> 'f - ; visit_FLess : 'c -> Expr.t -> Expr.t -> 'f - ; visit_FLessEq : 'c -> Expr.t -> Expr.t -> 'f - ; visit_ILess : 'c -> Expr.t -> Expr.t -> 'f - ; visit_ILessEq : 'c -> Expr.t -> Expr.t -> 'f - ; visit_IsInt : 'c -> Expr.t -> 'f + ; visit_IsInt : 'c -> 'f ; visit_ILessThan : 'c -> 'f ; visit_ILessThanEqual : 'c -> 'f ; visit_FLessThan : 'c -> 'f ; visit_FLessThanEqual : 'c -> 'f - ; visit_SLessThan : 'c -> 'f ; visit_ListType : 'c -> 'f ; visit_Lit : 'c -> Literal.t -> 'f ; visit_Loc : 'c -> string -> 'f @@ -1974,7 +1783,7 @@ module Visitors : sig ; visit_NoneType : 'c -> 'f ; visit_Nono : 'c -> 'f ; visit_Normal : 'c -> 'f - ; visit_Not : 'c -> Formula.t -> 'f + ; visit_Not : 'c -> 'f ; visit_Null : 'c -> 'f ; visit_NullType : 'c -> 'f ; visit_Int : 'c -> Z.t -> 'f @@ -1982,14 +1791,14 @@ module Visitors : sig ; visit_IntType : 'c -> 'f ; visit_NumberType : 'c -> 'f ; visit_ObjectType : 'c -> 'f - ; visit_Or : 'c -> Formula.t -> Formula.t -> 'f + ; visit_Or : 'c -> 'f ; visit_PVar : 'c -> string -> 'f ; visit_PhiAssignment : 'c -> (string * Expr.t list) list -> 'f ; visit_Pi : 'c -> 'f ; visit_IPlus : 'c -> 'f ; visit_FPlus : 'c -> 'f ; visit_Pred : 'c -> string -> Expr.t list -> 'f - ; visit_Pure : 'c -> Formula.t -> 'f + ; visit_Pure : 'c -> Expr.t -> 'f ; visit_Random : 'c -> 'f ; visit_ReturnError : 'c -> 'f ; visit_ReturnNormal : 'c -> 'f @@ -1997,8 +1806,8 @@ module Visitors : sig ; visit_SepAssert : 'c -> Asrt.t -> string list -> 'f ; visit_SetDiff : 'c -> 'f ; visit_SetInter : 'c -> 'f - ; visit_SetMem : 'c -> Expr.t -> Expr.t -> 'f - ; visit_SetSub : 'c -> Expr.t -> Expr.t -> 'f + ; visit_SetMem : 'c -> 'f + ; visit_SetSub : 'c -> 'f ; visit_SetToList : 'c -> 'f ; visit_SetType : 'c -> 'f ; visit_SetUnion : 'c -> 'f @@ -2007,12 +1816,12 @@ module Visitors : sig ; visit_SignedRightShiftF : 'c -> 'f ; visit_Skip : 'c -> 'f ; visit_FreshSVar : 'c -> string -> 'f - ; visit_Star : 'c -> Asrt.t -> Asrt.t -> 'f ; visit_StrCat : 'c -> 'f ; visit_StrLen : 'c -> 'f + ; visit_StrLess : 'c -> 'f ; visit_IntToNum : 'c -> 'f ; visit_NumToInt : 'c -> 'f - ; visit_StrLess : 'c -> Expr.t -> Expr.t -> 'f + ; visit_StrLess : 'c -> 'f ; visit_StrNth : 'c -> 'f ; visit_String : 'c -> string -> 'f ; visit_StringType : 'c -> 'f @@ -2025,12 +1834,10 @@ module Visitors : sig ; visit_ToStringOp : 'c -> 'f ; visit_ToUint16Op : 'c -> 'f ; visit_ToUint32Op : 'c -> 'f - ; visit_True : 'c -> 'f ; visit_Type : 'c -> Type.t -> 'f ; visit_TypeOf : 'c -> 'f ; visit_TypeType : 'c -> 'f ; visit_Types : 'c -> (Expr.t * Type.t) list -> 'f - ; visit_UNot : 'c -> 'f ; visit_UTCTime : 'c -> 'f ; visit_UnOp : 'c -> UnOp.t -> Expr.t -> 'f ; visit_IUnaryMinus : 'c -> 'f @@ -2049,6 +1856,7 @@ module Visitors : sig ; visit_UnsignedRightShift : 'c -> 'f ; visit_UnsignedRightShiftL : 'c -> 'f ; visit_UnsignedRightShiftF : 'c -> 'f + ; visit_assertion_atom : 'c -> Asrt.atom -> 'f ; visit_assertion : 'c -> Asrt.t -> 'f ; visit_bindings : 'c -> string * (string * Expr.t) list -> 'f ; visit_binop : 'c -> BinOp.t -> 'f @@ -2057,7 +1865,6 @@ module Visitors : sig ; visit_constant : 'c -> Constant.t -> 'f ; visit_expr : 'c -> Expr.t -> 'f ; visit_flag : 'c -> Flag.t -> 'f - ; visit_formula : 'c -> Formula.t -> 'f ; visit_lcmd : 'c -> LCmd.t -> 'f ; visit_lemma : 'c -> Lemma.t -> 'f ; visit_lemma_spec : 'c -> Lemma.spec -> 'f @@ -2077,20 +1884,15 @@ module Visitors : sig method visit_'annot : 'c -> 'd -> 'f method visit_'label : 'c -> 'g -> 'f method visit_ALoc : 'c -> ALoc.t -> 'f - method visit_And : 'c -> Formula.t -> Formula.t -> 'f - method visit_Impl : 'c -> Formula.t -> Formula.t -> 'f + method visit_And : 'c -> 'f + method visit_Impl : 'c -> 'f method visit_Apply : 'c -> string -> Expr.t -> 'g option -> 'f method visit_ApplyLem : 'c -> string -> Expr.t list -> string list -> 'f method visit_Arguments : 'c -> string -> 'f - method visit_Assert : 'c -> Formula.t -> 'f + method visit_Assert : 'c -> Expr.t -> 'f method visit_Assignment : 'c -> string -> Expr.t -> 'f - method visit_Assume : 'c -> Formula.t -> 'f + method visit_Assume : 'c -> Expr.t -> 'f method visit_AssumeType : 'c -> Expr.t -> Type.t -> 'f - method visit_BAnd : 'c -> 'f - method visit_BOr : 'c -> 'f - method visit_BImpl : 'c -> 'f - method visit_BSetMem : 'c -> 'f - method visit_BSetSub : 'c -> 'f method visit_BinOp : 'c -> Expr.t -> BinOp.t -> Expr.t -> 'f method visit_BitwiseAnd : 'c -> 'f method visit_BitwiseAndL : 'c -> 'f @@ -2104,7 +1906,7 @@ module Visitors : sig method visit_BitwiseXorF : 'c -> 'f method visit_Bool : 'c -> bool -> 'f method visit_BooleanType : 'c -> 'f - method visit_Branch : 'c -> Formula.t -> 'f + method visit_Branch : 'c -> Expr.t -> 'f method visit_Bug : 'c -> 'f method visit_Call : @@ -2128,16 +1930,13 @@ module Visitors : sig method visit_EList : 'c -> Expr.t list -> 'f method visit_ESet : 'c -> Expr.t list -> 'f method visit_Exists : 'c -> (string * Type.t option) list -> Expr.t -> 'f - method visit_EForall : 'c -> (string * Type.t option) list -> Expr.t -> 'f method visit_Emp : 'c -> 'f method visit_Empty : 'c -> 'f method visit_EmptyType : 'c -> 'f method visit_Epsilon : 'c -> 'f - method visit_Eq : 'c -> Expr.t -> Expr.t -> 'f method visit_Equal : 'c -> 'f method visit_Error : 'c -> 'f method visit_Fail : 'c -> string -> Expr.t list -> 'f - method visit_False : 'c -> 'f method visit_Fold : 'c -> @@ -2146,13 +1945,14 @@ module Visitors : sig (string * (string * Expr.t) list) option -> 'f - method visit_ForAll : 'c -> (string * Type.t option) list -> Formula.t -> 'f - method visit_GA : 'c -> string -> Expr.t list -> Expr.t list -> 'f + method visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> 'f + method visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> 'f method visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> 'f method visit_GUnfold : 'c -> string -> 'f method visit_Goto : 'c -> 'g -> 'f method visit_GuardedGoto : 'c -> Expr.t -> 'g -> 'g -> 'f method visit_If : 'c -> Expr.t -> LCmd.t list -> LCmd.t list -> 'f + method visit_IsInt : 'c -> 'f method visit_Invariant : 'c -> Asrt.t -> string list -> 'f method visit_Consume : 'c -> Asrt.t -> string list -> 'f method visit_Produce : 'c -> Asrt.t -> 'f @@ -2162,16 +1962,10 @@ module Visitors : sig method visit_LeftShift : 'c -> 'f method visit_LeftShiftL : 'c -> 'f method visit_LeftShiftF : 'c -> 'f - method visit_FLess : 'c -> Expr.t -> Expr.t -> 'f - method visit_FLessEq : 'c -> Expr.t -> Expr.t -> 'f - method visit_ILess : 'c -> Expr.t -> Expr.t -> 'f - method visit_ILessEq : 'c -> Expr.t -> Expr.t -> 'f - method visit_IsInt : 'c -> Expr.t -> 'f method visit_ILessThan : 'c -> 'f method visit_ILessThanEqual : 'c -> 'f method visit_FLessThan : 'c -> 'f method visit_FLessThanEqual : 'c -> 'f - method visit_SLessThan : 'c -> 'f method visit_ListType : 'c -> 'f method visit_Lit : 'c -> Literal.t -> 'f method visit_Loc : 'c -> string -> 'f @@ -2212,7 +2006,7 @@ module Visitors : sig method visit_NoneType : 'c -> 'f method visit_Nono : 'c -> 'f method visit_Normal : 'c -> 'f - method visit_Not : 'c -> Formula.t -> 'f + method visit_Not : 'c -> 'f method visit_Null : 'c -> 'f method visit_NullType : 'c -> 'f method visit_Int : 'c -> Z.t -> 'f @@ -2220,14 +2014,14 @@ module Visitors : sig method visit_IntType : 'c -> 'f method visit_NumberType : 'c -> 'f method visit_ObjectType : 'c -> 'f - method visit_Or : 'c -> Formula.t -> Formula.t -> 'f + method visit_Or : 'c -> 'f method visit_PVar : 'c -> string -> 'f method visit_PhiAssignment : 'c -> (string * Expr.t list) list -> 'f method visit_Pi : 'c -> 'f method visit_IPlus : 'c -> 'f method visit_FPlus : 'c -> 'f method visit_Pred : 'c -> string -> Expr.t list -> 'f - method visit_Pure : 'c -> Formula.t -> 'f + method visit_Pure : 'c -> Expr.t -> 'f method visit_Random : 'c -> 'f method visit_ReturnError : 'c -> 'f method visit_ReturnNormal : 'c -> 'f @@ -2235,8 +2029,8 @@ module Visitors : sig method visit_SepAssert : 'c -> Asrt.t -> string list -> 'f method visit_SetDiff : 'c -> 'f method visit_SetInter : 'c -> 'f - method visit_SetMem : 'c -> Expr.t -> Expr.t -> 'f - method visit_SetSub : 'c -> Expr.t -> Expr.t -> 'f + method visit_SetMem : 'c -> 'f + method visit_SetSub : 'c -> 'f method visit_SetToList : 'c -> 'f method visit_SetType : 'c -> 'f method visit_SetUnion : 'c -> 'f @@ -2245,12 +2039,12 @@ module Visitors : sig method visit_SignedRightShiftF : 'c -> 'f method visit_Skip : 'c -> 'f method visit_FreshSVar : 'c -> string -> 'f - method visit_Star : 'c -> Asrt.t -> Asrt.t -> 'f method visit_StrCat : 'c -> 'f method visit_StrLen : 'c -> 'f + method visit_StrLess : 'c -> 'f method visit_IntToNum : 'c -> 'f method visit_NumToInt : 'c -> 'f - method visit_StrLess : 'c -> Expr.t -> Expr.t -> 'f + method visit_StrLess : 'c -> 'f method visit_StrNth : 'c -> 'f method visit_String : 'c -> string -> 'f method visit_StringType : 'c -> 'f @@ -2263,12 +2057,10 @@ module Visitors : sig method visit_ToStringOp : 'c -> 'f method visit_ToUint16Op : 'c -> 'f method visit_ToUint32Op : 'c -> 'f - method visit_True : 'c -> 'f method visit_Type : 'c -> Type.t -> 'f method visit_TypeOf : 'c -> 'f method visit_TypeType : 'c -> 'f method visit_Types : 'c -> (Expr.t * Type.t) list -> 'f - method visit_UNot : 'c -> 'f method visit_UTCTime : 'c -> 'f method visit_UnOp : 'c -> UnOp.t -> Expr.t -> 'f method visit_IUnaryMinus : 'c -> 'f @@ -2285,6 +2077,7 @@ module Visitors : sig method visit_UnsignedRightShift : 'c -> 'f method visit_UnsignedRightShiftL : 'c -> 'f method visit_UnsignedRightShiftF : 'c -> 'f + method visit_assertion_atom : 'c -> Asrt.atom -> 'f method visit_assertion : 'c -> Asrt.t -> 'f method visit_bindings : 'c -> string * (string * Expr.t) list -> 'f method visit_binop : 'c -> BinOp.t -> 'f @@ -2293,7 +2086,6 @@ module Visitors : sig method visit_constant : 'c -> Constant.t -> 'f method visit_expr : 'c -> Expr.t -> 'f method visit_flag : 'c -> Flag.t -> 'f - method visit_formula : 'c -> Formula.t -> 'f method visit_lcmd : 'c -> LCmd.t -> 'f method visit_lemma : 'c -> Lemma.t -> 'f method visit_lemma_spec : 'c -> Lemma.spec -> 'f @@ -2315,20 +2107,15 @@ module Visitors : sig 'b = < visit_'annot : 'c -> 'd -> unit ; visit_'label : 'c -> 'f -> unit ; visit_ALoc : 'c -> string -> unit - ; visit_And : 'c -> Formula.t -> Formula.t -> unit - ; visit_Impl : 'c -> Formula.t -> Formula.t -> unit + ; visit_And : 'c -> unit + ; visit_Impl : 'c -> unit ; visit_Apply : 'c -> string -> Expr.t -> 'f option -> unit ; visit_ApplyLem : 'c -> string -> Expr.t list -> string list -> unit ; visit_Arguments : 'c -> string -> unit - ; visit_Assert : 'c -> Formula.t -> unit + ; visit_Assert : 'c -> Expr.t -> unit ; visit_Assignment : 'c -> string -> Expr.t -> unit - ; visit_Assume : 'c -> Formula.t -> unit + ; visit_Assume : 'c -> Expr.t -> unit ; visit_AssumeType : 'c -> Expr.t -> Type.t -> unit - ; visit_BAnd : 'c -> unit - ; visit_BOr : 'c -> unit - ; visit_BImpl : 'c -> unit - ; visit_BSetMem : 'c -> unit - ; visit_BSetSub : 'c -> unit ; visit_BinOp : 'c -> Expr.t -> BinOp.t -> Expr.t -> unit ; visit_BitwiseAnd : 'c -> unit ; visit_BitwiseAndL : 'c -> unit @@ -2342,7 +2129,7 @@ module Visitors : sig ; visit_BitwiseXorF : 'c -> unit ; visit_Bool : 'c -> bool -> unit ; visit_BooleanType : 'c -> unit - ; visit_Branch : 'c -> Formula.t -> unit + ; visit_Branch : 'c -> Expr.t -> unit ; visit_Bug : 'c -> unit ; visit_Call : 'c -> @@ -2360,12 +2147,10 @@ module Visitors : sig ; visit_EList : 'c -> Expr.t list -> unit ; visit_ESet : 'c -> Expr.t list -> unit ; visit_Exists : 'c -> (string * Type.t option) list -> Expr.t -> unit - ; visit_EForall : 'c -> (string * Type.t option) list -> Expr.t -> unit ; visit_Emp : 'c -> unit ; visit_Empty : 'c -> unit ; visit_EmptyType : 'c -> unit ; visit_Epsilon : 'c -> unit - ; visit_Eq : 'c -> Expr.t -> Expr.t -> unit ; visit_Equal : 'c -> unit ; visit_Error : 'c -> unit ; visit_FDiv : 'c -> unit @@ -2377,16 +2162,14 @@ module Visitors : sig ; visit_FTimes : 'c -> unit ; visit_FUnaryMinus : 'c -> unit ; visit_Fail : 'c -> string -> Expr.t list -> unit - ; visit_False : 'c -> unit ; visit_Fold : 'c -> string -> Expr.t list -> (string * (string * Expr.t) list) option -> unit - ; visit_ForAll : - 'c -> (string * Type.t option) list -> Formula.t -> unit - ; visit_GA : 'c -> string -> Expr.t list -> Expr.t list -> unit + ; visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> unit + ; visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> unit ; visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> unit ; visit_GUnfold : 'c -> string -> unit @@ -2412,11 +2195,7 @@ module Visitors : sig ; visit_LeftShift : 'c -> unit ; visit_LeftShiftL : 'c -> unit ; visit_LeftShiftF : 'c -> unit - ; visit_FLess : 'c -> Expr.t -> Expr.t -> unit - ; visit_FLessEq : 'c -> Expr.t -> Expr.t -> unit - ; visit_ILess : 'c -> Expr.t -> Expr.t -> unit - ; visit_ILessEq : 'c -> Expr.t -> Expr.t -> unit - ; visit_IsInt : 'c -> Expr.t -> unit + ; visit_IsInt : 'c -> unit ; visit_ListType : 'c -> unit ; visit_Lit : 'c -> Literal.t -> unit ; visit_Loc : 'c -> string -> unit @@ -2453,28 +2232,27 @@ module Visitors : sig ; visit_NoneType : 'c -> unit ; visit_Nono : 'c -> unit ; visit_Normal : 'c -> unit - ; visit_Not : 'c -> Formula.t -> unit + ; visit_Not : 'c -> unit ; visit_Null : 'c -> unit ; visit_NullType : 'c -> unit ; visit_Num : 'c -> float -> unit ; visit_NumberType : 'c -> unit ; visit_ObjectType : 'c -> unit - ; visit_Or : 'c -> Formula.t -> Formula.t -> unit + ; visit_Or : 'c -> unit ; visit_PVar : 'c -> string -> unit ; visit_PhiAssignment : 'c -> (string * Expr.t list) list -> unit ; visit_Pi : 'c -> unit ; visit_Pred : 'c -> string -> Expr.t list -> unit - ; visit_Pure : 'c -> Formula.t -> unit + ; visit_Pure : 'c -> Expr.t -> unit ; visit_Random : 'c -> unit ; visit_ReturnError : 'c -> unit ; visit_ReturnNormal : 'c -> unit ; visit_SL : 'c -> SLCmd.t -> unit - ; visit_SLessThan : 'c -> unit ; visit_SepAssert : 'c -> Asrt.t -> string list -> unit ; visit_SetDiff : 'c -> unit ; visit_SetInter : 'c -> unit - ; visit_SetMem : 'c -> Expr.t -> Expr.t -> unit - ; visit_SetSub : 'c -> Expr.t -> Expr.t -> unit + ; visit_SetMem : 'c -> unit + ; visit_SetSub : 'c -> unit ; visit_SetToList : 'c -> unit ; visit_SetType : 'c -> unit ; visit_SetUnion : 'c -> unit @@ -2483,12 +2261,11 @@ module Visitors : sig ; visit_SignedRightShiftF : 'c -> unit ; visit_Skip : 'c -> unit ; visit_FreshSVar : 'c -> string -> unit - ; visit_Star : 'c -> Asrt.t -> Asrt.t -> unit ; visit_StrCat : 'c -> unit ; visit_StrLen : 'c -> unit + ; visit_StrLess : 'c -> unit ; visit_IntToNum : 'c -> unit ; visit_NumToInt : 'c -> unit - ; visit_StrLess : 'c -> Expr.t -> Expr.t -> unit ; visit_StrNth : 'c -> unit ; visit_String : 'c -> string -> unit ; visit_StringType : 'c -> unit @@ -2499,12 +2276,10 @@ module Visitors : sig ; visit_ToStringOp : 'c -> unit ; visit_ToUint16Op : 'c -> unit ; visit_ToUint32Op : 'c -> unit - ; visit_True : 'c -> unit ; visit_Type : 'c -> Type.t -> unit ; visit_TypeOf : 'c -> unit ; visit_TypeType : 'c -> unit ; visit_Types : 'c -> (Expr.t * Type.t) list -> unit - ; visit_UNot : 'c -> unit ; visit_UTCTime : 'c -> unit ; visit_UnOp : 'c -> UnOp.t -> Expr.t -> unit ; visit_Undefined : 'c -> unit @@ -2521,6 +2296,7 @@ module Visitors : sig ; visit_UnsignedRightShift : 'c -> unit ; visit_UnsignedRightShiftL : 'c -> unit ; visit_UnsignedRightShiftF : 'c -> unit + ; visit_assertion_atom : 'c -> Asrt.atom -> unit ; visit_assertion : 'c -> Asrt.t -> unit ; visit_bindings : 'c -> string * (string * Expr.t) list -> unit ; visit_binop : 'c -> BinOp.t -> unit @@ -2529,7 +2305,6 @@ module Visitors : sig ; visit_constant : 'c -> Constant.t -> unit ; visit_expr : 'c -> Expr.t -> unit ; visit_flag : 'c -> Flag.t -> unit - ; visit_formula : 'c -> Formula.t -> unit ; visit_lcmd : 'c -> LCmd.t -> unit ; visit_lemma : 'c -> Lemma.t -> unit ; visit_lemma_spec : 'c -> Lemma.spec -> unit @@ -2548,20 +2323,15 @@ module Visitors : sig method visit_'annot : 'c -> 'd -> unit method visit_'label : 'c -> 'f -> unit method visit_ALoc : 'c -> string -> unit - method visit_And : 'c -> Formula.t -> Formula.t -> unit - method visit_Impl : 'c -> Formula.t -> Formula.t -> unit + method visit_And : 'c -> unit + method visit_Impl : 'c -> unit method visit_Apply : 'c -> string -> Expr.t -> 'f option -> unit method visit_ApplyLem : 'c -> string -> Expr.t list -> string list -> unit method visit_Arguments : 'c -> string -> unit - method visit_Assert : 'c -> Formula.t -> unit + method visit_Assert : 'c -> Expr.t -> unit method visit_Assignment : 'c -> string -> Expr.t -> unit - method visit_Assume : 'c -> Formula.t -> unit + method visit_Assume : 'c -> Expr.t -> unit method visit_AssumeType : 'c -> Expr.t -> Type.t -> unit - method visit_BAnd : 'c -> unit - method visit_BOr : 'c -> unit - method visit_BImpl : 'c -> unit - method visit_BSetMem : 'c -> unit - method visit_BSetSub : 'c -> unit method visit_BinOp : 'c -> Expr.t -> BinOp.t -> Expr.t -> unit method visit_BitwiseAnd : 'c -> unit method visit_BitwiseAndL : 'c -> unit @@ -2575,7 +2345,7 @@ module Visitors : sig method visit_BitwiseXorF : 'c -> unit method visit_Bool : 'c -> bool -> unit method visit_BooleanType : 'c -> unit - method visit_Branch : 'c -> Formula.t -> unit + method visit_Branch : 'c -> Expr.t -> unit method visit_Bug : 'c -> unit method visit_Call : @@ -2597,12 +2367,10 @@ module Visitors : sig method visit_EList : 'c -> Expr.t list -> unit method visit_ESet : 'c -> Expr.t list -> unit method visit_Exists : 'c -> (string * Type.t option) list -> Expr.t -> unit - method visit_EForall : 'c -> (string * Type.t option) list -> Expr.t -> unit method visit_Emp : 'c -> unit method visit_Empty : 'c -> unit method visit_EmptyType : 'c -> unit method visit_Epsilon : 'c -> unit - method visit_Eq : 'c -> Expr.t -> Expr.t -> unit method visit_Equal : 'c -> unit method visit_Error : 'c -> unit method visit_FDiv : 'c -> unit @@ -2614,7 +2382,6 @@ module Visitors : sig method visit_FTimes : 'c -> unit method visit_FUnaryMinus : 'c -> unit method visit_Fail : 'c -> string -> Expr.t list -> unit - method visit_False : 'c -> unit method visit_Fold : 'c -> @@ -2623,10 +2390,8 @@ module Visitors : sig (string * (string * Expr.t) list) option -> unit - method visit_ForAll : - 'c -> (string * Type.t option) list -> Formula.t -> unit - - method visit_GA : 'c -> string -> Expr.t list -> Expr.t list -> unit + method visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> unit + method visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> unit method visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> unit @@ -2654,11 +2419,7 @@ module Visitors : sig method visit_LeftShift : 'c -> unit method visit_LeftShiftL : 'c -> unit method visit_LeftShiftF : 'c -> unit - method visit_FLess : 'c -> Expr.t -> Expr.t -> unit - method visit_FLessEq : 'c -> Expr.t -> Expr.t -> unit - method visit_ILess : 'c -> Expr.t -> Expr.t -> unit - method visit_ILessEq : 'c -> Expr.t -> Expr.t -> unit - method visit_IsInt : 'c -> Expr.t -> unit + method visit_IsInt : 'c -> unit method visit_ListType : 'c -> unit method visit_Lit : 'c -> Literal.t -> unit method visit_Loc : 'c -> string -> unit @@ -2695,28 +2456,27 @@ module Visitors : sig method visit_NoneType : 'c -> unit method visit_Nono : 'c -> unit method visit_Normal : 'c -> unit - method visit_Not : 'c -> Formula.t -> unit + method visit_Not : 'c -> unit method visit_Null : 'c -> unit method visit_NullType : 'c -> unit method visit_Num : 'c -> float -> unit method visit_NumberType : 'c -> unit method visit_ObjectType : 'c -> unit - method visit_Or : 'c -> Formula.t -> Formula.t -> unit + method visit_Or : 'c -> unit method visit_PVar : 'c -> string -> unit method visit_PhiAssignment : 'c -> (string * Expr.t list) list -> unit method visit_Pi : 'c -> unit method visit_Pred : 'c -> string -> Expr.t list -> unit - method visit_Pure : 'c -> Formula.t -> unit + method visit_Pure : 'c -> Expr.t -> unit method visit_Random : 'c -> unit method visit_ReturnError : 'c -> unit method visit_ReturnNormal : 'c -> unit method visit_SL : 'c -> SLCmd.t -> unit - method visit_SLessThan : 'c -> unit method visit_SepAssert : 'c -> Asrt.t -> string list -> unit method visit_SetDiff : 'c -> unit method visit_SetInter : 'c -> unit - method visit_SetMem : 'c -> Expr.t -> Expr.t -> unit - method visit_SetSub : 'c -> Expr.t -> Expr.t -> unit + method visit_SetMem : 'c -> unit + method visit_SetSub : 'c -> unit method visit_SetToList : 'c -> unit method visit_SetType : 'c -> unit method visit_SetUnion : 'c -> unit @@ -2725,12 +2485,11 @@ module Visitors : sig method visit_SignedRightShiftF : 'c -> unit method visit_Skip : 'c -> unit method visit_FreshSVar : 'c -> string -> unit - method visit_Star : 'c -> Asrt.t -> Asrt.t -> unit method visit_StrCat : 'c -> unit method visit_StrLen : 'c -> unit + method visit_StrLess : 'c -> unit method visit_IntToNum : 'c -> unit method visit_NumToInt : 'c -> unit - method visit_StrLess : 'c -> Expr.t -> Expr.t -> unit method visit_StrNth : 'c -> unit method visit_String : 'c -> string -> unit method visit_StringType : 'c -> unit @@ -2741,12 +2500,10 @@ module Visitors : sig method visit_ToStringOp : 'c -> unit method visit_ToUint16Op : 'c -> unit method visit_ToUint32Op : 'c -> unit - method visit_True : 'c -> unit method visit_Type : 'c -> Type.t -> unit method visit_TypeOf : 'c -> unit method visit_TypeType : 'c -> unit method visit_Types : 'c -> (Expr.t * Type.t) list -> unit - method visit_UNot : 'c -> unit method visit_UTCTime : 'c -> unit method visit_UnOp : 'c -> UnOp.t -> Expr.t -> unit method visit_Undefined : 'c -> unit @@ -2770,6 +2527,7 @@ module Visitors : sig method private visit_array : 'env 'a. ('env -> 'a -> unit) -> 'env -> 'a array -> unit + method visit_assertion_atom : 'c -> Asrt.atom -> unit method visit_assertion : 'c -> Asrt.t -> unit method visit_bindings : 'c -> string * (string * Expr.t) list -> unit method visit_binop : 'c -> BinOp.t -> unit @@ -2782,7 +2540,6 @@ module Visitors : sig method visit_expr : 'c -> Expr.t -> unit method visit_flag : 'c -> Flag.t -> unit method private visit_float : 'env. 'env -> float -> unit - method visit_formula : 'c -> Formula.t -> unit method private visit_int : 'env. 'env -> int -> unit method private visit_int32 : 'env. 'env -> int32 -> unit method private visit_int64 : 'env. 'env -> int64 -> unit diff --git a/GillianCore/GIL_Syntax/LCmd.ml b/GillianCore/GIL_Syntax/LCmd.ml index 71242700..fd9bff41 100644 --- a/GillianCore/GIL_Syntax/LCmd.ml +++ b/GillianCore/GIL_Syntax/LCmd.ml @@ -4,40 +4,26 @@ module SS = Containers.SS type t = TypeDef__.lcmd = | If of Expr.t * t list * t list (** If-then-else *) - | Branch of Formula.t (** branching on a FO formual *) + | Branch of Expr.t (** branching on a FO formual *) | Macro of string * Expr.t list (** Macro *) - | Assert of Formula.t (** Assert *) - | Assume of Formula.t (** Assume *) + | Assert of Expr.t (** Assert *) + | Assume of Expr.t (** Assume *) | AssumeType of Expr.t * Type.t (** Assume Type *) | FreshSVar of string (** x := fresh_svar() *) | SL of SLCmd.t [@@deriving yojson] -let rec map - (f_l : (t -> t) option) - (f_e : (Expr.t -> Expr.t) option) - (f_p : (Formula.t -> Formula.t) option) - (f_sl : (SLCmd.t -> SLCmd.t) option) - (lcmd : t) : t = - (* Functions to map over formulas, expressions, and sl-commands *) - let f = map f_l f_e f_p f_sl in - let map_e = Option.value ~default:(fun x -> x) f_e in - let map_p = Option.value ~default:(fun x -> x) f_p in - let map_sl = Option.value ~default:(fun x -> x) f_sl in - - (* Apply the given function to the logical command *) - let mapped_lcmd = Option.fold ~some:(fun f -> f lcmd) ~none:lcmd f_l in - - (* Map over the elements of the command *) - match mapped_lcmd with - | Branch a -> Branch (map_p a) - | If (e, l1, l2) -> If (map_e e, List.map f l1, List.map f l2) - | Macro (s, l) -> Macro (s, List.map map_e l) - | Assume a -> Assume (map_p a) - | Assert a -> Assert (map_p a) - | AssumeType (e, t) -> AssumeType (map_e e, t) - | FreshSVar _ -> mapped_lcmd - | SL sl_cmd -> SL (map_sl sl_cmd) +let rec map (f_e : Expr.t -> Expr.t) (f_sl : SLCmd.t -> SLCmd.t) (lcmd : t) = + let f = map f_e f_sl in + match lcmd with + | Branch a -> Branch (f_e a) + | If (e, l1, l2) -> If (f_e e, List.map f l1, List.map f l2) + | Macro (s, l) -> Macro (s, List.map f_e l) + | Assume a -> Assume (f_e a) + | Assert a -> Assert (f_e a) + | AssumeType (e, t) -> AssumeType (f_e e, t) + | FreshSVar _ as lcmd -> lcmd + | SL sl_cmd -> SL (f_sl sl_cmd) let fold = List.fold_left SS.union SS.empty @@ -48,8 +34,7 @@ let rec pvars (lcmd : t) : SS.t = | If (e, lthen, lelse) -> SS.union (Expr.pvars e) (SS.union (pvars_lcmds lthen) (pvars_lcmds lelse)) | Macro (_, es) -> pvars_es es - | Branch pf | Assert pf | Assume pf -> Formula.pvars pf - | AssumeType (e, _) -> Expr.pvars e + | Branch e | Assert e | Assume e | AssumeType (e, _) -> Expr.pvars e | FreshSVar name -> SS.singleton name | SL slcmd -> SLCmd.pvars slcmd @@ -60,8 +45,7 @@ let rec lvars (lcmd : t) : SS.t = | If (e, lthen, lelse) -> SS.union (Expr.lvars e) (SS.union (lvars_lcmds lthen) (lvars_lcmds lelse)) | Macro (_, es) -> lvars_es es - | Branch pf | Assert pf | Assume pf -> Formula.lvars pf - | AssumeType (e, _) -> Expr.lvars e + | Branch e | Assert e | Assume e | AssumeType (e, _) -> Expr.lvars e | SL slcmd -> SLCmd.lvars slcmd | FreshSVar _ -> SS.empty @@ -72,8 +56,7 @@ let rec locs (lcmd : t) : SS.t = | If (e, lthen, lelse) -> SS.union (Expr.locs e) (SS.union (locs_lcmds lthen) (locs_lcmds lelse)) | Macro (_, es) -> locs_es es - | Branch pf | Assert pf | Assume pf -> Formula.locs pf - | AssumeType (e, _) -> Expr.locs e + | Branch e | Assert e | Assume e | AssumeType (e, _) -> Expr.locs e | SL slcmd -> SLCmd.locs slcmd | FreshSVar _ -> SS.empty @@ -88,10 +71,10 @@ let rec pp fmt lcmd = else Fmt.pf fmt "if (@[%a@]) @[then {@\n%a@]@\n}" Expr.pp le pp_list then_lcmds - | Branch fo -> Fmt.pf fmt "branch (%a)" Formula.pp fo + | Branch fo -> Fmt.pf fmt "branch (%a)" Expr.pp fo | Macro (name, lparams) -> Fmt.pf fmt "%s(@[%a@])" name pp_params lparams - | Assert a -> Fmt.pf fmt "assert (@[%a@])" Formula.pp a - | Assume a -> Fmt.pf fmt "assume (@[%a@])" Formula.pp a + | Assert a -> Fmt.pf fmt "assert (@[%a@])" Expr.pp a + | Assume a -> Fmt.pf fmt "assume (@[%a@])" Expr.pp a | AssumeType (e, t) -> Fmt.pf fmt "assume_type (%a, %s)" Expr.pp e (Type.str t) | SL sl_cmd -> SLCmd.pp fmt sl_cmd diff --git a/GillianCore/GIL_Syntax/Lemma.ml b/GillianCore/GIL_Syntax/Lemma.ml index ad40a132..5d88ba38 100644 --- a/GillianCore/GIL_Syntax/Lemma.ml +++ b/GillianCore/GIL_Syntax/Lemma.ml @@ -48,43 +48,11 @@ let pp fmt lemma = lemma.lemma_specs (Fmt.option pp_proof) lemma.lemma_proof let parameter_types (preds : (string, Pred.t) Hashtbl.t) (lemma : t) : t = - (* copied from spec - needs refactoring *) - let pt_asrt (a : Asrt.t) : Asrt.t = - let f_a_after a : Asrt.t = - match (a : Asrt.t) with - | Pred (name, les) -> - let pred = - try Hashtbl.find preds name - with _ -> - raise - (Failure - ("DEATH. parameter_types: predicate " ^ name - ^ " does not exist.")) - in - (* Printf.printf "Pred: %s\n\tParams1: %s\n\tParams2: %s\n" name - (String.concat ", " (let x, _ = List.split pred.params in x)) (String.concat ", " (List.map (Fmt.to_to_string Expr.pp) les)); *) - let ac_types = - List.fold_left - (fun ac_types ((_, t_x), le) -> - match t_x with - | None -> ac_types - | Some t_x -> (le, t_x) :: ac_types) - [] - (try List.combine pred.pred_params les - with Invalid_argument _ -> - Fmt.failwith - "Invalid number of arguments: %a.\nInside of lemma: %s" - Asrt.pp a lemma.lemma_name) - in - Star (Types ac_types, a) - | _ -> a - in - Asrt.map None (Some f_a_after) None None a - in + let map_asrts = Pred.extend_asrt_pred_types preds in let pt_spec { lemma_hyp; lemma_concs; lemma_spec_variant } = { - lemma_hyp = pt_asrt lemma_hyp; - lemma_concs = List.map pt_asrt lemma_concs; + lemma_hyp = map_asrts lemma_hyp; + lemma_concs = List.map map_asrts lemma_concs; lemma_spec_variant; } in @@ -96,11 +64,8 @@ let add_param_bindings (lemma : t) = let lvar_params = List.map (fun x -> "#" ^ x) params in let param_eqs = List.map2 - (fun pv lv -> Asrt.Pure (Eq (PVar pv, LVar lv))) + (fun pv lv -> Asrt.Pure (Expr.BinOp (PVar pv, Equal, LVar lv))) params lvar_params in - let param_eqs = Asrt.star param_eqs in - let add_to_spec spec = - { spec with lemma_hyp = Asrt.Star (param_eqs, spec.lemma_hyp) } - in + let add_to_spec spec = { spec with lemma_hyp = param_eqs @ spec.lemma_hyp } in { lemma with lemma_specs = List.map add_to_spec lemma.lemma_specs } diff --git a/GillianCore/GIL_Syntax/Literal.ml b/GillianCore/GIL_Syntax/Literal.ml index b3a3bfde..84b9a987 100644 --- a/GillianCore/GIL_Syntax/Literal.ml +++ b/GillianCore/GIL_Syntax/Literal.ml @@ -40,7 +40,7 @@ let rec pp fmt x = | Empty -> Fmt.string fmt "empty" | Nono -> Fmt.string fmt "none" | Constant c -> Fmt.string fmt (Constant.str c) - | Bool b -> if b then Fmt.string fmt "true" else Fmt.string fmt "false" + | Bool b -> Fmt.pf fmt "%b" b | Int i -> Fmt.pf fmt "%ai" Z.pp_print i | Num n -> Fmt.pf fmt "%F" n | String x -> Fmt.pf fmt "\"%s\"" x diff --git a/GillianCore/GIL_Syntax/Pred.ml b/GillianCore/GIL_Syntax/Pred.ml index 32a39b63..50fad6ce 100644 --- a/GillianCore/GIL_Syntax/Pred.ml +++ b/GillianCore/GIL_Syntax/Pred.ml @@ -7,7 +7,7 @@ type t = TypeDef__.pred = { pred_ins : int list; (** Ins *) pred_definitions : ((string * string list) option * Asrt.t) list; (** Predicate definitions *) - pred_facts : Formula.t list; (** Facts that hold for every definition *) + pred_facts : Expr.t list; (** Facts that hold for every definition *) pred_guard : Asrt.t option; (** Cost for unfolding the predicate *) pred_pure : bool; (** Is the predicate pure *) pred_abstract : bool; (** Is the predicate abstract *) @@ -113,9 +113,7 @@ let pp fmt pred = let pp_facts fmt = function | [] -> () | facts -> - Fmt.pf fmt "facts: %a;@\n" - Fmt.(list ~sep:(any " and ") Formula.pp) - facts + Fmt.pf fmt "facts: %a;@\n" Fmt.(list ~sep:(any " and ") Expr.pp) facts in let pp_guard fmt = function | None -> () @@ -177,54 +175,48 @@ let check_pvars (predicates : (string, t) Hashtbl.t) : unit = Hashtbl.iter check_pred_pvars predicates +let extend_asrt_pred_types (preds : (string, t) Hashtbl.t) : Asrt.t -> Asrt.t = + List.concat_map @@ function + | Asrt.Pred (name, les) as a -> + let pred = + try Hashtbl.find preds name + with _ -> + raise + (Failure + ("DEATH. parameter_types: predicate " ^ name ^ " does not exist.")) + in + Logging.tmi (fun fmt -> + fmt "Gillian explicit param types: %s (%d, %d)" pred.pred_name + (List.length pred.pred_params) + (List.length les)); + let combined = + try List.combine pred.pred_params les + with Invalid_argument _ -> + let message = + Fmt.str + "Invalid number of parameters for predicate %s which requires %i \ + parameters and was used with the following %i parameters: %a" + pred.pred_name pred.pred_num_params (List.length les) + (Fmt.Dump.list Expr.pp) les + in + raise (Invalid_argument message) + in + let ac_types = + List.fold_left + (fun ac_types ((_, t_x), le) -> + match t_x with + | None -> ac_types + | Some t_x -> (le, t_x) :: ac_types) + [] combined + in + [ Asrt.Types ac_types; a ] + | a -> [ a ] + (** GIL Predicates can have non-pvar parameters - to say that a given parameter always has a certain value... *) let explicit_param_types (preds : (string, t) Hashtbl.t) (pred : t) : t = - let pt_asrt (a : Asrt.t) : Asrt.t = - let f_a_after a : Asrt.t = - match (a : Asrt.t) with - | Pred (name, les) -> - let pred = - try Hashtbl.find preds name - with _ -> - raise - (Failure - ("DEATH. parameter_types: predicate " ^ name - ^ " does not exist.")) - in - Logging.tmi (fun fmt -> - fmt "Gillian explicit param types: %s (%d, %d)" pred.pred_name - (List.length pred.pred_params) - (List.length les)); - let combined = - try List.combine pred.pred_params les - with Invalid_argument _ -> - let message = - Fmt.str - "Invalid number of parameters for predicate %s which \ - requires %i parameters and was used with the following %i \ - parameters: %a" - pred.pred_name pred.pred_num_params (List.length les) - (Fmt.Dump.list Expr.pp) les - in - raise (Invalid_argument message) - in - let ac_types = - List.fold_left - (fun ac_types ((_, t_x), le) -> - match t_x with - | None -> ac_types - | Some t_x -> (le, t_x) :: ac_types) - [] combined - in - Star (Types ac_types, a) - | _ -> a - in - Asrt.map None (Some f_a_after) None None a - in - let new_asrts = List.fold_right (fun (x, t_x) new_asrts -> @@ -235,7 +227,7 @@ let explicit_param_types (preds : (string, t) Hashtbl.t) (pred : t) : t = in let new_defs = List.map - (fun (oid, a) -> (oid, pt_asrt (Asrt.star (a :: new_asrts)))) + (fun (oid, a) -> (oid, extend_asrt_pred_types preds (a @ new_asrts))) pred.pred_definitions in let new_facts = @@ -244,7 +236,8 @@ let explicit_param_types (preds : (string, t) Hashtbl.t) (pred : t) : t = match t_x with | None -> new_facts | Some t_x -> - Formula.Eq (UnOp (TypeOf, PVar x), Lit (Type t_x)) :: new_facts) + Expr.BinOp (UnOp (TypeOf, PVar x), Equal, Lit (Type t_x)) + :: new_facts) pred.pred_params [] in { @@ -321,7 +314,7 @@ let close_token_name (pred : t) : string = failwith "close_token_name called on non-guarded predicate"; pred.pred_name ^ close_suffix -let close_token_call (pred : t) : Asrt.t = +let close_token_call (pred : t) : Asrt.atom = let name = close_token_name pred in let args = in_args pred pred.pred_params |> List.map (fun (x, _t) -> Expr.PVar x) diff --git a/GillianCore/GIL_Syntax/SLCmd.ml b/GillianCore/GIL_Syntax/SLCmd.ml index 43ba2d2e..584e5235 100644 --- a/GillianCore/GIL_Syntax/SLCmd.ml +++ b/GillianCore/GIL_Syntax/SLCmd.ml @@ -26,40 +26,23 @@ type t = TypeDef__.slcmd = | SymbExec [@@deriving yojson] -let map - (f_l : (t -> t) option) - (f_a : (Asrt.t -> Asrt.t) option) - (f_e : (Expr.t -> Expr.t) option) - (lcmd : t) : t = - (* Functions to map over assertions and expressions *) - let map_e = Option.value ~default:(fun x -> x) f_e in - let map_a = Option.value ~default:(fun x -> x) f_a in - - let mapped_lcmd = Option.fold ~some:(fun f -> f lcmd) ~none:lcmd f_l in - - (* Map over the elements of the command *) - match mapped_lcmd with - | Fold (name, les, None) -> Fold (name, List.map map_e les, None) +let map (f_a : Asrt.t -> Asrt.t) (f_e : Expr.t -> Expr.t) : t -> t = function + | Fold (name, les, None) -> Fold (name, List.map f_e les, None) | Fold (name, les, Some (s, l)) -> Fold - ( name, - List.map map_e les, - Some (s, List.map (fun (x, e) -> (x, map_e e)) l) ) + (name, List.map f_e les, Some (s, List.map (fun (x, e) -> (x, f_e e)) l)) | Unfold (name, les, unfold_info, b) -> - Unfold (name, List.map map_e les, unfold_info, b) + Unfold (name, List.map f_e les, unfold_info, b) | GUnfold name -> GUnfold name - | ApplyLem (s, l, existentials) -> ApplyLem (s, List.map map_e l, existentials) - | SepAssert (a, binders) -> SepAssert (map_a a, binders) - | Invariant (a, existentials) -> Invariant (map_a a, existentials) - | Consume (a, binders) -> Consume (map_a a, binders) - | Produce a -> Produce (map_a a) + | ApplyLem (s, l, existentials) -> ApplyLem (s, List.map f_e l, existentials) + | SepAssert (a, binders) -> SepAssert (f_a a, binders) + | Invariant (a, existentials) -> Invariant (f_a a, existentials) + | Consume (a, binders) -> Consume (f_a a, binders) + | Produce a -> Produce (f_a a) | SymbExec -> SymbExec | Package { lhs = lname, largs; rhs = rname, rargs } -> Package - { - lhs = (lname, List.map map_e largs); - rhs = (rname, List.map map_e rargs); - } + { lhs = (lname, List.map f_e largs); rhs = (rname, List.map f_e rargs) } let fold = List.fold_left SS.union SS.empty diff --git a/GillianCore/GIL_Syntax/Spec.ml b/GillianCore/GIL_Syntax/Spec.ml index f9350355..5dc96161 100644 --- a/GillianCore/GIL_Syntax/Spec.ml +++ b/GillianCore/GIL_Syntax/Spec.ml @@ -76,51 +76,12 @@ let pp fmt spec = spec.spec_sspecs let parameter_types (preds : (string, Pred.t) Hashtbl.t) (spec : t) : t = - let pt_asrt (a : Asrt.t) : Asrt.t = - let f_a_after a : Asrt.t = - match (a : Asrt.t) with - | Pred (name, les) -> - let pred = - try Hashtbl.find preds name - with _ -> - raise - (Failure - ("DEATH. parameter_types: predicate " ^ name - ^ " does not exist.")) - in - (* Printf.printf "Pred: %s\n\tParams1: %s\n\tParams2: %s\n" name - (String.concat ", " (let x, _ = List.split pred.params in x)) (String.concat ", " (List.map (Fmt.to_to_string Expr.pp) les)); *) - let combined_params = - try List.combine pred.pred_params les - with Invalid_argument _ -> - let message = - Fmt.str - "Predicate %s is expecting %i arguments but is used with the \ - following %i arguments : %a" - pred.pred_name pred.pred_num_params (List.length les) - (Fmt.Dump.list Expr.pp) les - in - raise (Invalid_argument message) - in - let ac_types = - List.fold_left - (fun ac_types ((_, t_x), le) -> - match t_x with - | None -> ac_types - | Some t_x -> (le, t_x) :: ac_types) - [] combined_params - in - Star (Types ac_types, a) - | _ -> a - in - Asrt.map None (Some f_a_after) None None a - in - + let map_asrts = Pred.extend_asrt_pred_types preds in let pt_sspec (sspec : st) : st = { sspec with - ss_pre = pt_asrt sspec.ss_pre; - ss_posts = List.map pt_asrt sspec.ss_posts; + ss_pre = map_asrts sspec.ss_pre; + ss_posts = List.map map_asrts sspec.ss_posts; } in { spec with spec_sspecs = List.map pt_sspec spec.spec_sspecs } diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index 0ae9811b..17ad7776 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -60,10 +60,9 @@ and binop = | FTimes | FDiv | FMod - | SLessThan - | BAnd - | BOr - | BImpl + | And + | Or + | Impl | BitwiseAnd | BitwiseOr | BitwiseXor @@ -88,14 +87,15 @@ and binop = | LstRepeat | StrCat | StrNth + | StrLess | SetDiff - | BSetMem - | BSetSub + | SetMem + | SetSub and unop = | IUnaryMinus | FUnaryMinus - | UNot + | Not | BitwiseNot | M_isNaN | M_abs @@ -127,6 +127,7 @@ and unop = | StrLen | NumToInt | IntToNum + | IsInt and nop = LstCat | SetUnion | SetInter @@ -142,35 +143,17 @@ and expr = | EList of expr list | ESet of expr list | Exists of (string * typ option) list * expr - | EForall of (string * typ option) list * expr + | ForAll of (string * typ option) list * expr -and formula = - | True - | False - | Not of formula - | And of formula * formula - | Or of formula * formula - | Eq of expr * expr - | Impl of formula * formula - | FLess of expr * expr - | FLessEq of expr * expr - | ILess of expr * expr - | ILessEq of expr * expr - | StrLess of expr * expr - | SetMem of expr * expr - | SetSub of expr * expr - | ForAll of (string * typ option) list * formula - | IsInt of expr - -and assertion = +and assertion_atom = | Emp - | Star of assertion * assertion | Pred of string * expr list - | Pure of formula + | Pure of expr | Types of (expr * typ) list - | GA of string * expr list * expr list + | CorePred of string * expr list * expr list | Wand of { lhs : string * expr list; rhs : string * expr list } +and assertion = assertion_atom list and bindings = string * (string * expr) list and slcmd = @@ -188,10 +171,10 @@ and slcmd = and lcmd = | If of expr * lcmd list * lcmd list - | Branch of formula + | Branch of expr | Macro of string * expr list - | Assert of formula - | Assume of formula + | Assert of expr + | Assume of expr | AssumeType of expr * typ | FreshSVar of string | SL of slcmd @@ -222,7 +205,7 @@ and pred = { pred_params : (string * typ option) list; pred_ins : int list; pred_definitions : ((string * string list) option * assertion) list; - pred_facts : formula list; + pred_facts : expr list; pred_guard : assertion option; pred_pure : bool; pred_abstract : bool; diff --git a/GillianCore/GIL_Syntax/UnOp.ml b/GillianCore/GIL_Syntax/UnOp.ml index 9788bc66..c5c0d09a 100644 --- a/GillianCore/GIL_Syntax/UnOp.ml +++ b/GillianCore/GIL_Syntax/UnOp.ml @@ -5,7 +5,7 @@ type t = TypeDef__.unop = | IUnaryMinus (** Integer unary minus *) | FUnaryMinus (** Float unary minus *) (* Boolean *) - | UNot (** Negation *) + | Not (** Negation *) (* Bitwise *) | BitwiseNot (** Bitwise negation *) (* Mathematics *) @@ -47,13 +47,13 @@ type t = TypeDef__.unop = (* Integer vs Number *) | NumToInt (** Number to Integer - actual cast *) | IntToNum (** Integer to Number - actual cast *) + | IsInt (** IsInt e <=> (e : float) /\ (e % 1. == 0) *) [@@deriving yojson, ord, eq] -let str (x : t) = - match x with +let str = function | IUnaryMinus -> "i-" | FUnaryMinus -> "-" - | UNot -> "not" + | Not -> "!" | BitwiseNot -> "~" | M_isNaN -> "isNaN" | M_abs -> "m_abs" @@ -83,5 +83,6 @@ let str (x : t) = | LstRev -> "l-rev" | StrLen -> "s-len" | SetToList -> "set_to_list" + | IsInt -> "is_int" | NumToInt -> "as_int" | IntToNum -> "as_num" diff --git a/GillianCore/GIL_Syntax/Visitors.ml b/GillianCore/GIL_Syntax/Visitors.ml index d2e6501b..508df7c0 100644 --- a/GillianCore/GIL_Syntax/Visitors.ml +++ b/GillianCore/GIL_Syntax/Visitors.ml @@ -75,11 +75,11 @@ module Collectors = struct inherit [_] reduce inherit Utils.ss_monoid - method! visit_ForAll exclude binders f = + method! visit_ForAll exclude binders e = (* Quantified variables need to be excluded *) let univ_quant = List.to_seq binders |> Seq.map fst in let exclude = Containers.SS.add_seq univ_quant exclude in - self#visit_formula exclude f + self#visit_expr exclude e method! visit_Exists exclude binders e = let exist_quants = List.to_seq binders |> Seq.map fst in diff --git a/GillianCore/GIL_Syntax/test/Visitors.ml b/GillianCore/GIL_Syntax/test/Visitors.ml index de72f7fa..57342647 100644 --- a/GillianCore/GIL_Syntax/test/Visitors.ml +++ b/GillianCore/GIL_Syntax/test/Visitors.ml @@ -41,7 +41,7 @@ let test_expr_base_elements () = EList [ Lit (LList [ Bool false ]); - BinOp (UnOp (UNot, Lit (Num 32.)), FPlus, PVar "b"); + BinOp (UnOp (Not, Lit (Num 32.)), FPlus, PVar "b"); ]; LVar "a"; ALoc "e"; diff --git a/GillianCore/command_line/s_interpreter_console.ml b/GillianCore/command_line/s_interpreter_console.ml index fab8a7da..7579b5dd 100644 --- a/GillianCore/command_line/s_interpreter_console.ml +++ b/GillianCore/command_line/s_interpreter_console.ml @@ -49,7 +49,7 @@ struct in let fs = match f with - | Some f -> [ Formula.Not f ] + | Some f -> [ Expr.Infix.not f ] | None -> [] in let subst = SState.sat_check_f error_state fs in diff --git a/GillianCore/debugging/debugger/base_debugger.ml b/GillianCore/debugging/debugger/base_debugger.ml index 5280d82c..914632da 100644 --- a/GillianCore/debugging/debugger/base_debugger.ml +++ b/GillianCore/debugging/debugger/base_debugger.ml @@ -231,7 +231,7 @@ struct let open Variable in State.get_pfs state |> PFS.to_list |> List.map (fun formula -> - let value = Fmt.to_to_string (Fmt.hbox Formula.pp) formula in + let value = Fmt.to_to_string (Fmt.hbox Expr.pp) formula in { name = ""; value; type_ = None; var_ref = 0 }) |> List.sort (fun v w -> Stdlib.compare v.value w.value) diff --git a/GillianCore/debugging/utils/match_map.ml b/GillianCore/debugging/utils/match_map.ml index d0a75bce..fbfba8d3 100644 --- a/GillianCore/debugging/utils/match_map.ml +++ b/GillianCore/debugging/utils/match_map.ml @@ -49,7 +49,7 @@ functor in let assertion = let asrt, _ = asrt_report.step in - Fmt.str "%a" Asrt.pp asrt + Fmt.str "%a" Asrt.pp_atom asrt in let substitutions = asrt_report.subst |> Subst.to_list_pp diff --git a/GillianCore/engine/Abstraction/LogicPreprocessing.ml b/GillianCore/engine/Abstraction/LogicPreprocessing.ml index 19f8751b..b325417b 100644 --- a/GillianCore/engine/Abstraction/LogicPreprocessing.ml +++ b/GillianCore/engine/Abstraction/LogicPreprocessing.ml @@ -12,74 +12,85 @@ let rec auto_unfold (predicates : (string, Pred.t) Hashtbl.t) (rec_tbl : (string, bool) Hashtbl.t) (asrt : Asrt.t) : Asrt.t list = - let au_rec = auto_unfold ~unfold_rec_predicates predicates rec_tbl in - let au_no_rec = auto_unfold ~unfold_rec_predicates:false predicates rec_tbl in - match (asrt : Asrt.t) with - | Star (a1, a2) -> - List.filter Simplifications.admissible_assertion - (List_utils.cross_product (au_rec a1) (au_rec a2) (fun asrt1 asrt2 -> - Asrt.Star (asrt1, asrt2))) - (* We don't unfold: - - Recursive predicates (except in some very specific cases) - - predicates marked with no-unfold - - predicates with a guard *) - | Pred (name, _) - when (Hashtbl.find rec_tbl name && not unfold_rec_predicates) - || - let pred = Hashtbl.find predicates name in - pred.pred_nounfold || Option.is_some pred.pred_guard -> [ asrt ] - | Pred (name, args) when Hashtbl.mem unfolded_preds name -> - L.verbose (fun fmt -> - fmt "Unfolding predicate: %s with nounfold %b" name - (Hashtbl.find predicates name).pred_nounfold); - let pred = Hashtbl.find unfolded_preds name in - let params, _ = List.split pred.pred_params in - let combined = - try List.combine params args - with Invalid_argument _ -> - Fmt.failwith - "Impossible to auto unfold predicate %s. Used with %i args instead \ - of %i" - name (List.length args) (List.length params) - in - let subst = SVal.SSubst.init combined in - let defs = List.map (fun (_, def) -> def) pred.pred_definitions in - List.map (SVal.SSubst.substitute_asrt subst ~partial:false) defs - | Pred (name, args) -> ( - try - L.tmi (fun fmt -> fmt "AutoUnfold: %a : %s" Asrt.pp asrt name); - let pred : Pred.t = Hashtbl.find predicates name in - (* If it is not, replace the predicate assertion for the list of its definitions - substituting the formal parameters of the predicate with the corresponding - logical expressions in the argument list *) - let params, _ = List.split pred.pred_params in - let subst = SVal.SSubst.init (List.combine params args) in - Logging.tmi (fun fmt -> - fmt "PREDICATE %s has %d definitions" pred.pred_name - (List.length pred.pred_definitions)); - let new_asrts = - List.map - (fun (_, a) -> - L.tmi (fun fmt -> fmt "Before Auto Unfolding: %a" Asrt.pp a); - let facts = - List.map (fun fact -> Asrt.Pure fact) pred.pred_facts - in - let a = Asrt.star (a :: facts) in - let result = SVal.SSubst.substitute_asrt subst ~partial:false a in - L.tmi (fun fmt -> fmt "After Auto Unfolding: %a" Asrt.pp result); - result) - pred.pred_definitions - in - - (* FIXME: - If we processed the predicate definitions in order the recursive call to auto unfold - would be avoided *) - let result = List.concat (List.map au_no_rec new_asrts) in - let result = List.filter Simplifications.admissible_assertion result in - result - with Not_found -> - raise (Failure ("Error: Can't auto_unfold predicate " ^ name))) - | _ -> [ asrt ] + asrt + |> List.map (function + (* We don't unfold: + - Recursive predicates (except in some very specific cases) + - predicates marked with no-unfold + - predicates with a guard *) + | Asrt.Pred (name, _) as asrt + when (Hashtbl.find rec_tbl name && not unfold_rec_predicates) + || + let pred = Hashtbl.find predicates name in + pred.pred_nounfold || Option.is_some pred.pred_guard -> + [ [ asrt ] ] + | Pred (name, args) when Hashtbl.mem unfolded_preds name -> + L.verbose (fun fmt -> + fmt "Unfolding predicate: %s with nounfold %b" name + (Hashtbl.find predicates name).pred_nounfold); + let pred = Hashtbl.find unfolded_preds name in + let params, _ = List.split pred.pred_params in + let combined = + try List.combine params args + with Invalid_argument _ -> + Fmt.failwith + "Impossible to auto unfold predicate %s. Used with %i args \ + instead of %i" + name (List.length args) (List.length params) + in + let subst = SVal.SSubst.init combined in + let defs = List.map (fun (_, def) -> def) pred.pred_definitions in + List.map (SVal.SSubst.substitute_asrt subst ~partial:false) defs + | Pred (name, args) as asrt -> ( + try + L.tmi (fun fmt -> fmt "AutoUnfold: %a : %s" Asrt.pp_atom asrt name); + let pred : Pred.t = Hashtbl.find predicates name in + (* If it is not, replace the predicate assertion for the list of its definitions + substituting the formal parameters of the predicate with the corresponding + logical expressions in the argument list *) + let params, _ = List.split pred.pred_params in + let subst = SVal.SSubst.init (List.combine params args) in + L.tmi (fun fmt -> + fmt "PREDICATE %s has %d definitions" pred.pred_name + (List.length pred.pred_definitions)); + let new_asrts = + List.map + (fun (_, a) -> + L.tmi (fun fmt -> fmt "Before Auto Unfolding: %a" Asrt.pp a); + let facts = + List.map (fun fact -> Asrt.Pure fact) pred.pred_facts + in + let a = a @ facts in + let result = + SVal.SSubst.substitute_asrt subst ~partial:false a + in + L.tmi (fun fmt -> + fmt "After Auto Unfolding: %a" Asrt.pp result); + result) + pred.pred_definitions + in + + (* FIXME: + If we processed the predicate definitions in order the recursive call to auto unfold + would be avoided *) + let au_no_rec = + auto_unfold ~unfold_rec_predicates:false predicates rec_tbl + in + let result = List.concat_map au_no_rec new_asrts in + List.filter Simplifications.admissible_assertion result + with Not_found -> + raise (Failure ("Error: Can't auto_unfold predicate " ^ name))) + | asrt -> [ [ asrt ] ]) + (* Now that all assertions have been unfolded to multiple options, do the + cross products of options + e.g. [[a1; a2]; [b1; b2]] -> [[a1; b1]; [a1; b2]; [a2; b1]; [a2; b2]] *) + |> List.fold_left + (fun acc asrts -> + List.concat_map + (fun asrt -> List.map (fun asrt' -> asrt' @ asrt) asrts) + acc) + [ [] ] + |> List.filter Simplifications.admissible_assertion (* * Return: Hashtbl from predicate name to boolean @@ -186,7 +197,7 @@ let find_pure_preds (preds : (string, Pred.t) Hashtbl.t) : let pred = Hashtbl.find preds pred_name in let is_pure = List.for_all - (fun (_, asrt) -> Asrt.is_pure_asrt asrt) + (fun (_, asrt) -> List.for_all Asrt.is_pure_asrt asrt) pred.pred_definitions in @@ -253,15 +264,15 @@ let unfold_spec (preds : (string, Pred.t) Hashtbl.t) (rec_info : (string, bool) Hashtbl.t) (spec : Spec.t) : Spec.t = - let aux spec_name (sspec : Spec.st) : Spec.st list = + let aux (sspec : Spec.st) : Spec.st list = let pres : Asrt.t list = auto_unfold preds rec_info sspec.ss_pre in - L.verbose (fun fmt -> fmt "Pre admissibility: %s" spec_name); + L.verbose (fun fmt -> fmt "Pre admissibility: %s" spec.spec_name); let pres = List.filter Simplifications.admissible_assertion pres in let posts : Asrt.t list = List.concat_map (auto_unfold preds rec_info) sspec.ss_posts in let posts = List.map Reduction.reduce_assertion posts in - L.verbose (fun fmt -> fmt "Post admissibility: %s" spec_name); + L.verbose (fun fmt -> fmt "Post admissibility: %s" spec.spec_name); L.tmi (fun fmt -> fmt "@[Testing admissibility for assertions:@.%a@]" (Fmt.list Asrt.pp) posts); @@ -270,14 +281,12 @@ let unfold_spec Fmt.failwith "Unfolding: Postcondition of %s seems invalid, it has been reduced to \ no postcondition" - spec_name; + spec.spec_name; List.map (fun pre -> Spec.{ sspec with ss_pre = pre; ss_posts = posts }) pres in - let spec_sspecs = - List.concat (List.map (aux spec.spec_name) spec.spec_sspecs) - in + let spec_sspecs = List.concat_map aux spec.spec_sspecs in match spec_sspecs with | [] -> Fmt.failwith "unfolding in spec at preprocessing led to no spec!" | _ -> @@ -352,9 +361,7 @@ let remove_equalities_between_binders_and_lvars binders assertion = let uf_maker = object inherit [_] Visitors.iter - method! visit_Not _ _ = () - method! visit_Or _ _ _ = () - method! visit_Eq _ e1 e2 = union_expr e1 e2 + method! visit_BinOp _ e1 op e2 = if op = Equal then union_expr e1 e2 end in uf_maker#visit_assertion () assertion; @@ -396,6 +403,8 @@ let unfold_proc (preds : (string, Pred.t) Hashtbl.t) (rec_info : (string, bool) Hashtbl.t) (proc : ('a, int) Proc.t) : ('a, int) Proc.t = + Logging.normal (fun f -> + f "UNFOLD_PROC ! %a" (Proc.pp_indexed ~pp_annot:Fmt.nop) proc); let new_spec = Option.map (unfold_spec preds rec_info) proc.proc_spec in let new_body = Array.map @@ -567,8 +576,7 @@ let add_closing_tokens preds = pred with pred_definitions = List.map - (fun (x, def) -> - (x, Asrt.Star (def, Pred.close_token_call pred))) + (fun (x, def) -> (x, Pred.close_token_call pred :: def)) pred.pred_definitions; }) |> Seq.iter (fun (pred : Pred.t) -> Hashtbl.replace preds pred.pred_name pred); diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index 646454bb..ce7e07c7 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -12,9 +12,9 @@ let outs_pp = (** The [mp_step] type represents a matching plan step, consisting of an assertion together with the possible learned outs *) -type step = Asrt.t * outs [@@deriving yojson, eq] +type step = Asrt.atom * outs [@@deriving yojson, eq] -let pp_step = Fmt.pair ~sep:(Fmt.any ", ") Asrt.pp outs_pp +let pp_step = Fmt.pair ~sep:(Fmt.any ", ") Asrt.pp_atom_full outs_pp let pp_step_list = Fmt.Dump.list pp_step type label = string * SS.t [@@deriving eq, yojson] @@ -25,7 +25,7 @@ let pp_label ft (lab, ss) = type post = Flag.t * Asrt.t list [@@deriving eq, yojson] let pp_post ft (flag, asrts) = - Fmt.pf ft "%a: %a" Flag.pp flag Asrt.pp (Asrt.star asrts) + Fmt.pf ft "%a: %a" Flag.pp flag Fmt.(list ~sep:comma Asrt.pp) asrts (** At a high level, a matching plan is a tree of assertions. *) @@ -68,11 +68,11 @@ let kb_pp = Fmt.(braces (iter ~sep:comma KB.iter Expr.full_pp)) type preds_tbl_t = (string, pred) Hashtbl.t type err = - | MPSpec of string * Asrt.t list list - | MPPred of string * Asrt.t list list - | MPLemma of string * Asrt.t list list - | MPAssert of Asrt.t * Asrt.t list list - | MPInvariant of Asrt.t * Asrt.t list list + | MPSpec of string * Asrt.t list + | MPPred of string * Asrt.t list + | MPLemma of string * Asrt.t list + | MPAssert of Asrt.t * Asrt.t list + | MPInvariant of Asrt.t * Asrt.t list [@@deriving show] exception MPError of err @@ -148,7 +148,7 @@ let rec missing_expr (kb : KB.t) (e : Expr.t) : KB.t list = Fmt.(brackets (list ~sep:semi kb_pp)) result); result - | Exists (bt, e) | EForall (bt, e) -> + | Exists (bt, e) | ForAll (bt, e) -> let kb' = KB.add_seq (List.to_seq bt |> Seq.map (fun (x, _) -> Expr.LVar x)) kb in @@ -286,7 +286,7 @@ let rec learn_expr (* TODO: Finish the remaining invertible binary operators *) | BinOp _ -> [] (* Can we learn anything from Exists? *) - | Exists _ | EForall _ -> [] + | Exists _ | ForAll _ -> [] and learn_expr_list (kb : KB.t) (le : (Expr.t * Expr.t) list) = (* L.(verbose (fun m -> m "Entering learn_expr_list: \nKB: %a\nList: %a" kb_pp kb Fmt.(brackets (list ~sep:semi (parens (pair ~sep:comma Expr.pp Expr.pp)))) le)); *) @@ -325,7 +325,7 @@ let simple_ins_expr_collector = (KB.empty, KB.singleton e) | UnOp (LstLen, ((PVar s | LVar s) as v)) when not (SS.mem s exclude) -> (KB.singleton v, KB.empty) - | Exists (bt, e) | EForall (bt, e) -> + | Exists (bt, e) | ForAll (bt, e) -> let exclude = List.fold_left (fun acc (x, _) -> SS.add x acc) exclude bt in @@ -401,28 +401,21 @@ let ins_and_outs_from_lists (kb : KB.t) (lei : Expr.t list) (leo : Expr.t list) (** [simple_ins_formula pf] returns the list of possible ins for a given formula [pf] *) -let rec simple_ins_formula (kb : KB.t) (pf : Formula.t) : KB.t list = +let rec simple_ins_formula (kb : KB.t) (pf : Expr.t) : KB.t list = let f = simple_ins_formula kb in match pf with - | True | False -> [] - | Not pf -> f pf + | UnOp (Not, pf) -> f pf (* Conjunction and disjunction are treated the same *) - | And (pf1, pf2) | Or (pf1, pf2) -> + | BinOp (pf1, And, pf2) | BinOp (pf1, Or, pf2) -> let ins_pf1 = f pf1 in let ins_pf2 = f pf2 in let ins = List_utils.cross_product ins_pf1 ins_pf2 KB.union in let ins = List_utils.remove_duplicates ins in List.map minimise_matchables ins - | Impl (f1, f2) -> simple_ins_formula kb (Or (Not f1, f2)) + | BinOp (f1, Impl, f2) -> + simple_ins_formula kb (BinOp (UnOp (Not, f1), Or, f2)) (* Relational formulae are all treated the same *) - | Eq (e1, e2) - | ILess (e1, e2) - | ILessEq (e1, e2) - | FLess (e1, e2) - | FLessEq (e1, e2) - | StrLess (e1, e2) - | SetMem (e1, e2) - | SetSub (e1, e2) -> + | BinOp (e1, _, e2) -> let ins_e1 = simple_ins_expr e1 in let ins_e2 = simple_ins_expr e2 in let ins = List_utils.list_product [ ins_e1; ins_e2 ] in @@ -434,8 +427,11 @@ let rec simple_ins_formula (kb : KB.t) (pf : Formula.t) : KB.t list = in let ins = List_utils.remove_duplicates ins in List.map minimise_matchables ins - (* Forall must exclude the binders *) - | ForAll (binders, pf) -> + | UnOp (_, e) -> + e |> simple_ins_expr |> List_utils.remove_duplicates + |> List.map minimise_matchables + (* ForAll/Exists must exclude the binders *) + | Exists (binders, pf) | ForAll (binders, pf) -> let binders = List.fold_left (fun acc (b, _) -> KB.add (Expr.LVar b) acc) @@ -444,20 +440,18 @@ let rec simple_ins_formula (kb : KB.t) (pf : Formula.t) : KB.t list = let ins_pf = f pf in let ins = List.map (fun ins -> KB.diff ins binders) ins_pf in List.map minimise_matchables ins - | IsInt e -> - e |> simple_ins_expr |> List_utils.remove_duplicates - |> List.map minimise_matchables + | Lit _ | PVar _ | LVar _ | ALoc _ | LstSub _ | NOp _ | EList _ | ESet _ -> [] (** [ins_outs_formula kb pf] returns a list of possible ins-outs pairs for a given formula [pf] under a given knowledge base [kb] *) -let ins_outs_formula (kb : KB.t) (pf : Formula.t) : (KB.t * outs) list = +let ins_outs_formula (kb : KB.t) (pf : Expr.t) : (KB.t * outs) list = let default_ins = simple_ins_formula kb pf in let default_result : (KB.t * outs) list = List.map (fun ins -> (ins, [])) default_ins in match pf with - | Eq (e1, e2) -> ( - L.verbose (fun fmt -> fmt "IO Equality: %a" Formula.pp pf); + | BinOp (e1, Equal, e2) -> ( + L.verbose (fun fmt -> fmt "IO Equality: %a" Expr.pp pf); L.verbose (fun fmt -> fmt "Ins: %a" Fmt.(brackets (list ~sep:semi kb_pp)) default_ins); L.verbose (fun fmt -> fmt "KB: %a" kb_pp kb); @@ -487,11 +481,11 @@ let ins_outs_formula (kb : KB.t) (pf : Formula.t) : (KB.t * outs) list = (list ~sep:semi (parens (pair ~sep:comma kb_pp outs_pp)))) result); result) - | And _ -> + | BinOp (_, And, _) -> raise (Failure (Format.asprintf "ins_outs_formula: Should have been reduced: %a" - Formula.pp pf)) + Expr.pp pf)) | _ -> default_result (** [ins_outs_assertion kb a] returns a list of possible ins-outs pairs @@ -499,15 +493,16 @@ let ins_outs_formula (kb : KB.t) (pf : Formula.t) : (KB.t * outs) list = let ins_outs_assertion (pred_ins : (string, int list) Hashtbl.t) (kb : KB.t) - (asrt : Asrt.t) : (KB.t * outs) list = + (asrt : Asrt.atom) : (KB.t * outs) list = let get_pred_ins name = match Hashtbl.find_opt pred_ins name with | None -> raise (Failure ("ins_outs_assertion. Unknown Predicate: " ^ name)) | Some ins -> ins in - match (asrt : Asrt.t) with + match (asrt : Asrt.atom) with + | Emp -> [] | Pure form -> ins_outs_formula kb form - | GA (_, lie, loe) -> ins_and_outs_from_lists kb lie loe + | CorePred (_, lie, loe) -> ins_and_outs_from_lists kb lie loe | Pred (p_name, args) -> let p_ins = get_pred_ins p_name in let _, lie, loe = @@ -522,6 +517,7 @@ let ins_outs_assertion | Types [ (e, _) ] -> let ins = simple_ins_expr e in List.map (fun ins -> (ins, [])) ins + | Types _ -> failwith "Impossible: non-atomic types assertion in get_pred_ins" | Wand { lhs = _, largs; rhs = rname, rargs } -> let r_ins = get_pred_ins rname in let _, llie, lloe = @@ -532,38 +528,27 @@ let ins_outs_assertion (0, [], []) rargs in ins_and_outs_from_lists kb (largs @ List.rev llie) lloe - | _ -> - raise (Failure "Impossible: non-simple assertion in ins_outs_assertion.") -let collect_simple_asrts a = - let rec aux (a : Asrt.t) : Asrt.t Seq.t = +let simplify_asrts ?(sorted = true) a = + let rec aux (a : Asrt.atom) : Asrt.atom list = match a with - | Pure True | Emp -> Seq.empty - | Pure (And (f1, f2)) -> Seq.append (aux (Pure f1)) (aux (Pure f2)) - | Pure _ | Pred _ | GA _ | Wand _ -> Seq.return a + | Pure (Lit (Bool true)) | Emp -> [] + | Pure (BinOp (f1, And, f2)) -> aux (Pure f1) @ aux (Pure f2) + | Pure _ | Pred _ | CorePred _ | Wand _ -> [ a ] | Types _ -> ( - let a = Reduction.reduce_assertion a in + let a = Reduction.reduce_assertion [ a ] in match a with - | Types les -> Seq.map (fun e -> Asrt.Types [ e ]) (List.to_seq les) - | _ -> aux a) - | Star (a1, a2) -> Seq.append (aux a1) (aux a2) - in - List.of_seq (aux a) - -let collect_and_simplify_atoms a = - let atoms = collect_simple_asrts a in - let atoms = - if List.mem (Asrt.Pure False) atoms then [ Asrt.Pure False ] else atoms + | [ Types les ] -> List.map (fun e -> Asrt.Types [ e ]) les + | _ -> List.concat_map aux a) in - let separating, overlapping = - List.partition - (function - | Asrt.Pred _ | Asrt.GA _ | Asrt.Wand _ -> true - | _ -> false) - atoms - in - let overlapping = List.sort_uniq Stdlib.compare overlapping in - List.sort Asrt.prioritise (separating @ overlapping) + let atoms = List.concat_map aux a in + if List.mem (Asrt.Pure (Lit (Bool false))) atoms then + [ Asrt.Pure (Lit (Bool false)) ] + else if not sorted then atoms + else + let overlapping, separating = List.partition Asrt.is_pure_asrt atoms in + let overlapping = List.sort_uniq Stdlib.compare overlapping in + List.sort Asrt.prioritise (separating @ overlapping) let s_init_atoms ~preds kb atoms = let step_of_atom ~kb atom = @@ -575,7 +560,7 @@ let s_init_atoms ~preds kb atoms = L.verbose (fun m -> m "KNOWN: @[%a@].@\n@[CUR MP:@\n%a@]@\nTO VISIT: @[%a@]" kb_pp kb pp_step_list current - (Fmt.list ~sep:(Fmt.any "@\n") Asrt.full_pp) + (Fmt.list ~sep:(Fmt.any "@\n") Asrt.pp_atom_full) rest); match rest with | [] -> @@ -595,9 +580,9 @@ let s_init_atoms ~preds kb atoms = search [] kb atoms let s_init ~(preds : (string, int list) Hashtbl.t) (kb : KB.t) (a : Asrt.t) : - (step list, Asrt.t list) result = + (step list, Asrt.t) result = L.verbose (fun m -> m "Entering s-init on: %a\n\nKB: %a\n" Asrt.pp a kb_pp kb); - let atoms = collect_and_simplify_atoms a in + let atoms = simplify_asrts a in s_init_atoms ~preds kb atoms let of_step_list ?post ?label (steps : step list) : t = @@ -659,7 +644,7 @@ let init (preds : (string, int list) Hashtbl.t) (asrts_posts : (Asrt.t * ((string * SS.t) option * (Flag.t * Asrt.t list) option)) list) - : (t, Asrt.t list list) result = + : (t, Asrt.atom list list) result = let known_matchables = match use_params with | None -> known_matchables @@ -908,32 +893,32 @@ let get_lemma (prog : 'a prog) (name : string) : (lemma, unit) result = | Some lemma -> Ok lemma | None -> Error () -let rec pp_asrt +let pp_asrt ?(preds_printer : (Format.formatter -> string * Expr.t list -> unit) option) ~(preds : preds_tbl_t) (fmt : Format.formatter) (a : Asrt.t) = - let pp_asrt = pp_asrt ?preds_printer ~preds in - match a with - | Star (a1, a2) -> Fmt.pf fmt "%a *@ %a" pp_asrt a1 pp_asrt a2 - | Pred (name, args) -> ( - match preds_printer with - | Some pp_pred -> (Fmt.hbox pp_pred) fmt (name, args) - | None -> ( - try - let pred = get_pred_def preds name in - let out_params = Pred.out_params pred.pred in - let out_args = Pred.out_args pred.pred args in - let in_args = Pred.in_args pred.pred args in - let out_params_args = List.combine out_params out_args in - let pp_out_params_args fmt (x, e) = - Fmt.pf fmt "@[%s: %a@]" x Expr.pp e - in - Fmt.pf fmt "%s(@[%a@])" name - (Pred.pp_ins_outs pred.pred Expr.pp pp_out_params_args) - (in_args, out_params_args) - with _ -> Asrt.pp fmt a)) - | a -> Asrt.pp fmt a + let pp_atom_asrt fmt = function + | Asrt.Pred (name, args) -> ( + match preds_printer with + | Some pp_pred -> (Fmt.hbox pp_pred) fmt (name, args) + | None -> ( + try + let pred = get_pred_def preds name in + let out_params = Pred.out_params pred.pred in + let out_args = Pred.out_args pred.pred args in + let in_args = Pred.in_args pred.pred args in + let out_params_args = List.combine out_params out_args in + let pp_out_params_args fmt (x, e) = + Fmt.pf fmt "@[%s: %a@]" x Expr.pp e + in + Fmt.pf fmt "%s(@[%a@])" name + (Pred.pp_ins_outs pred.pred Expr.pp pp_out_params_args) + (in_args, out_params_args) + with _ -> Asrt.pp fmt a)) + | a -> Asrt.pp_atom fmt a + in + Fmt.list ~sep:(Fmt.any " *@ ") pp_atom_asrt fmt a let pp_sspec ?(preds_printer : (Format.formatter -> string * Expr.t list -> unit) option) diff --git a/GillianCore/engine/Abstraction/MP.mli b/GillianCore/engine/Abstraction/MP.mli index 63a85792..42b4752d 100644 --- a/GillianCore/engine/Abstraction/MP.mli +++ b/GillianCore/engine/Abstraction/MP.mli @@ -7,7 +7,7 @@ val outs_pp : outs Fmt.t (** The [step] type represents a matching plan step, consisting of an assertion together with the possible learned outs *) -type step = Asrt.t * outs [@@deriving yojson] +type step = Asrt.atom * outs [@@deriving yojson] type label = string * SS.t [@@deriving yojson] type post = Flag.t * Asrt.t list [@@deriving yojson] @@ -40,11 +40,11 @@ type 'annot prog = { type preds_tbl_t = (string, pred) Hashtbl.t type err = - | MPSpec of string * Asrt.t list list - | MPPred of string * Asrt.t list list - | MPLemma of string * Asrt.t list list - | MPAssert of Asrt.t * Asrt.t list list - | MPInvariant of Asrt.t * Asrt.t list list + | MPSpec of string * Asrt.t list + | MPPred of string * Asrt.t list + | MPLemma of string * Asrt.t list + | MPAssert of Asrt.t * Asrt.t list + | MPInvariant of Asrt.t * Asrt.t list [@@deriving show] module KB = Expr.Set @@ -53,13 +53,13 @@ val learn_expr : ?top_level:bool -> KB.t -> Gil_syntax.Expr.t -> Gil_syntax.Expr.t -> outs val ins_outs_expr : KB.t -> Expr.t -> Expr.t -> (KB.t * outs) list -val collect_simple_asrts : Asrt.t -> Asrt.t list +val simplify_asrts : ?sorted:bool -> Asrt.t -> Asrt.t val s_init_atoms : preds:(string, int list) Hashtbl.t -> KB.t -> - Asrt.t list -> - (step list, Asrt.t list) result + Asrt.t -> + (step list, Asrt.t) result val of_step_list : ?post:post -> ?label:label -> step list -> t @@ -69,7 +69,7 @@ val init : KB.t -> (string, int list) Hashtbl.t -> (Asrt.t * ((string * SS.t) option * (Flag.t * Asrt.t list) option)) list -> - (t, Asrt.t list list) result + (t, Asrt.t list) result val init_prog : ?preds_tbl:(string, pred) Hashtbl.t -> diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index 8a8ee836..8af919b1 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -76,7 +76,9 @@ module type S = sig type unfold_info_t = (string * string) list - val produce_assertion : t -> SVal.SESubst.t -> Asrt.t -> (t, err_t) Res_list.t + val produce_assertion : + t -> SVal.SESubst.t -> Asrt.atom -> (t, err_t) Res_list.t + val produce : t -> SVal.SESubst.t -> Asrt.t -> (t, err_t) Res_list.t val produce_posts : t -> SVal.SESubst.t -> Asrt.t list -> t list @@ -305,9 +307,9 @@ module Make (State : SState.S) : preds_list; { state; preds; wands = Wands.init []; pred_defs; variants } - type cons_pure_result = Success of state_t | Abort of Formula.t | Vanish + type cons_pure_result = Success of state_t | Abort of Expr.t | Vanish - let cons_pure (state : state_t) (f : Formula.t) : cons_pure_result = + let cons_pure (state : state_t) (f : Expr.t) : cons_pure_result = if !Config.under_approximation then match State.assume_a ~matching:true state [ f ] with | Some state -> Success state @@ -531,8 +533,10 @@ module Make (State : SState.S) : in Some (actual_pred, args) - let rec produce_assertion (astate : t) (subst : SVal.SESubst.t) (a : Asrt.t) : - (t, err_t) Res_list.t = + let rec produce_assertion + (astate : t) + (subst : SVal.SESubst.t) + (a : Asrt.atom) : (t, err_t) Res_list.t = let open Res_list.Syntax in let { state; preds; pred_defs; variants; wands } = astate in let other_state_err msg = [ Error (StateErr.EOther msg) ] in @@ -543,12 +547,15 @@ module Make (State : SState.S) : Produce simple assertion: @[%a@]@\n\ With subst: %a\n\ \ -------------------------@\n" - Asrt.pp a SVal.SESubst.pp subst); + Asrt.pp_atom a SVal.SESubst.pp subst); L.verbose (fun m -> m "STATE: %a" pp_astate astate); - match a with - | GA (a_id, ins, outs) -> + match (a : Asrt.atom) with + | Emp -> + L.verbose (fun fmt -> fmt "Emp assertion."); + [ Ok astate ] + | CorePred (a_id, ins, outs) -> L.verbose (fun fmt -> fmt "Memory producer."); let vs = List.map (subst_in_expr subst) (ins @ outs) in @@ -596,12 +603,12 @@ module Make (State : SState.S) : List.fold_left2 (fun facts param le -> let subst = - Formula.subst_expr_for_expr ~to_subst:param ~subst_with:le + Expr.subst_expr_for_expr ~to_subst:param ~subst_with:le in List.map subst facts) facts params les in - let facts = Asrt.Pure (Formula.conjunct facts) in + let facts = Asrt.Pure (Expr.conjunct facts) in produce_assertion { state; preds; wands; pred_defs; variants } subst facts @@ -621,7 +628,7 @@ module Make (State : SState.S) : let rargs = List.map (subst_in_expr subst) rargs in Wands.extend wands Wands.{ lhs = (lname, largs); rhs = (rname, rargs) }; Res_list.return astate - | Pure (Eq (PVar x, le)) | Pure (Eq (le, PVar x)) -> ( + | Pure (BinOp (PVar x, Equal, le)) | Pure (BinOp (le, Equal, PVar x)) -> ( L.verbose (fun fmt -> fmt "Pure assertion."); match SVal.SESubst.get subst (PVar x) with | Some v_x -> @@ -632,7 +639,7 @@ module Make (State : SState.S) : [ Ok { state; preds; wands; pred_defs; variants } ]) (State.assume_a ~matching:true ~production:!Config.delay_entailment state - [ Eq (v_x, v_le) ]) + [ BinOp (v_x, Equal, v_le) ]) in Option.value ~default: @@ -650,7 +657,7 @@ module Make (State : SState.S) : Res_list.return (update_store astate x v)) | Pure f -> ( L.verbose (fun fmt -> fmt "Pure assertion."); - let f' = SVal.SESubst.substitute_formula subst ~partial:false f in + let f' = SVal.SESubst.subst_in_expr subst ~partial:false f in (* let pp_state = match !Config.pbn with | false -> State.pp @@ -669,18 +676,15 @@ module Make (State : SState.S) : | None -> let msg = Fmt.str "Produce Simple Assertion: Cannot assume pure formula %a." - Formula.pp f' + Expr.pp f' in other_state_err msg | Some state' -> Res_list.return { state = state'; preds; wands; pred_defs; variants }) - | _ -> L.fail "Produce simple assertion: unsupported assertion" - and produce_asrt_list - (astate : t) - (subst : SVal.SESubst.t) - (sas : Asrt.t list) : (t, err_t) Res_list.t = + and produce_asrt_list (astate : t) (subst : SVal.SESubst.t) (sas : Asrt.t) : + (t, err_t) Res_list.t = let open Res_list.Syntax in let other_state_err msg = Res_list.error_with (StateErr.EOther msg) in let () = @@ -695,7 +699,7 @@ module Make (State : SState.S) : with e -> let admissible = State.assume_a ~time:"Produce: final check" ~matching:true - intermediate_state.state [ True ] + intermediate_state.state [ Expr.true_ ] in if !Config.delay_entailment && Option.is_none admissible then ( L.verbose (fun fmt -> @@ -712,7 +716,7 @@ module Make (State : SState.S) : L.verbose (fun fmt -> fmt "Produce: final check"); try State.assume_a ~time:"Produce: final check" ~matching:true state - [ True ] + [ Expr.true_ ] with _ -> None in L.verbose (fun fmt -> fmt "Concluded final check"); @@ -727,7 +731,7 @@ module Make (State : SState.S) : "@[-----------------@\n\ -----------------@\n\ Produce assertion: @[%a@]@]" Asrt.pp a); - let sas = MP.collect_simple_asrts a in + let sas = MP.simplify_asrts a in produce_asrt_list astate subst sas let produce_posts (state : t) (subst : SVal.SESubst.t) (asrts : Asrt.t list) : @@ -785,7 +789,7 @@ module Make (State : SState.S) : m "@[Using unfold info, obtained subst:@\n%a@]@\n" SVal.SESubst.pp subst) - let resource_fail = Res_list.error_with (StateErr.EAsrt ([], True, [])) + let resource_fail = Res_list.error_with (StateErr.EAsrt ([], Expr.true_, [])) (* WARNING: At the moment, unfold behaves over-approximately, it will return only success of only error. We only use unfold and fold in OX mode right now, and we don't quite know the meaning of UX fold/unfold. *) @@ -919,26 +923,13 @@ module Make (State : SState.S) : | Some (pname, v_args) -> ( L.verbose (fun m -> m "FOUND STH TO UNFOLD: %s!!!!\n" pname); let rets = unfold (copy_astate astate) pname v_args in - let only_errors = - List.filter_map - (function - | Error e -> Some e - | _ -> None) - rets - in + let only_successes, only_errors = Res_list.split rets in match only_errors with | [] -> L.verbose (fun m -> m "Unfold complete: %s(@[%a@]): %d" pname Fmt.(list ~sep:comma Expr.pp) v_args (List.length rets)); - let only_successes = - List.filter_map - (function - | Ok x -> Some x - | _ -> None) - rets - in Some only_successes | _ :: _ -> L.verbose (fun m -> @@ -1000,14 +991,14 @@ module Make (State : SState.S) : | Success new_state -> Res_list.return { astate with state = new_state } | Abort fail_pf -> let error = - StateErr.EAsrt ([], Not fail_pf, [ [ Pure fail_pf ] ]) + StateErr.EAsrt ([], UnOp (Not, fail_pf), [ [ Pure fail_pf ] ]) in Res_list.error_with error | Vanish -> Res_list.vanish) | None -> L.verbose (fun m -> m "Could not find any match for the required wand!!!"); - Res_list.error_with (StateErr.EPure False) + Res_list.error_with (StateErr.EPure Expr.false_) (** Consumes a predicate from the state. If the predicate is not "verbatim" in our set of preds, @@ -1059,7 +1050,7 @@ module Make (State : SState.S) : ({ state = new_state; wands; preds; pred_defs; variants }, vs) | Abort fail_pf -> let error = - StateErr.EAsrt ([], Not fail_pf, [ [ Pure fail_pf ] ]) + StateErr.EAsrt ([], UnOp (Not, fail_pf), [ [ Pure fail_pf ] ]) in Res_list.error_with error | Vanish -> Res_list.vanish)) @@ -1089,7 +1080,7 @@ module Make (State : SState.S) : | _ -> let values = List.filter_map Fun.id vs in (* The `False` as second parameter is required for the fixing mechanism to trigger *) - Res_list.error_with (StateErr.EAsrt (values, False, [])) + Res_list.error_with (StateErr.EAsrt (values, Expr.false_, [])) and match_ins_outs_lists (state : State.t) @@ -1127,7 +1118,7 @@ module Make (State : SState.S) : with _ -> None in match outs with - | None -> Abort True + | None -> Abort Expr.true_ | Some outs -> ( L.verbose (fun fmt -> fmt "Substed outs: %a" @@ -1156,7 +1147,7 @@ module Make (State : SState.S) : match ac with | Abort _ | Vanish -> ac | Success state -> - let pf : Formula.t = Eq (vd, od) in + let pf = Expr.BinOp (vd, Equal, od) in cons_pure state pf) (Success state) vos eos with Invalid_argument _ -> @@ -1177,7 +1168,7 @@ module Make (State : SState.S) : let a = fst step in (* Get pvars, lvars, locs from the assertion *) let a_pvars, a_lvars, a_locs = - (Asrt.pvars a, Asrt.lvars a, Asrt.locs a) + (Asrt.pvars [ a ], Asrt.lvars [ a ], Asrt.locs [ a ]) in let filter_vars = SS.union a_pvars (SS.union a_lvars a_locs) in @@ -1231,12 +1222,12 @@ module Make (State : SState.S) : let p, outs = step in let open Res_list.Syntax in let res_list = - match (p : Asrt.t) with - | GA (a_id, e_ins, e_outs) -> ( + match (p : Asrt.atom) with + | CorePred (a_id, e_ins, e_outs) -> ( let vs_ins = List.map (subst_in_expr_opt astate subst) e_ins in let failure = List.exists (fun x -> x = None) vs_ins in if failure then ( - Fmt.pr "I don't know all ins for %a????" Asrt.pp p; + Fmt.pr "I don't know all ins for %a????" Asrt.pp_atom p; if !Config.under_approximation then [] else resource_fail) else let vs_ins = List.map Option.get vs_ins in @@ -1256,7 +1247,8 @@ module Make (State : SState.S) : { state = state'''; preds; wands; pred_defs; variants } | Abort fail_pf -> let error = - StateErr.EAsrt ([], Not fail_pf, [ [ Pure fail_pf ] ]) + StateErr.EAsrt + ([], UnOp (Not, fail_pf), [ [ Pure fail_pf ] ]) in Res_list.error_with error | Vanish -> Res_list.vanish) @@ -1309,7 +1301,7 @@ module Make (State : SState.S) : let fold_outs_info = (subst, step, les_outs) in consume_wand ~fold_outs_info astate subst { lhs; rhs } (* Conjunction should not be here *) - | Pure (Formula.And _) -> + | Pure (BinOp (_, And, _)) -> raise (Failure "Match assertion: And: should have been reduced") (* Other pure assertions *) | Pure f -> ( @@ -1330,7 +1322,7 @@ module Make (State : SState.S) : Ok discharges | Some out' when Expr.equal out out' -> Ok discharges | Some out' -> - let new_discharge = Formula.Eq (out, out') in + let new_discharge = Expr.BinOp (out, Equal, out') in Ok (new_discharge :: discharges)) (Ok []) outs in @@ -1340,23 +1332,23 @@ module Make (State : SState.S) : Fmt.failwith "INTERNAL ERROR: Matching failure: do not know all ins \ for %a" - Formula.pp f + Expr.pp f | Ok discharges -> discharges in (* To match a pure formula we must know all ins *) - let opf = SVal.SESubst.substitute_in_formula_opt subst f in + let opf = SVal.SESubst.subst_in_expr_opt subst f in match opf with | None -> Fmt.failwith "Matching failure: do not know all ins for %a" - Formula.pp f + Expr.pp f | Some pf -> ( let discharges_pf = - List.fold_left Formula.Infix.( #&& ) True discharges + List.fold_left Expr.Infix.( && ) Expr.true_ discharges in let discharges_pf = - Reduction.reduce_formula ~matching:true discharges_pf + Reduction.reduce_lexpr ~matching:true discharges_pf in - let to_asrt = Formula.Infix.( #&& ) pf discharges_pf in + let to_asrt = Expr.Infix.( && ) pf discharges_pf in match cons_pure state to_asrt with | Success new_state -> Res_list.return @@ -1365,13 +1357,13 @@ module Make (State : SState.S) : | Abort _ -> let vs = State.unfolding_vals state [ pf ] in let error = - StateErr.EAsrt (vs, Not pf, [ [ Pure pf ] ]) + StateErr.EAsrt (vs, Expr.UnOp (Not, pf), [ [ Pure pf ] ]) in Res_list.error_with error)) | Types les -> ( let corrections = List.fold_left - (fun (ac : Formula.t list) (le, t) -> + (fun (ac : Expr.t list) (le, t) -> let v_le = (subst_in_expr_opt astate subst) le in let v_le : Expr.t = match v_le with @@ -1380,8 +1372,9 @@ module Make (State : SState.S) : in match State.get_type state v_le with | Some t' -> - if not (Type.equal t t') then False :: ac else ac - | None -> Eq (UnOp (TypeOf, v_le), Lit (Type t)) :: ac) + if not (Type.equal t t') then Expr.false_ :: ac else ac + | None -> + BinOp (UnOp (TypeOf, v_le), Equal, Lit (Type t)) :: ac) [] les in @@ -1400,9 +1393,10 @@ module Make (State : SState.S) : let les = List.filter_map (subst_in_expr_opt astate subst) les in - let conjunct = Formula.conjunct corrections in + let conjunct = Expr.conjunct corrections in let error = - StateErr.EAsrt (les, Not conjunct, [ [ Pure conjunct ] ]) + StateErr.EAsrt + (les, UnOp (Not, conjunct), [ [ Pure conjunct ] ]) in Res_list.error_with error) (* LTrue, LFalse, LEmp, LStar *) @@ -1438,12 +1432,13 @@ module Make (State : SState.S) : | Pure pf -> let { state = bstate; _ } = state in let vs = State.unfolding_vals bstate [ pf ] in - Res_list.error_with (StateErr.EAsrt (vs, Not pf, [ [ Pure pf ] ])) - | _ -> + Res_list.error_with + (StateErr.EAsrt (vs, UnOp (Not, pf), [ [ Pure pf ] ])) + | asrt -> let other_error = StateErr.EOther (Fmt.str "Uncaught exception while matching assertions %a" - Asrt.pp (fst step)) + Asrt.pp_atom asrt) in Res_list.error_with other_error in @@ -1576,13 +1571,13 @@ module Make (State : SState.S) : let subst_i = SVal.SESubst.copy subst in let can_fix errs = List.exists State.can_fix errs in - let rec handle_ret ~try_recover ret = + let rec handle_ret ~fuel ret = match ret with | Ok successes -> L.verbose (fun fmt -> fmt "Matcher.match_: Success (possibly empty)"); Res_list.just_oks successes | Error errs - when try_recover && !Config.unfolding + when fuel > 0 && !Config.unfolding && Exec_mode.is_verification_exec !Config.current_exec_mode && (not in_matching) && can_fix errs -> ( L.verbose (fun fmt -> fmt "Matcher.match_: Failure"); @@ -1616,8 +1611,7 @@ module Make (State : SState.S) : (* let subst'' = compose_substs (Subst.to_list subst_i) subst (Subst.init []) in *) let subst'' = SVal.SESubst.copy subst_i in let new_ret = match_mp ([ (astate, subst'', mp) ], []) in - (* We already tried recovering once and it failed, we stop here *) - handle_ret ~try_recover:false new_ret)) + handle_ret ~fuel:(fuel - 1) new_ret)) | Error errors -> L.verbose (fun fmt -> fmt "Matcher.match: Failure"); Res_list.just_errors errors @@ -1626,7 +1620,7 @@ module Make (State : SState.S) : { astate = AstateRec.from astate; subst; mp; match_kind } (fun _ -> let ret = match_mp ([ (astate, subst, mp) ], []) in - handle_ret ~try_recover:true ret) + handle_ret ~fuel:10 ret) and fold ?(in_matching = false) @@ -1759,23 +1753,9 @@ module Make (State : SState.S) : match tactic.try_fold with | Some fold_values -> ( let res = fold_guarded_with_vals astate fold_values in - let errors = - List.filter_map - (function - | Error e -> Some e - | _ -> None) - res - in + let successes, errors = Res_list.split res in match errors with - | [] -> - let successes = - List.filter_map - (function - | Ok x -> Some x - | _ -> None) - res - in - Ok successes + | [] -> Ok successes | _ -> let error_string = Fmt.str "%a" Fmt.(Dump.list string) errors in Error error_string) @@ -1834,14 +1814,13 @@ module Make (State : SState.S) : let get_defs (pred : Pred.t) largs = if pred.pred_abstract || Option.is_some pred.pred_guard then - [ Asrt.Pred (pred.pred_name, largs) ] + [ [ Asrt.Pred (pred.pred_name, largs) ] ] else let unfolded_pred = Hashtbl.find_opt LogicPreprocessing.unfolded_preds pred.pred_name in - match unfolded_pred with - | Some pred -> List.map snd pred.pred_definitions - | None -> List.map snd pred.pred_definitions + let pred = Option.value ~default:pred unfolded_pred in + List.map snd pred.pred_definitions let make_lhs_states ~pred_defs ~empty_state (lname, largs) = let open Syntaxes.List in @@ -1947,7 +1926,7 @@ module Make (State : SState.S) : init_subst; fold_outs_info = (subst, step, out_params, out_args); } - | (GA (core_pred, ins, outs), _), [ err ] -> + | (CorePred (core_pred, ins, outs), _), [ err ] -> (* What we do here is simulate the idea that the core predicate is actually a folded core-predicate *) let kb = List.to_seq ins @@ -1994,15 +1973,15 @@ module Make (State : SState.S) : List.init out_amount (fun o_i -> all_new_outs.((cp_i * out_amount) + o_i)) in - Asrt.GA (core_pred, ins, outs)) + Asrt.CorePred (core_pred, ins, outs)) new_ins_l in let learning_equalities = List.map2 (fun old_out new_out -> - let open Formula.Infix in Asrt.Pure - (Expr.PVar old_out) #== (subst_in_expr pvar_subst new_out)) + (Expr.Infix.( == ) (Expr.PVar old_out) + (subst_in_expr pvar_subst new_out))) out_params new_outs_learn in let atoms = List.rev_append new_cps learning_equalities in @@ -2055,7 +2034,7 @@ module Make (State : SState.S) : (fun acc vd od -> let open Syntaxes.Result in let* acc = acc in - let equality = Formula.Eq (vd, od) in + let equality = Expr.BinOp (vd, Equal, od) in if State.assert_a state.lhs_state.state [ equality ] || State.assert_a state.current_state.state [ equality ] @@ -2064,15 +2043,16 @@ module Make (State : SState.S) : Error [ StateErr.EAsrt - ([], Formula.Infix.fnot equality, [ [ Pure equality ] ]); + ([], Expr.Infix.not equality, [ [ Pure equality ] ]); ]) (Ok state) obtained expected - let rec package_case_step { lhs_state; current_state; subst } step : - (package_state list, err_t list) Result.t = + let rec package_case_step + { lhs_state; current_state; subst } + (step : MP.step) : (package_state list, err_t list) Result.t = let open Syntaxes.Result in L.verbose (fun m -> - m "Wand about to consume RHS step: %a" Asrt.pp (fst step)); + m "Wand about to consume RHS step: %a" Asrt.pp_atom (fst step)); (* States are modified in place unfortunately.. so we have to copy them just in case *) (* First we try to consume from the lhs_state *) let- lhs_errs = diff --git a/GillianCore/engine/Abstraction/Matcher.mli b/GillianCore/engine/Abstraction/Matcher.mli index 3945480f..3e41c9ff 100644 --- a/GillianCore/engine/Abstraction/Matcher.mli +++ b/GillianCore/engine/Abstraction/Matcher.mli @@ -76,11 +76,13 @@ module type S = sig type unfold_info_t = (string * string) list - val produce_assertion : t -> SVal.SESubst.t -> Asrt.t -> (t, err_t) Res_list.t + val produce_assertion : + t -> SVal.SESubst.t -> Asrt.atom -> (t, err_t) Res_list.t + val produce : t -> SVal.SESubst.t -> Asrt.t -> (t, err_t) Res_list.t val produce_posts : t -> SVal.SESubst.t -> Asrt.t list -> t list - (** [unfold state name args unfold_info] returns a + (** [unfold state name args unfold_info] returns a list of pairs (subst, state), resulting from unfolding the predicate [name(..args..)] from the given state. unfold_info contains information about how to bind new variables. *) diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 67686cc2..7182ef4f 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -20,22 +20,19 @@ module Make (SPState : PState.S) = struct (* 1 - Find the lists for which we know the length *) let find_list_exprs_to_concretize (a : Asrt.t) : (Expr.t, Expr.t list) Hashtbl.t = - let rec collect_concretizable_lists = function - | Asrt.Pure (Eq (EList _, EList _)) -> [] - | Pure (Eq (le, EList les)) | Pure (Eq (EList les, le)) -> [ (le, les) ] - | Pure (Eq (UnOp (LstLen, le), Lit (Int i))) - | Pure (Eq (Lit (Int i), UnOp (LstLen, le))) -> + let collect_concretizable_lists = function + | Asrt.Pure (BinOp (EList _, Equal, EList _)) -> [] + | Pure (BinOp (le, Equal, EList les)) + | Pure (BinOp (EList les, Equal, le)) -> [ (le, les) ] + | Pure (BinOp (UnOp (LstLen, le), Equal, Lit (Int i))) + | Pure (BinOp (Lit (Int i), Equal, UnOp (LstLen, le))) -> let les = List.init (Z.to_int i) (fun _ -> Expr.LVar (LVar.alloc ())) in [ (le, les) ] - | Star (a1, a2) -> - List.rev_append - (collect_concretizable_lists a1) - (collect_concretizable_lists a2) | _ -> [] in - let lst_exprs = collect_concretizable_lists a in + let lst_exprs = List.concat_map collect_concretizable_lists a in let lists_tbl = Hashtbl.create 1 in List.iter (fun (le, les) -> @@ -77,12 +74,9 @@ module Make (SPState : PState.S) = struct let make_new_list_as (a : Asrt.t) (new_lists : (Expr.t, Expr.t list) Hashtbl.t) : Asrt.t = - let new_list_as = - Hashtbl.fold - (fun le les (ac : Asrt.t list) -> Pure (Eq (le, EList les)) :: ac) - new_lists [ a ] - in - Asrt.star new_list_as + Hashtbl.fold + (fun le les (ac : Asrt.t) -> Pure (BinOp (le, Equal, EList les)) :: ac) + new_lists a in (* Doing IT *) @@ -148,11 +142,10 @@ module Make (SPState : PState.S) = struct raise (Failure "Non-integer string index") | _, _ -> BinOp (nle1, StrNth, nle2)) | _ -> ( - match ((nle1 : Expr.t), (nle2 : Expr.t)) with - | Lit lit1, Lit lit2 -> + match (nle1, nle2) with + | Lit _, Lit _ -> let lit = - CExprEval.evaluate_binop (CStore.init []) bop (Lit lit1) - (Lit lit2) + CExprEval.evaluate_binop (CStore.init []) bop nle1 nle2 in Lit lit | _, _ -> BinOp (nle1, bop, nle2))) @@ -181,12 +174,12 @@ module Make (SPState : PState.S) = struct "normalise_lexpr: program variable in normalised \ expression") | BinOp (_, _, _) | UnOp (_, _) -> UnOp (TypeOf, nle1) - | Exists _ | EForall _ -> Lit (Type BooleanType) + | Exists _ | ForAll _ -> Lit (Type BooleanType) | EList _ | LstSub _ | NOp (LstCat, _) -> Lit (Type ListType) | NOp (_, _) | ESet _ -> Lit (Type SetType)) | _ -> UnOp (uop, nle1))) | EList le_list -> - let n_le_list = List.map (fun le -> f le) le_list in + let n_le_list = List.map f le_list in let all_literals, lit_list = List.fold_left (fun (ac, list) le -> @@ -197,10 +190,10 @@ module Make (SPState : PState.S) = struct in if all_literals then Lit (LList lit_list) else EList n_le_list | ESet le_list -> - let n_le_list = List.map (fun le -> f le) le_list in + let n_le_list = List.map f le_list in ESet n_le_list | NOp (op, le_list) -> - let n_le_list = List.map (fun le -> f le) le_list in + let n_le_list = List.map f le_list in NOp (op, n_le_list) | LstSub (le1, le2, le3) -> ( let nle1 = f le1 in @@ -217,7 +210,7 @@ module Make (SPState : PState.S) = struct | _, Lit (Num _), Lit (Num _) -> raise (Failure "Sublist indexes non-integer") | _, _, _ -> LstSub (nle1, nle2, nle3)) - | Exists (bt, e) -> ( + | ForAll (bt, e) | Exists (bt, e) -> ( let new_gamma = Type_env.copy gamma in List.iter (fun (x, t) -> @@ -228,23 +221,11 @@ module Make (SPState : PState.S) = struct let ne = normalise_lexpr ~no_types ~store ~subst new_gamma e in let lvars = Expr.lvars ne in let bt = List.filter (fun (x, _) -> SS.mem x lvars) bt in - match bt with - | [] -> ne - | _ -> Exists (bt, ne)) - | EForall (bt, e) -> ( - let new_gamma = Type_env.copy gamma in - List.iter - (fun (x, t) -> - match t with - | Some t -> Type_env.update new_gamma x t - | None -> Type_env.remove new_gamma x) - bt; - let ne = normalise_lexpr ~no_types ~store ~subst new_gamma e in - let lvars = Expr.lvars ne in - let bt = List.filter (fun (x, _) -> SS.mem x lvars) bt in - match bt with - | [] -> ne - | _ -> EForall (bt, ne)) + match (bt, le) with + | [], _ -> ne + | _, Exists _ -> Exists (bt, ne) + | _, ForAll _ -> ForAll (bt, ne) + | _, _ -> failwith "Impossible") in if not no_types then Typing.infer_types_expr gamma result; @@ -252,12 +233,14 @@ module Make (SPState : PState.S) = struct let extend_typing_env_using_assertion_info (gamma : Type_env.t) - (a_list : Formula.t list) : unit = + (a_list : Expr.t list) : unit = List.iter (fun a -> - match (a : Formula.t) with - | Eq (LVar x, le) | Eq (le, LVar x) | Eq (PVar x, le) | Eq (le, PVar x) - -> ( + match (a : Expr.t) with + | BinOp (LVar x, Equal, le) + | BinOp (le, Equal, LVar x) + | BinOp (PVar x, Equal, le) + | BinOp (le, Equal, PVar x) -> ( let x_type = Type_env.get gamma x in match x_type with | None -> @@ -274,71 +257,12 @@ module Make (SPState : PState.S) = struct ----------------------------------------------------- _____________________________________________________ *) - let normalise_logic_expression - ?(no_types = false) - (store : SStore.t) - (gamma : Type_env.t) - (subst : SESubst.t) - (le : Expr.t) : Expr.t = - let le' = normalise_lexpr ~no_types ~store ~subst gamma le in - le' - - (* ----------------------------------------------------- - Normalise Pure Assertion (only one!) - ----------------------------------------------------- - Invoke normalise_logic_expression on all the logic - expressions of a - _____________________________________________________ - *) - let rec normalise_pure_assertion - ?(no_types = false) - (store : SStore.t) - (gamma : Type_env.t) - (subst : SESubst.t) - (assertion : Formula.t) : Formula.t = - let fa = normalise_pure_assertion ~no_types store gamma subst in - let fant = normalise_pure_assertion ~no_types:true store gamma subst in - let fe = normalise_logic_expression ~no_types store gamma subst in - let result : Formula.t = - match (assertion : Formula.t) with - | Eq (le1, le2) -> Eq (fe le1, fe le2) - | ILess (le1, le2) -> ILess (fe le1, fe le2) - | ILessEq (le1, le2) -> ILessEq (fe le1, fe le2) - | FLess (le1, le2) -> FLess (fe le1, fe le2) - | FLessEq (le1, le2) -> FLessEq (fe le1, fe le2) - | Not (Eq (le1, le2)) -> Not (Eq (fe le1, fe le2)) - | Not (FLessEq (le1, le2)) -> Not (FLessEq (fe le1, fe le2)) - | Not (FLess (le1, le2)) -> Not (FLess (fe le1, fe le2)) - | Not (ILessEq (le1, le2)) -> Not (ILessEq (fe le1, fe le2)) - | Not (ILess (le1, le2)) -> Not (ILess (fe le1, fe le2)) - | Not (SetSub (le1, le2)) -> Not (SetSub (fe le1, fe le2)) - | Not (SetMem (le1, le2)) -> Not (SetMem (fe le1, fe le2)) - | And (a1, a2) -> And (fa a1, fa a2) - | Or (a1, a2) -> Or (fa a1, fa a2) - | False -> False - | True -> True - | SetSub (le1, le2) -> SetSub (fe le1, fe le2) - | SetMem (le1, le2) -> SetMem (fe le1, fe le2) - | ForAll (bt, a) -> ForAll (bt, fant a) - | IsInt e -> IsInt (fe e) - | Impl (a, b) -> Impl (fa a, fa b) - | _ -> - let msg = - Fmt.str - "normalise_pure_assertion can only process pure assertions: %a" - Formula.pp assertion - in - raise (Failure msg) - in - if not no_types then Typing.infer_types_formula gamma result; - result - let normalise_pure_assertions (store : SStore.t) (gamma : Type_env.t) (subst : SESubst.t) (args : SS.t option) - (fs : Formula.t list) : PFS.t = + (fs : Expr.t list) : PFS.t = let pvar_equalities = Hashtbl.create 1 in let non_store_pure_assertions = Stack.create () in @@ -349,16 +273,19 @@ module Make (SPState : PState.S) = struct * or E = x, for a logical expression E and a variable x * ----------------------------------------------------------------------------------- *) - let init_pvar_equalities (fs : Formula.t list) : unit = + let init_pvar_equalities (fs : Expr.t list) : unit = List.iter - (fun (f : Formula.t) : unit -> + (fun (f : Expr.t) : unit -> match f with - | Eq (PVar x, e) | Eq (e, PVar x) -> + | BinOp (PVar x, Equal, e) | BinOp (e, Equal, PVar x) -> if (not (Hashtbl.mem pvar_equalities x)) && not (SStore.mem store x) then Hashtbl.add pvar_equalities x e - else Stack.push (Formula.Eq (PVar x, e)) non_store_pure_assertions + else + Stack.push + (Expr.BinOp (PVar x, Equal, e)) + non_store_pure_assertions | _ -> Stack.push f non_store_pure_assertions) fs in @@ -433,7 +360,7 @@ module Make (SPState : PState.S) = struct try let e = Hashtbl.find pvar_equalities var in Stack.push - (Formula.Eq (LVar (new_lvar_name var), e)) + (Expr.BinOp (LVar (new_lvar_name var), Equal, e)) non_store_pure_assertions; Hashtbl.remove pvar_equalities var with _ -> @@ -491,8 +418,7 @@ module Make (SPState : PState.S) = struct *) let fill_store args = let def_pvars = - SS.of_list - (List.concat (List.map (fun f -> SS.elements (Formula.pvars f)) fs)) + fs |> List.map Expr.pvars |> List.fold_left SS.union SS.empty in let p_vars = Option.value ~default:def_pvars args in SS.iter @@ -516,9 +442,7 @@ module Make (SPState : PState.S) = struct while not (Stack.is_empty non_store_pure_assertions) do let p_assertion = Stack.pop non_store_pure_assertions in - let p_assertion' = - normalise_pure_assertion store gamma subst p_assertion - in + let p_assertion' = normalise_lexpr ~store ~subst gamma p_assertion in PFS.extend pfs p_assertion'; cur_index := !cur_index + 1 done; @@ -561,29 +485,25 @@ module Make (SPState : PState.S) = struct result (** Separate an assertion into: core_asrts, pure, typing and predicates *) - let rec separate_assertion (a : Asrt.t) : + let separate_assertion (a : Asrt.t) : (string * Expr.t list * Expr.t list) list - * Formula.t list + * Expr.t list * (Expr.t * Type.t) list * (string * Expr.t list) list * Wands.wand list = - let f = separate_assertion in - - match a with - | Star (al, ar) -> - let core_asrts_l, pure_l, types_l, preds_l, wands_l = f al in - let core_asrts_r, pure_r, types_r, preds_r, wands_r = f ar in - ( core_asrts_l @ core_asrts_r, - pure_l @ pure_r, - types_l @ types_r, - preds_l @ preds_r, - wands_l @ wands_r ) - | GA (a, es1, es2) -> ([ (a, es1, es2) ], [], [], [], []) - | Wand { lhs; rhs } -> ([], [], [], [], [ { lhs; rhs } ]) - | Emp -> ([], [], [], [], []) - | Types lst -> ([], [], lst, [], []) - | Pred (name, params) -> ([], [], [], [ (name, params) ], []) - | Pure f -> ([], [ f ], [], [], []) + List.fold_left + (fun (core_asrts, pure, types, preds, wands) (a : Asrt.atom) -> + match a with + | CorePred (a, es1, es2) -> + ((a, es1, es2) :: core_asrts, pure, types, preds, wands) + | Wand { lhs; rhs } -> + (core_asrts, pure, types, preds, Wands.{ lhs; rhs } :: wands) + | Emp -> (core_asrts, pure, types, preds, wands) + | Types lst -> (core_asrts, pure, lst @ types, preds, wands) + | Pred (name, params) -> + (core_asrts, pure, types, (name, params) :: preds, wands) + | Pure f -> (core_asrts, f :: pure, types, preds, wands)) + ([], [], [], [], []) a (** Normalise type assertions (Intialise type environment *) let normalise_types @@ -598,7 +518,7 @@ module Make (SPState : PState.S) = struct m "%s : %s" ((Fmt.to_to_string Expr.pp) e) (Type.str t))) type_list; - let fe = normalise_logic_expression store gamma subst in + let fe = normalise_lexpr ~store ~subst gamma in let type_check_lexpr (le : Expr.t) (t : Type.t) : bool = let le_type, success = Typing.type_lexpr gamma le in @@ -650,7 +570,7 @@ module Make (SPState : PState.S) = struct (gamma : Type_env.t) (subst : SVal.SESubst.t) (pred_asrts : (string * Expr.t list) list) : Preds.t = - let fe = normalise_logic_expression store gamma subst in + let fe = normalise_lexpr ~store ~subst gamma in let preds = Preds.init [] in List.iter @@ -671,7 +591,7 @@ module Make (SPState : PState.S) = struct (fun facts (param, le) -> List.map (fun fact -> - Formula.subst_expr_for_expr ~to_subst:param ~subst_with:le + Expr.subst_expr_for_expr ~to_subst:param ~subst_with:le fact) facts) pred_def.pred.pred_facts (List.combine params les) @@ -683,7 +603,7 @@ module Make (SPState : PState.S) = struct preds let generate_overlapping_constraints - (c_asrts : (string * Expr.t list * Expr.t list) list) : Formula.t list = + (c_asrts : (string * Expr.t list * Expr.t list) list) : Expr.t list = let partition (c_asrts : (string * Expr.t list * Expr.t list) list) : (string, (Expr.t list * Expr.t list) list) Hashtbl.t = let summary : (string, (Expr.t list * Expr.t list) list) Hashtbl.t = @@ -704,24 +624,24 @@ module Make (SPState : PState.S) = struct let generate_constraint (ins_outs_pair : (Expr.t * Expr.t) list * (Expr.t * Expr.t) list) : - Formula.t = + Expr.t = let ins_pairs, outs_pairs = ins_outs_pair in let ins_fo = - Formula.disjunct + Expr.disjunct (List.map - (fun (i1, i2) -> Formula.Not (Formula.Eq (i1, i2))) + (fun (i1, i2) -> Expr.UnOp (Not, Expr.BinOp (i1, Equal, i2))) ins_pairs) in let outs_fo = - Formula.conjunct - (List.map (fun (o1, o2) -> Formula.Eq (o1, o2)) outs_pairs) + Expr.conjunct + (List.map (fun (o1, o2) -> Expr.BinOp (o1, Equal, o2)) outs_pairs) in - Or (ins_fo, outs_fo) + BinOp (ins_fo, Or, outs_fo) in let summary_to_constraints (summary : (string, (Expr.t list * Expr.t list) list) Hashtbl.t) : - Formula.t list = + Expr.t list = let f_aux (ins1, outs1) (ins2, outs2) = if List.length ins1 <> List.length ins2 @@ -732,7 +652,7 @@ module Make (SPState : PState.S) = struct Hashtbl.fold (fun (_ : _) (a_asrts : (Expr.t list * Expr.t list) list) - (_ : Formula.t list) : Formula.t list -> + (_ : Expr.t list) : Expr.t list -> let pre_constraints = List_utils.cross_product a_asrts a_asrts f_aux in @@ -760,7 +680,7 @@ module Make (SPState : PState.S) = struct (c_asrts : (string * Expr.t list * Expr.t list) list) : (string * Expr.t list * Expr.t list) list * SESubst.t * SESubst.t = let new_pfs = PFS.copy pfs in - let fe = normalise_logic_expression store gamma subst in + let fe = normalise_lexpr ~store ~subst gamma in let c_asrts' = List.map (fun (a, ins, outs) -> (a, List.map fe ins, List.map fe outs)) @@ -783,7 +703,7 @@ module Make (SPState : PState.S) = struct L.verbose (fun m -> m "pfs after overlapping constraints:\n%a\nSubst:\n%a\nSubst':\n%a\n" (* FIXME: Shouldn't use PFS.to_list but Fmt.iter and PFS.iter *) - (Fmt.list ~sep:(Fmt.any "@\n") Formula.pp) + (Fmt.list ~sep:(Fmt.any "@\n") Expr.pp) (PFS.to_list new_pfs) SESubst.pp subst SESubst.pp subst'); let f_subst = SESubst.subst_in_expr subst' ~partial:true in @@ -844,7 +764,7 @@ module Make (SPState : PState.S) = struct (fun current_states (a, ins, outs) -> let open Syntaxes.List in let* current_state = current_states in - SPState.produce current_state subst (Asrt.GA (a, ins, outs)) + SPState.produce current_state subst [ Asrt.CorePred (a, ins, outs) ] |> (* If some production fails, we ignore *) List.filter_map (function | Ok x -> Some x @@ -852,13 +772,14 @@ module Make (SPState : PState.S) = struct L.verbose (fun m -> m "One branch of produce GA failed for: %a!\n\ - with Message: %a. Might have lost some paths ?" Asrt.pp - (Asrt.GA (a, ins, outs)) + with Message: %a. Might have lost some paths ?" + Asrt.pp_atom + (Asrt.CorePred (a, ins, outs)) SPState.pp_err msg); None)) [ astate ] - let subst_to_pfs ?(svars : SS.t option) (subst : SESubst.t) : Formula.t list = + let subst_to_pfs ?(svars : SS.t option) (subst : SESubst.t) : Expr.t list = let subst_lvs = SESubst.to_list subst in let subst_lvs' = match svars with @@ -877,27 +798,23 @@ module Make (SPState : PState.S) = struct | _ -> false) subst_lvs in - List.map (fun (e, le) -> Formula.Eq (e, le)) subst_lvs' + List.map (fun (e, le) -> Expr.BinOp (e, Equal, le)) subst_lvs' let normalise_a_bit (a : Asrt.t) = let a = Reduction.reduce_assertion a in let subst = SESubst.init [] in - let rec find_spec_var_eqs (a : Asrt.t) = - let f = find_spec_var_eqs in + let find_spec_var_eqs (a : Asrt.atom) = match a with - | Star (al, ar) -> - f al; - f ar - | Pure (Eq (LVar x, LVar y)) + | Pure (BinOp (LVar x, Equal, LVar y)) when is_spec_var_name x && not (is_spec_var_name y) -> SESubst.put subst (LVar y) (LVar x) - | Pure (Eq (LVar x, LVar y)) + | Pure (BinOp (LVar x, Equal, LVar y)) when is_spec_var_name y && not (is_spec_var_name x) -> SESubst.put subst (LVar x) (LVar y) | _ -> () in - find_spec_var_eqs a; + List.iter find_spec_var_eqs a; SESubst.substitute_asrt subst ~partial:true a (** Given an assertion creates a symbolic state and a substitution *) @@ -906,7 +823,7 @@ module Make (SPState : PState.S) = struct ~(init_data : SPState.init_data) ?(pvars : SS.t option) (a : Asrt.t) : ((SPState.t * SESubst.t) list, string) result = - let falsePFs pfs = PFS.mem pfs False in + let falsePFs pfs = PFS.mem pfs Expr.false_ in let a = normalise_a_bit a in let svars = SS.filter is_spec_var_name (Asrt.lvars a) in L.verbose (fun m -> diff --git a/GillianCore/engine/Abstraction/PState.ml b/GillianCore/engine/Abstraction/PState.ml index 200377d4..bb2a2923 100644 --- a/GillianCore/engine/Abstraction/PState.ml +++ b/GillianCore/engine/Abstraction/PState.ml @@ -189,7 +189,7 @@ module Make (State : SState.S) : ?(production = false) ?(time = "") (astate : t) - (fs : Formula.t list) : t option = + (fs : Expr.t list) : t option = match State.assume_a ~matching ~production ~time astate.state fs with | Some state -> Some { astate with state } | None -> None @@ -201,10 +201,10 @@ module Make (State : SState.S) : let sat_check (astate : t) (v : Expr.t) : bool = State.sat_check astate.state v - let sat_check_f (astate : t) (fs : Formula.t list) : SVal.SESubst.t option = + let sat_check_f (astate : t) (fs : Expr.t list) : SVal.SESubst.t option = State.sat_check_f astate.state fs - let assert_a (astate : t) (fs : Formula.t list) : bool = + let assert_a (astate : t) (fs : Expr.t list) : bool = State.assert_a astate.state fs let equals (astate : t) (v1 : Expr.t) (v2 : Expr.t) : bool = @@ -262,7 +262,7 @@ module Make (State : SState.S) : |> SS.union (Preds.get_lvars preds) |> SS.union (Wands.get_lvars wands) - let to_assertions ?(to_keep : SS.t option) (astate : t) : Asrt.t list = + let to_assertions ?(to_keep : SS.t option) (astate : t) : Asrt.t = let { state; preds; wands; _ } = astate in let s_asrts = State.to_assertions ?to_keep state in let p_asrts = Preds.to_assertions preds in @@ -410,7 +410,7 @@ module Make (State : SState.S) : preds_list; { state; preds; wands = Wands.init []; pred_defs; variants } - let consume ~(prog : 'a MP.prog) astate a binders = + let consume ~(prog : 'a MP.prog) astate (a : Asrt.t) binders = if not (List.for_all Names.is_lvar_name binders) then failwith "Binding of pure variables in *-assert."; let store = State.get_store astate.state in @@ -503,11 +503,12 @@ module Make (State : SState.S) : @ additional_bindings in let new_bindings = - List.map (fun (e, e_v) -> Asrt.Pure (Eq (e, e_v))) new_bindings + List.map + (fun (e, e_v) -> Asrt.Pure (BinOp (e, Equal, e_v))) + new_bindings in - let a_new_bindings = Asrt.star new_bindings in let full_subst = make_id_subst a in - let a_produce = a_new_bindings in + let a_produce = new_bindings in let open Res_list.Syntax in let result = let** new_astate = SMatcher.produce new_state full_subst a_produce in @@ -533,7 +534,7 @@ module Make (State : SState.S) : StateErr.EOther msg) result | Error err -> - let fail_pfs : Formula.t = State.get_failing_constraint err in + let fail_pfs : Expr.t = State.get_failing_constraint err in let failing_model = State.sat_check_f astate.state [ fail_pfs ] in let msg = @@ -667,7 +668,7 @@ module Make (State : SState.S) : match result with | Ok state -> Ok state | Error err -> - let fail_pfs : Formula.t = State.get_failing_constraint err in + let fail_pfs : Expr.t = State.get_failing_constraint err in let failing_model = State.sat_check_f astate.state [ fail_pfs ] in let () = L.print_to_all @@ -721,10 +722,9 @@ module Make (State : SState.S) : | Expr.PVar x when List.mem x pvar_binders -> false | UnOp (LstLen, _) -> false | _ -> true) - |> List.map (fun (e, e_v) -> Asrt.Pure (Eq (e, e_v))) + |> List.map (fun (e, e_v) -> Asrt.Pure (BinOp (e, Equal, e_v))) in - let a_bindings = Asrt.star bindings in - let subst_bindings = make_id_subst a_bindings in + let subst_bindings = make_id_subst bindings in let pvar_subst_list_known = List.map (fun x -> @@ -748,9 +748,7 @@ module Make (State : SState.S) : (SVal.SESubst.substitute_asrt subst_bindings ~partial:true a) in L.verbose (fun fmt -> fmt "Invariant v2: %a" Asrt.pp a_substed); - let a_produce = - Reduction.reduce_assertion (Asrt.star [ a_bindings; a_substed ]) - in + let a_produce = Reduction.reduce_assertion (bindings @ a_substed) in L.verbose (fun fmt -> fmt "Invariant v3: %a" Asrt.pp a_produce); (* Create empty state *) let invariant_state : t = clear_resource new_state in @@ -803,7 +801,7 @@ module Make (State : SState.S) : (fun astates (id, frame) -> let** astate = astates in let** astate = - let frame_asrt = Asrt.star (to_assertions frame) in + let frame_asrt = to_assertions frame in let full_subst = make_id_subst frame_asrt in let+ produced = SMatcher.produce astate full_subst frame_asrt in match produced with @@ -1011,16 +1009,18 @@ module Make (State : SState.S) : @ additional_bindings in let new_bindings = - List.map (fun (e, e_v) -> Asrt.Pure (Eq (e, e_v))) new_bindings + List.map + (fun (e, e_v) -> Asrt.Pure (BinOp (e, Equal, e_v))) + new_bindings in - let a_new_bindings = Asrt.star new_bindings in + let a_new_bindings = new_bindings in let subst_bindings = make_id_subst a_new_bindings in let full_subst = make_id_subst a in let _ = SVal.SESubst.merge_left full_subst subst_bindings in let a_substed = SVal.SESubst.substitute_asrt subst_bindings ~partial:true a in - let a_produce = Asrt.star [ a_new_bindings; a_substed ] in + let a_produce = a_new_bindings @ a_substed in let result = let** new_astate = SMatcher.produce new_state full_subst a_produce @@ -1048,7 +1048,7 @@ module Make (State : SState.S) : StateErr.EOther msg) result | Error err -> - let fail_pfs : Formula.t = State.get_failing_constraint err in + let fail_pfs : Expr.t = State.get_failing_constraint err in let failing_model = State.sat_check_f astate.state [ fail_pfs ] in let msg = @@ -1124,7 +1124,7 @@ module Make (State : SState.S) : L.verbose (fun fmt -> fmt "PSTATE.matches: Success: %b" success); success - let unfolding_vals (astate : t) (fs : Formula.t list) : vt list = + let unfolding_vals (astate : t) (fs : Expr.t list) : vt list = State.unfolding_vals astate.state fs let add_pred_defs (pred_defs : MP.preds_tbl_t) (astate : t) : t = @@ -1180,7 +1180,7 @@ module Make (State : SState.S) : let split_core_pred_further astate core_pred ins err = State.split_core_pred_further astate.state core_pred ins err - let mem_constraints (astate : t) : Formula.t list = + let mem_constraints (astate : t) : Expr.t list = State.mem_constraints astate.state let is_overlapping_asrt (a : string) : bool = State.is_overlapping_asrt a diff --git a/GillianCore/engine/Abstraction/Preds.ml b/GillianCore/engine/Abstraction/Preds.ml index 5b950f88..547d6ed4 100644 --- a/GillianCore/engine/Abstraction/Preds.ml +++ b/GillianCore/engine/Abstraction/Preds.ml @@ -100,8 +100,9 @@ let get_alocs (preds : t) : SS.t = (** Printing function *) let pp_pabs fmt pa = + let exprpp fmt e = Fmt.pf fmt "@[%a@]" Expr.pp e in let pname, vs = pa in - Fmt.pf fmt "%s(%a)" pname (Fmt.list ~sep:(Fmt.any ", ") Expr.pp) vs + Fmt.pf fmt "%s(%a)" pname (Fmt.list ~sep:(Fmt.any ", ") exprpp) vs let pp fmt preds = let lpreds = to_list preds in @@ -223,7 +224,7 @@ let substitution_in_place (subst : st) (preds : t) : unit = let pred_substitution subst (s, vs) = (s, List.map (subst_in_val subst) vs) in preds := List.map (pred_substitution subst) !preds -let to_assertions (preds : t) : Asrt.t list = +let to_assertions (preds : t) : Asrt.atom list = let preds = to_list preds in let pred_to_assert (n, args) = Asrt.Pred (n, args) in List.sort Asrt.compare (List.map pred_to_assert preds) diff --git a/GillianCore/engine/Abstraction/Preds.mli b/GillianCore/engine/Abstraction/Preds.mli index 89c35fde..ad1e0011 100644 --- a/GillianCore/engine/Abstraction/Preds.mli +++ b/GillianCore/engine/Abstraction/Preds.mli @@ -40,4 +40,4 @@ val get_all : maintain:bool -> (abs_t -> bool) -> t -> abs_t list val substitution_in_place : SVal.SESubst.t -> t -> unit (** Turns a predicate set into a list of assertions *) -val to_assertions : t -> Asrt.t list +val to_assertions : t -> Asrt.t diff --git a/GillianCore/engine/Abstraction/Verifier.ml b/GillianCore/engine/Abstraction/Verifier.ml index 0f2a1114..cb8cb7a8 100644 --- a/GillianCore/engine/Abstraction/Verifier.ml +++ b/GillianCore/engine/Abstraction/Verifier.ml @@ -189,7 +189,7 @@ struct posts in if not to_verify then - let pre' = Asrt.star (SPState.to_assertions ss_pre) in + let pre' = SPState.to_assertions ss_pre in (None, Some (pre', posts)) else (* Step 4 - create a matching plan for the postconditions and s_test *) @@ -229,7 +229,7 @@ struct L.verbose (fun m -> m "%s" msg); (None, None) | Ok post_mp -> - let pre' = Asrt.star (SPState.to_assertions ss_pre) in + let pre' = SPState.to_assertions ss_pre in let ss_pre = match flag with (* Lemmas should not have stores when being proven *) diff --git a/GillianCore/engine/BiAbduction/Abductor.ml b/GillianCore/engine/BiAbduction/Abductor.ml index 28a153ce..75add5ab 100644 --- a/GillianCore/engine/BiAbduction/Abductor.ml +++ b/GillianCore/engine/BiAbduction/Abductor.ml @@ -90,13 +90,12 @@ module Make SPState.simplify ~kill_new_lvars:true state_f in let+ final_simplified = finals_simplified in - Asrt.star - (List.sort Asrt.compare - (SPState.to_assertions ~to_keep:pvars final_simplified)) + List.sort Asrt.compare + (SPState.to_assertions ~to_keep:pvars final_simplified) in let+ pre = - let af_asrt = Asrt.star (SPState.to_assertions state_af) in + let af_asrt = SPState.to_assertions state_af in let af_subst = make_id_subst af_asrt in let* af_produce_res = SPState.produce state_i af_subst af_asrt in match af_produce_res with @@ -105,9 +104,8 @@ module Make SPState.simplify ~kill_new_lvars:true state_i' in let+ simplified = simplifieds in - Asrt.star - (List.sort Asrt.compare - (SPState.to_assertions ~to_keep:pvars simplified)) + List.sort Asrt.compare + (SPState.to_assertions ~to_keep:pvars simplified) | Error _ -> L.verbose (fun m -> m "Failed to produce anti-frame"); [] diff --git a/GillianCore/engine/BiAbduction/BiState.ml b/GillianCore/engine/BiAbduction/BiState.ml index 056bb9cd..beb46afb 100644 --- a/GillianCore/engine/BiAbduction/BiState.ml +++ b/GillianCore/engine/BiAbduction/BiState.ml @@ -77,7 +77,7 @@ module Make (State : SState.S) = struct ?(production = false) ?time:_ (bi_state : t) - (fs : Formula.t list) : t option = + (fs : Expr.t list) : t option = let { state; _ } = bi_state in match State.assume_a ~matching ~production state fs with | Some state -> Some { bi_state with state } @@ -89,11 +89,11 @@ module Make (State : SState.S) = struct let sat_check ({ state; _ } : t) (v : Expr.t) : bool = State.sat_check state v - let sat_check_f ({ state; _ } : t) (fs : Formula.t list) : - SVal.SESubst.t option = + let sat_check_f ({ state; _ } : t) (fs : Expr.t list) : SVal.SESubst.t option + = State.sat_check_f state fs - let assert_a ({ state; _ } : t) (fs : Formula.t list) : bool = + let assert_a ({ state; _ } : t) (fs : Expr.t list) : bool = State.assert_a state fs let equals ({ state; _ } : t) (v1 : Expr.t) (v2 : Expr.t) : bool = @@ -149,7 +149,7 @@ module Make (State : SState.S) = struct let get_spec_vars ({ state; _ } : t) : Var.Set.t = State.get_spec_vars state let get_lvars ({ state; _ } : t) : Var.Set.t = State.get_lvars state - let to_assertions ?(to_keep : SS.t option) ({ state; _ } : t) : Asrt.t list = + let to_assertions ?(to_keep : SS.t option) ({ state; _ } : t) : Asrt.t = State.to_assertions ?to_keep state let evaluate_slcmd (prog : 'a MP.prog) (lcmd : SLCmd.t) (bi_state : t) : @@ -167,7 +167,7 @@ module Make (State : SState.S) = struct let frame_on _ _ _ = raise (Failure "ERROR: framing called for bi-abductive execution") - let unfolding_vals ({ state; _ } : t) (fs : Formula.t list) : Expr.t list = + let unfolding_vals ({ state; _ } : t) (fs : Expr.t list) : Expr.t list = State.unfolding_vals state fs let substitution_in_place ?subst_all:_ (_ : SVal.SESubst.t) (_ : t) = @@ -193,12 +193,12 @@ module Make (State : SState.S) = struct in SVal.SESubst.init bindings - let fix_list_apply s = + let fix_list_apply (s : state_t) (asrt : Asrt.t) = let open Syntaxes.List in List.fold_left (fun acc a -> let* this_state = acc in - let lvars = Asrt.lvars a in + let lvars = Asrt.lvars [ a ] in let this_state = State.add_spec_vars this_state lvars in match a with | Asrt.Emp -> [ this_state ] @@ -213,12 +213,11 @@ module Make (State : SState.S) = struct | Some s -> State.assume_t s e t) (Some this_state) |> Option.to_list - | GA (corepred, ins, outs) -> + | CorePred (corepred, ins, outs) -> State.produce_core_pred corepred this_state (ins @ outs) - | Star _ -> raise (Failure "DEATH. fix_list_apply star") | Wand _ -> raise (Failure "DEATH. fix_list_apply wand") | Pred _ -> raise (Failure "DEATH. fix_list_apply pred")) - [ s ] + [ s ] asrt type post_res = (Flag.t * Asrt.t list) option @@ -258,7 +257,8 @@ module Make (State : SState.S) = struct "@[WARNING: Match Assertion Failed: %a with error: \ %a. CUR SUBST:@\n\ %a@]@\n" - Asrt.pp (fst step) State.pp_err err SVal.SESubst.pp subst); + Asrt.pp_atom (fst step) State.pp_err err SVal.SESubst.pp + subst); if not (State.can_fix err) then ( L.verbose (fun m -> m "CANNOT FIX!"); []) @@ -448,7 +448,7 @@ module Make (State : SState.S) = struct (* to throw errors: *) - let get_fixes (_ : err_t) : Asrt.t list list = + let get_fixes (_ : err_t) : Asrt.t list = raise (Failure "get_fixes not implemented in MakeBiState") let get_recovery_tactic (_ : t) (_ : err_t list) = @@ -461,7 +461,7 @@ module Make (State : SState.S) = struct (** new functions *) - let mem_constraints ({ state; _ } : t) : Formula.t list = + let mem_constraints ({ state; _ } : t) : Expr.t list = State.mem_constraints state let is_overlapping_asrt (a : string) : bool = State.is_overlapping_asrt a diff --git a/GillianCore/engine/FOLogic/FOSolver.ml b/GillianCore/engine/FOLogic/FOSolver.ml index f2bdd6ca..86b74963 100644 --- a/GillianCore/engine/FOLogic/FOSolver.ml +++ b/GillianCore/engine/FOLogic/FOSolver.ml @@ -5,25 +5,26 @@ module L = Logging * SATISFIABILITY * * **************** **) -let get_axioms (fs : Formula.Set.t) (_ : Type_env.t) : Formula.Set.t = - Formula.Set.fold - (fun (pf : Formula.t) (result : Formula.Set.t) -> +let get_axioms (fs : Expr.Set.t) (_ : Type_env.t) : Expr.Set.t = + Expr.Set.fold + (fun (pf : Expr.t) (result : Expr.Set.t) -> match pf with - | Eq (NOp (LstCat, x), NOp (LstCat, y)) -> - Formula.Set.add - (Reduction.reduce_formula - (Eq + | BinOp (NOp (LstCat, x), Equal, NOp (LstCat, y)) -> + Expr.Set.add + (Reduction.reduce_lexpr + (BinOp ( UnOp (LstLen, NOp (LstCat, x)), + Equal, UnOp (LstLen, NOp (LstCat, y)) ))) result | _ -> result) - fs Formula.Set.empty + fs Expr.Set.empty let simplify_pfs_and_gamma ?(matching = false) ?relevant_info - (fs : Formula.t list) - (gamma : Type_env.t) : Formula.Set.t * Type_env.t * SESubst.t = + (fs : Expr.t list) + (gamma : Type_env.t) : Expr.Set.t * Type_env.t * SESubst.t = let pfs, gamma = match (relevant_info, !Config.under_approximation) with | Some relevant_info, false -> @@ -33,10 +34,10 @@ let simplify_pfs_and_gamma in let subst, _ = Simplifications.simplify_pfs_and_gamma ~matching pfs gamma in let fs_lst = PFS.to_list pfs in - let fs_set = Formula.Set.of_list fs_lst in + let fs_set = Expr.Set.of_list fs_lst in (fs_set, gamma, subst) -let check_satisfiability_with_model (fs : Formula.t list) (gamma : Type_env.t) : +let check_satisfiability_with_model (fs : Expr.t list) (gamma : Type_env.t) : SESubst.t option = let fs, gamma, subst = simplify_pfs_and_gamma fs gamma in let model = Smt.check_sat fs (Type_env.as_hashtbl gamma) in @@ -48,7 +49,7 @@ let check_satisfiability_with_model (fs : Formula.t list) (gamma : Type_env.t) : in Expr.Set.union ac vs) Expr.Set.empty - (List.map Formula.lvars (Formula.Set.elements fs)) + (List.map Expr.lvars (Expr.Set.elements fs)) in let smt_vars = Expr.Set.diff lvars (SESubst.domain subst None) in L.( @@ -77,15 +78,15 @@ let check_satisfiability ?(matching = false) ?time:_ ?relevant_info - (fs : Formula.t list) + (fs : Expr.t list) (gamma : Type_env.t) : bool = (* let t = if time = "" then 0. else Sys.time () in *) L.verbose (fun m -> m "Entering FOSolver.check_satisfiability"); let fs, gamma, _ = simplify_pfs_and_gamma ?relevant_info ~matching fs gamma in let axioms = get_axioms fs gamma in - let fs = Formula.Set.union fs axioms in - if Formula.Set.is_empty fs then true - else if Formula.Set.mem False fs then false + let fs = Expr.Set.union fs axioms in + if Expr.Set.is_empty fs then true + else if Expr.Set.mem Expr.false_ fs then false else let result = Smt.is_sat fs (Type_env.as_hashtbl gamma) in (* if time <> "" then @@ -94,20 +95,18 @@ let check_satisfiability result let sat ~matching ~pfs ~gamma formula : bool = - let formula = Reduction.reduce_formula ~matching ~pfs ~gamma formula in - match formula with - | True -> - Logging.verbose (fun fmt -> fmt "Discharged sat before SMT"); - true - | False -> - Logging.verbose (fun fmt -> fmt "Discharged sat before SMT"); - false + let formula' = Reduction.reduce_lexpr ~matching ~pfs ~gamma formula in + match formula' with + | Lit (Bool b) -> + Logging.verbose (fun fmt -> + fmt "Discharged sat before SMT @[%a -> %b@]" Expr.pp formula b); + b | _ -> let relevant_info = - (Formula.pvars formula, Formula.lvars formula, Formula.locs formula) + (Expr.pvars formula', Expr.lvars formula', Expr.locs formula') in check_satisfiability ~matching ~relevant_info - (formula :: PFS.to_list pfs) + (formula' :: PFS.to_list pfs) gamma (** ************ @@ -118,7 +117,7 @@ let check_entailment ?(matching = false) (existentials : SS.t) (left_fs : PFS.t) - (right_fs : Formula.t list) + (right_fs : Expr.t list) (gamma : Type_env.t) : bool = L.verbose (fun m -> m @@ -157,7 +156,7 @@ let check_entailment let gamma_right = Type_env.filter gamma (fun v -> SS.mem v existentials) in (* If left side is false, return false *) - if List.mem Formula.False (left_fs @ right_fs) then false + if List.mem Expr.false_ (left_fs @ right_fs) then false else (* Check satisfiability of left side *) let left_sat = @@ -185,18 +184,18 @@ let check_entailment (* let axioms = get_axioms (left_fs @ right_fs) gamma in *) let right_fs = List.map - (fun f : Formula.t -> Formula.push_in_negations (Not f)) + (fun f : Expr.t -> Expr.push_in_negations (UnOp (Not, f))) right_fs in - let right_f : Formula.t = - if SS.is_empty existentials then Formula.disjunct right_fs + let right_f : Expr.t = + if SS.is_empty existentials then Expr.disjunct right_fs else let binders = List.map (fun x -> (x, Type_env.get gamma_right x)) (SS.elements existentials) in - ForAll (binders, Formula.disjunct right_fs) + ForAll (binders, Expr.disjunct right_fs) in let formulae = PFS.of_list (right_f :: (left_fs @ [] (* axioms *))) in @@ -204,7 +203,7 @@ let check_entailment let model = Smt.check_sat - (Formula.Set.of_list (PFS.to_list formulae)) + (Expr.Set.of_list (PFS.to_list formulae)) (Type_env.as_hashtbl gamma_left) in let ret = Option.is_none model in @@ -220,53 +219,54 @@ let check_entailment let is_equal ~pfs ~gamma e1 e2 = (* let t = Sys.time () in *) - let feq = - Reduction.reduce_formula ?gamma:(Some gamma) ?pfs:(Some pfs) (Eq (e1, e2)) - in + let feq = Reduction.reduce_lexpr ~gamma ~pfs (BinOp (e1, Equal, e2)) in let result = match feq with - | True -> true - | False -> false - | Eq _ | And _ -> check_entailment SS.empty pfs [ feq ] gamma + | Lit (Bool b) -> b + | BinOp (_, Equal, _) | BinOp (_, And, _) -> + check_entailment SS.empty pfs [ feq ] gamma | _ -> raise (Failure ("Equality reduced to something unexpected: " - ^ (Fmt.to_to_string Formula.pp) feq)) + ^ (Fmt.to_to_string Expr.pp) feq)) in (* Utils.Statistics.update_statistics "FOS: is_equal" (Sys.time () -. t); *) result let is_different ~pfs ~gamma e1 e2 = (* let t = Sys.time () in *) - let feq = Reduction.reduce_formula ~gamma ~pfs (Not (Eq (e1, e2))) in + let feq = + Reduction.reduce_lexpr ~gamma ~pfs (UnOp (Not, BinOp (e1, Equal, e2))) + in let result = match feq with - | True -> true - | False -> false - | Not _ -> check_entailment SS.empty pfs [ feq ] gamma + | Lit (Bool b) -> b + | Expr.UnOp (Not, _) -> check_entailment SS.empty pfs [ feq ] gamma | _ -> raise (Failure ("Inequality reduced to something unexpected: " - ^ (Fmt.to_to_string Formula.pp) feq)) + ^ (Fmt.to_to_string Expr.pp) feq)) in (* Utils.Statistics.update_statistics "FOS: is different" (Sys.time () -. t); *) result let num_is_less_or_equal ~pfs ~gamma e1 e2 = - let feq = Reduction.reduce_formula ~gamma ~pfs (FLessEq (e1, e2)) in + let feq = + Reduction.reduce_lexpr ~gamma ~pfs (Expr.BinOp (e1, FLessThanEqual, e2)) + in let result = match feq with - | True -> true - | False -> false - | Eq (ra, rb) -> is_equal ~pfs ~gamma ra rb - | FLessEq _ -> check_entailment SS.empty pfs [ feq ] gamma + | Lit (Bool b) -> b + | BinOp (ra, Equal, rb) -> is_equal ~pfs ~gamma ra rb + | BinOp (_, FLessThanEqual, _) -> + check_entailment SS.empty pfs [ feq ] gamma | _ -> raise (Failure ("Inequality reduced to something unexpected: " - ^ (Fmt.to_to_string Formula.pp) feq)) + ^ (Fmt.to_to_string Expr.pp) feq)) in result diff --git a/GillianCore/engine/FOLogic/FOSolver.mli b/GillianCore/engine/FOLogic/FOSolver.mli index 5dc8bcd7..7d294813 100644 --- a/GillianCore/engine/FOLogic/FOSolver.mli +++ b/GillianCore/engine/FOLogic/FOSolver.mli @@ -3,7 +3,7 @@ under the typing environment [gamma]. If this is the case, the function returns the appropriate logical environment. *) val check_satisfiability_with_model : - Gil_syntax.Formula.t list -> Type_env.t -> SVal.SESubst.t option + Gil_syntax.Expr.t list -> Type_env.t -> SVal.SESubst.t option (** [check_satisfiability ?matching pfs gamma] checks whether or not the pure formulae [pfs] are satisfiable @@ -13,13 +13,13 @@ val check_satisfiability : ?matching:bool -> ?time:string -> ?relevant_info:Containers.SS.t * Containers.SS.t * Containers.SS.t -> - Gil_syntax.Formula.t list -> + Gil_syntax.Expr.t list -> Type_env.t -> bool (** A different API for [check_satisfiability] better adapted for usage in memory models *) val sat : - matching:bool -> pfs:PFS.t -> gamma:Type_env.t -> Gil_syntax.Formula.t -> bool + matching:bool -> pfs:PFS.t -> gamma:Type_env.t -> Gil_syntax.Expr.t -> bool (** [check_entailment existentials lpfs rpfs gamma] checks whether or not the entailment << ∃ [existentials]. [lpfs] => [rpfs] >> holds @@ -28,7 +28,7 @@ val check_entailment : ?matching:bool -> Utils.Containers.SS.t -> PFS.t -> - Gil_syntax.Formula.t list -> + Gil_syntax.Expr.t list -> Type_env.t -> bool diff --git a/GillianCore/engine/FOLogic/PFS.ml b/GillianCore/engine/FOLogic/PFS.ml index 575bbe1a..f2f7dae6 100644 --- a/GillianCore/engine/FOLogic/PFS.ml +++ b/GillianCore/engine/FOLogic/PFS.ml @@ -1,24 +1,19 @@ open SVal module L = Logging -type t = Formula.t Ext_list.t [@@deriving yojson] +type t = Expr.t Ext_list.t [@@deriving yojson] let init () : t = Ext_list.make () - -let equal (pfs1 : t) (pfs2 : t) : bool = - Ext_list.for_all2 Formula.equal pfs1 pfs2 - -let to_list : t -> Formula.t list = Ext_list.to_list -let of_list : Formula.t list -> t = Ext_list.of_list +let equal (pfs1 : t) (pfs2 : t) : bool = Ext_list.for_all2 Expr.equal pfs1 pfs2 +let to_list : t -> Expr.t list = Ext_list.to_list +let of_list : Expr.t list -> t = Ext_list.of_list let to_set pfs = - Ext_list.fold_left - (fun acc el -> Formula.Set.add el acc) - Formula.Set.empty pfs + Ext_list.fold_left (fun acc el -> Expr.Set.add el acc) Expr.Set.empty pfs -let mem (pfs : t) (f : Formula.t) = Ext_list.mem ~equal:Formula.equal f pfs +let mem (pfs : t) (f : Expr.t) = Ext_list.mem ~equal:Expr.equal f pfs -let extend (pfs : t) (a : Formula.t) : unit = +let extend (pfs : t) (a : Expr.t) : unit = if not (mem pfs a) then Ext_list.add a pfs let clear (pfs : t) : unit = Ext_list.clear pfs @@ -26,37 +21,38 @@ let length (pfs : t) = Ext_list.length pfs let copy (pfs : t) : t = Ext_list.copy pfs let merge_into_left (pfs_l : t) (pfs_r : t) : unit = Ext_list.concat pfs_l pfs_r -let set (pfs : t) (reset : Formula.t list) : unit = +let set (pfs : t) (reset : Expr.t list) : unit = clear pfs; merge_into_left pfs (of_list reset) let substitution (subst : SESubst.t) (pfs : t) : unit = - Ext_list.map_inplace (SESubst.substitute_formula ~partial:true subst) pfs + Ext_list.map_inplace (SESubst.subst_in_expr ~partial:true subst) pfs let subst_expr_for_expr (to_subst : Expr.t) (subst_with : Expr.t) (pfs : t) : unit = - Ext_list.map_inplace (Formula.subst_expr_for_expr ~to_subst ~subst_with) pfs + Ext_list.map_inplace (Expr.subst_expr_for_expr ~to_subst ~subst_with) pfs let lvars (pfs : t) : SS.t = - Ext_list.fold_left (fun ac a -> SS.union ac (Formula.lvars a)) SS.empty pfs + Ext_list.fold_left (fun ac a -> SS.union ac (Expr.lvars a)) SS.empty pfs let alocs (pfs : t) : SS.t = - Ext_list.fold_left (fun ac a -> SS.union ac (Formula.alocs a)) SS.empty pfs + Ext_list.fold_left (fun ac a -> SS.union ac (Expr.alocs a)) SS.empty pfs let clocs (pfs : t) : SS.t = - Ext_list.fold_left (fun ac a -> SS.union ac (Formula.clocs a)) SS.empty pfs + Ext_list.fold_left (fun ac a -> SS.union ac (Expr.clocs a)) SS.empty pfs -let pp = Fmt.vbox (Ext_list.pp ~sep:Fmt.cut Formula.pp) +let pp = Fmt.vbox (Ext_list.pp ~sep:Fmt.cut Expr.pp) let sort (p_formulae : t) : unit = let pfl = to_list p_formulae in let var_eqs, llen_eqs, others = List.fold_left - (fun (var_eqs, llen_eqs, others) (pf : Formula.t) -> + (fun (var_eqs, llen_eqs, others) (pf : Expr.t) -> match pf with - | Eq (LVar _, _) | Eq (_, LVar _) -> (pf :: var_eqs, llen_eqs, others) - | Eq (UnOp (LstLen, _), _) | Eq (_, UnOp (LstLen, _)) -> - (var_eqs, pf :: llen_eqs, others) + | BinOp (LVar _, Equal, _) | BinOp (_, Equal, LVar _) -> + (pf :: var_eqs, llen_eqs, others) + | BinOp (UnOp (LstLen, _), Equal, _) | BinOp (_, Equal, UnOp (LstLen, _)) + -> (var_eqs, pf :: llen_eqs, others) | _ -> (var_eqs, llen_eqs, pf :: others)) ([], [], []) pfl in @@ -78,9 +74,10 @@ let get_nth = Ext_list.nth let clean_up pfs = Ext_list.filter - (fun (pf : Formula.t) -> + (fun (pf : Expr.t) -> match pf with - | Formula.ILessEq (Lit (Int x), UnOp (LstLen, _)) when x = Z.zero -> false + | Expr.BinOp (Lit (Int x), BinOp.ILessThanEqual, UnOp (LstLen, _)) + when x = Z.zero -> false | _ -> true) pfs @@ -90,10 +87,10 @@ let rec get_relevant_info (_ : SS.t) (lvars : SS.t) (locs : SS.t) (pfs : t) : let new_pvars, new_lvars, new_locs = fold_left (fun (new_pvars, new_lvars, new_locs) pf -> - let pf_pvars, pf_lvars, pf_locs = Formula.get_print_info pf in - let pf_relevant = - List.fold_left SS.union SS.empty [ pf_pvars; pf_lvars; pf_locs ] - in + let pf_pvars = Expr.pvars pf in + let pf_lvars = Expr.lvars pf in + let pf_locs = Expr.locs pf in + let pf_relevant = SS.union pf_pvars (SS.union pf_lvars pf_locs) in if SS.inter relevant pf_relevant = SS.empty then (new_pvars, new_lvars, new_locs) else @@ -116,9 +113,9 @@ let filter_with_info relevant_info (pfs : t) : t = let () = filter (fun pf -> - not - (SS.is_empty - (SS.inter relevant (SS.union (Formula.lvars pf) (Formula.locs pf))))) + let pf_info = SS.union (Expr.lvars pf) (Expr.locs pf) in + let overlap = SS.inter relevant pf_info in + not @@ SS.is_empty overlap) filtered_pfs in filtered_pfs diff --git a/GillianCore/engine/FOLogic/PFS.mli b/GillianCore/engine/FOLogic/PFS.mli index 7d08ef05..d7fd46a2 100644 --- a/GillianCore/engine/FOLogic/PFS.mli +++ b/GillianCore/engine/FOLogic/PFS.mli @@ -1,5 +1,5 @@ (** @canonical Gillian.Symbolic.Pure_context - + GIL pure formulae *) (** @canonical Gillian.Symbolic.Pure_context.t *) @@ -12,18 +12,18 @@ val init : unit -> t val equal : t -> t -> bool (** [to_list pfs] serialises the pure formulae [pfs] into a list *) -val to_list : t -> Formula.t list +val to_list : t -> Expr.t list (** [of_list fs] deserialises a list of formulae [fs] into pure formulae *) -val of_list : Formula.t list -> t +val of_list : Expr.t list -> t -val to_set : t -> Formula.Set.t +val to_set : t -> Expr.Set.t (** [mem pfs f] return true iff the formula [f] is part of the pure formulae [pfs] *) -val mem : t -> Formula.t -> bool +val mem : t -> Expr.t -> bool (** [extend pfs f] extends the pure formulae [pfs] with the formula [f] *) -val extend : t -> Formula.t -> unit +val extend : t -> Expr.t -> unit (* (** [nth_get pfs n] returns the n-th pure formula of [pfs] *) @@ -48,16 +48,16 @@ val copy : t -> t val merge_into_left : t -> t -> unit (** [set pfs fs] sets the pure formulae [pfs] to [fs] *) -val set : t -> Formula.t list -> unit +val set : t -> Expr.t list -> unit (** [iter f pfs] iterates over the pure formulae [pfs] using the function [f] *) -val iter : (Formula.t -> unit) -> t -> unit +val iter : (Expr.t -> unit) -> t -> unit (** [fold_left f ac pfs] folds over the pure formulae [pfs] using the function [f] and initial accumulator [ac] *) -val fold_left : ('a -> Formula.t -> 'a) -> 'a -> t -> 'a +val fold_left : ('a -> Expr.t -> 'a) -> 'a -> t -> 'a (** [map_inplace f pfs] is like a map operation, but performing in place *) -val map_inplace : (Formula.t -> Formula.t) -> t -> unit +val map_inplace : (Expr.t -> Expr.t) -> t -> unit (** [substitution subst pfs] substitutes the substutition subst in the pure formulae [pfs] in-place *) val substitution : SVal.SESubst.t -> t -> unit @@ -103,16 +103,16 @@ val get_relevant_info : Containers.SS.t * Containers.SS.t * Containers.SS.t val filter_map_stop : - (Formula.t -> [ `Stop | `Filter | `Replace of Formula.t ]) -> t -> bool + (Expr.t -> [ `Stop | `Filter | `Replace of Expr.t ]) -> t -> bool (** See Gillian.Utils.Ext_list.filter_stop_cond *) val filter_stop_cond : - keep:(Formula.t -> bool) -> cond:(Formula.t -> bool) -> t -> bool + keep:(Expr.t -> bool) -> cond:(Expr.t -> bool) -> t -> bool -val filter : (Formula.t -> bool) -> t -> unit -val filter_map : (Formula.t -> Formula.t option) -> t -> unit -val exists : (Formula.t -> bool) -> t -> bool +val filter : (Expr.t -> bool) -> t -> unit +val filter_map : (Expr.t -> Expr.t option) -> t -> unit +val exists : (Expr.t -> bool) -> t -> bool (** Gets the nths formula. There are very few good use cases for this function, and uses should generaly use iterators instead. O(n) *) -val get_nth : int -> t -> Formula.t option +val get_nth : int -> t -> Expr.t option diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index f742a342..19e2aa58 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -38,9 +38,8 @@ let normalise_cat (f : Expr.t -> Expr.t) (les : Expr.t list) : Expr.t = (* Filter out empty lists *) let nles = List.filter - (fun (x : Expr.t) -> - match x with - | Lit (LList []) | EList [] -> false + (function + | Expr.Lit (LList []) | EList [] -> false | _ -> true) nles in @@ -136,7 +135,7 @@ let rec normalise_list_expressions (le : Expr.t) : Expr.t = | ESet lst -> ESet (List.map f lst) | LstSub (le1, le2, le3) -> LstSub (f le1, f le2, f le3) | Exists (bt, le) -> Exists (bt, f le) - | EForall (bt, le) -> EForall (bt, f le) + | ForAll (bt, le) -> ForAll (bt, f le) (* | LstSub(le1, le2, le3) -> (match f le1, f le2, f le3 with @@ -159,11 +158,11 @@ let rec normalise_list_expressions (le : Expr.t) : Expr.t = _____________________________________________________ *) -let resolve_list (le : Expr.t) (pfs : Formula.t list) : Expr.t = +let resolve_list (le : Expr.t) (pfs : Expr.t list) : Expr.t = let rec search x pfs = - match (pfs : Formula.t list) with + match (pfs : Expr.t list) with | [] -> None - | Eq (LVar x', le) :: rest when String.equal x' x -> ( + | BinOp (LVar x', Equal, le) :: rest when String.equal x' x -> ( let le' = normalise_list_expressions le in match le' with (* Weird things can happen where x reduces to e.g. `{{ l-nth(x, 0) }}`. @@ -173,7 +172,7 @@ let resolve_list (le : Expr.t) (pfs : Formula.t list) : Expr.t = | Expr.BinOp (_, LstRepeat, _) as ret when not (SS.mem x (Expr.lvars ret)) -> Some ret | _ -> search x rest) - | Eq (le, LVar x') :: rest when String.equal x' x -> ( + | BinOp (le, Equal, LVar x') :: rest when String.equal x' x -> ( let le' = normalise_list_expressions le in match le' with | (EList _ | NOp (LstCat, _)) when not (SS.mem x (Expr.lvars le')) -> @@ -199,7 +198,7 @@ let find_equalities (pfs : PFS.t) (le : Expr.t) : Expr.t list = List.find_all (fun x -> match x with - | Formula.Eq (x, y) -> Expr.equal x le || Expr.equal y le + | Expr.BinOp (x, Equal, y) -> Expr.equal x le || Expr.equal y le | _ -> false) lpfs in @@ -207,7 +206,7 @@ let find_equalities (pfs : PFS.t) (le : Expr.t) : Expr.t list = List.map (fun x -> match x with - | Formula.Eq (x, y) -> if Expr.equal x le then y else x + | Expr.BinOp (x, Equal, y) -> if Expr.equal x le then y else x | _ -> raise (Exceptions.Impossible @@ -222,8 +221,7 @@ let find_equalities (pfs : PFS.t) (le : Expr.t) : Expr.t list = let typable (gamma : Type_env.t) (le : Expr.t) (target_type : Type.t) : bool = let t, success = Typing.type_lexpr gamma le in - if success then - Option.fold ~some:(fun t -> Type.equal t target_type) ~none:true t + if success then Option.fold ~some:(Type.equal target_type) ~none:true t else let msg : string = Fmt.str "TYPE ERROR: %a not typable in typing environment %a" Expr.pp le @@ -259,10 +257,10 @@ let get_equal_expressions (pfs : PFS.t) nle = List.rev (PFS.fold_left (fun ac a -> - match (a : Formula.t) with - | Eq (le1, le2) when Expr.equal le1 nle -> le2 :: ac - | Eq (le2, le1) when Expr.equal le1 nle -> le2 :: ac - | Eq (e, EList el) | Eq (EList el, e) -> ( + match (a : Expr.t) with + | BinOp (le1, Equal, le2) when Expr.equal le1 nle -> le2 :: ac + | BinOp (le2, Equal, le1) when Expr.equal le1 nle -> le2 :: ac + | BinOp (e, Equal, EList el) | BinOp (EList el, Equal, e) -> ( match List_utils.index_of nle el with | None -> ac | Some index -> Expr.list_nth e index :: ac) @@ -346,17 +344,17 @@ let rec get_nth_of_list (pfs : PFS.t) (lst : Expr.t) (idx : int) : Expr.t option (* Finding the nth element of a list *) let get_head_and_tail_of_list ~pfs lst = - let rec loop (pfs : PFS.t) (unacceptable : Expr.Set.t) (lst : Expr.t) : + let rec loop (pfs : PFS.t) (checked : Expr.Set.t) (lst : Expr.t) : (Expr.t * Expr.t) option = - let loop = loop pfs (Expr.Set.add lst unacceptable) in + let loop = loop pfs (Expr.Set.add lst checked) in match lst with (* Nothing can be done for variables *) (* FIXME: This function is suboptimal *) | PVar _ -> None | LVar _ -> ( - let ole = get_equal_expressions pfs lst in let ole = - List.filter (fun x -> not (Expr.Set.mem x unacceptable)) ole + get_equal_expressions pfs lst + |> List.filter (fun x -> not (Expr.Set.mem x checked)) in match ole with | [] -> None @@ -364,14 +362,14 @@ let get_head_and_tail_of_list ~pfs lst = L.verbose (fun fmt -> fmt "LE: %a\n\n" Expr.pp le); loop le) (* Base lists of literals and logical expressions *) - | Lit (LList l) -> - if l = [] then None else Some (Lit (List.hd l), Lit (LList (List.tl l))) - | EList l -> if l = [] then None else Some (List.hd l, EList (List.tl l)) + | Lit (LList []) -> None + | Lit (LList (hd :: tl)) -> Some (Lit hd, Lit (LList tl)) + | EList [] -> None + | EList (hd :: tl) -> Some (hd, EList tl) | NOp (LstCat, lel :: ler) -> - Option.value ~default:None - (Option.map - (fun (hd, tl) -> Some (hd, Expr.NOp (LstCat, tl :: ler))) - (loop lel)) + Option.map + (fun (hd, tl) -> (hd, Expr.NOp (LstCat, tl :: ler))) + (loop lel) | _ -> None in loop pfs Expr.Set.empty lst @@ -390,12 +388,12 @@ let rec get_length_of_string (str : Expr.t) : int option = | Lit (String s) -> Some (String.length s) | BinOp (sl, StrCat, sr) -> Option.value ~default:None - (Option.map (fun ll -> Option.map (fun lr -> ll + lr) (f sr)) (f sl)) + (Option.map (fun ll -> Option.map (( + ) ll) (f sr)) (f sl)) | _ -> raise (Failure - (Printf.sprintf "get_length_of_string: string equals %s, impossible" - ((Fmt.to_to_string Expr.pp) str))) + (Fmt.str "get_length_of_string: string equals %a, impossible" Expr.pp + str)) (* Finding the nth element of a list *) let rec get_nth_of_string (str : Expr.t) (idx : int) : Expr.t option = @@ -405,11 +403,10 @@ let rec get_nth_of_string (str : Expr.t) (idx : int) : Expr.t option = (* If we can compute the length of the list, then the index needs to be compatible *) let olen = get_length_of_string str in - let _ = + let () = match olen with - | None -> () - | Some len -> - if len <= idx then raise (ReductionException (Lit Nono, err_msg)) + | Some len when len <= idx -> raise (ReductionException (Lit Nono, err_msg)) + | _ -> () in let result : Expr.t option = @@ -422,19 +419,14 @@ let rec get_nth_of_string (str : Expr.t) (idx : int) : Expr.t option = assert (idx < String.length s); Some (Lit (String (String.sub s idx 1))) | BinOp (ls, StrCat, rs) -> - Option.value ~default:None - (Option.map - (fun llen -> - let lst, idx = - if idx < llen then (ls, idx) else (rs, idx - llen) - in - f lst idx) - (get_length_of_string ls)) + Option.bind (get_length_of_string ls) (fun llen -> + let lst, idx = if idx < llen then (ls, idx) else (rs, idx - llen) in + f lst idx) | _ -> raise (Failure - (Printf.sprintf "get_nth_of_string: string equals %s, impossible" - ((Fmt.to_to_string Expr.pp) str))) + (Fmt.str "get_nth_of_string: string equals %a, impossible" Expr.pp + str)) in result @@ -442,8 +434,7 @@ let rec get_nth_of_string (str : Expr.t) (idx : int) : Expr.t option = (* SET REASONING HELPER FUNCTIONS *) (**********************************) -let is_different (pfs : Formula.t list) (li : Expr.t) (lj : Expr.t) : - bool option = +let is_different (pfs : Expr.t list) (li : Expr.t) (lj : Expr.t) : bool option = match li = lj with | true -> Some false | false -> ( @@ -459,29 +450,29 @@ let is_different (pfs : Formula.t list) (li : Expr.t) (lj : Expr.t) : -> Some true | _, _ -> if - List.mem (Formula.Not (Formula.Eq (li, lj))) pfs - || List.mem (Formula.Not (Formula.Eq (lj, li))) pfs + List.mem (Expr.UnOp (Not, BinOp (li, Equal, lj))) pfs + || List.mem (Expr.UnOp (Not, BinOp (lj, Equal, li))) pfs then Some true else None) (* I dont understand this! *) -let rec set_member (pfs : Formula.t list) m s = +let rec set_member (pfs : Expr.t list) m s = let f = set_member pfs m in match s with | Expr.LVar _ -> m = s | Expr.ESet s -> List.mem m s - | Expr.NOp (SetUnion, les) -> List.exists (fun x -> f x) les - | Expr.NOp (SetInter, les) -> List.for_all (fun x -> f x) les - | _ -> List.mem (Formula.SetMem (m, s)) pfs + | Expr.NOp (SetUnion, les) -> List.exists f les + | Expr.NOp (SetInter, les) -> List.for_all f les + | _ -> List.mem (Expr.BinOp (m, SetMem, s)) pfs let rec not_set_member pfs m s = let f = not_set_member pfs m in match s with - | Expr.NOp (SetUnion, les) -> List.for_all (fun x -> f x) les - | Expr.NOp (SetInter, les) -> List.exists (fun x -> f x) les + | Expr.NOp (SetUnion, les) -> List.for_all f les + | Expr.NOp (SetInter, les) -> List.exists f les | Expr.ESet les -> List.for_all (fun le -> is_different pfs m le = Some true) les - | _ -> List.mem (Formula.Not (Formula.SetMem (m, s))) pfs + | _ -> List.mem (Expr.UnOp (Not, BinOp (m, SetMem, s))) pfs let rec set_subset pfs s s' = let f = set_subset pfs s in @@ -494,20 +485,16 @@ let rec set_subset pfs s s' = | Expr.ESet les -> List.for_all (fun x -> set_member pfs x s') les | _ -> false) -let rec contained_in_union (pfs : Formula.t list) (le1 : Expr.t) (le2 : Expr.t) - = +let rec contained_in_union (pfs : Expr.t list) (le1 : Expr.t) (le2 : Expr.t) = L.( tmi (fun m -> m "Contained in union: %s %s" ((Fmt.to_to_string Expr.pp) le1) ((Fmt.to_to_string Expr.pp) le2))); - match le2 with - | LVar _ -> ( - match pfs with - | [] -> false - | Eq (le, NOp (SetUnion, les)) :: rest when le = le2 -> - if List.mem le1 les then true else contained_in_union rest le1 le2 - | _ :: rest -> contained_in_union rest le1 le2) + match (le2, pfs) with + | LVar _, BinOp (le, Equal, NOp (SetUnion, les)) :: _ + when le = le2 && List.mem le1 les -> true + | LVar _, _ :: rest -> contained_in_union rest le1 le2 | _ -> false let all_different pfs les = @@ -602,20 +589,16 @@ let prefix_catch pfs (x : Expr.t) (y : string) = match x with | NOp (LstCat, x) -> PFS.exists - (fun pf -> - match pf with - | Eq (NOp (LstCat, lx), NOp (LstCat, LVar y' :: _)) when y = y' -> ( - match List_utils.list_sub lx 0 (List.length x) with - | Some x' -> x' = x - | _ -> false) + (function + | BinOp (NOp (LstCat, lx), Equal, NOp (LstCat, LVar y' :: _)) + when y = y' -> List_utils.list_sub lx 0 (List.length x) = Some x | _ -> false) pfs | LVar x -> PFS.exists - (fun pf -> - match pf with - | Eq (NOp (LstCat, LVar x' :: _), NOp (LstCat, LVar y' :: _)) -> - (x' = x && y = y') || (y' = x && x' = y) + (function + | BinOp (NOp (LstCat, LVar x' :: _), Equal, NOp (LstCat, LVar y' :: _)) + -> (x' = x && y = y') || (y' = x && x' = y) | _ -> false) pfs | _ -> false @@ -736,16 +719,13 @@ module Canonical = struct (fun e vr (restl, restr) -> match Expr.Map.find_opt e restl with | None -> (restl, restr) - | Some vl -> ( - match vl = vr with - | true -> (Expr.Map.remove e restl, Expr.Map.remove e restr) - | false -> - if vl > vr then - ( Expr.Map.add e (P.sub vl vr) restl, - Expr.Map.remove e restr ) - else - ( Expr.Map.remove e restl, - Expr.Map.add e (P.sub vr vl) restr ))) + | Some vl -> + if vl = vr then + (Expr.Map.remove e restl, Expr.Map.remove e restr) + else if vl > vr then + (Expr.Map.add e (P.sub vl vr) restl, Expr.Map.remove e restr) + else + (Expr.Map.remove e restl, Expr.Map.add e (P.sub vr vl) restr)) cr.symb (cl.symb, cr.symb) in let cl, cr = ({ conc = nl; symb = restl }, { conc = nr; symb = restr }) in @@ -853,8 +833,8 @@ let find_list_length_eqs (pfs : PFS.t) (e : Expr.t) : Cint.t list = PFS.fold_left (fun found pf -> match pf with - | Eq (e1, e2) when e1 = llen_expr -> Cint.of_expr e2 :: found - | Eq (e1, e2) when e2 = llen_expr -> Cint.of_expr e1 :: found + | BinOp (e1, Equal, e2) when e1 = llen_expr -> Cint.of_expr e2 :: found + | BinOp (e1, Equal, e2) when e2 = llen_expr -> Cint.of_expr e1 :: found | _ -> found) [] pfs in @@ -900,6 +880,7 @@ let rec reduce_binop_inttonum_const - gamma is used for: - pfs are used for: Car, Cdr, SetDiff *) +(* TODO: can this whole mess be removed since we did sth similar with formulae? *) and reduce_lexpr_loop ?(matching = false) ?(reduce_lvars = false) @@ -917,498 +898,152 @@ and reduce_lexpr_loop let result : Expr.t = match le with - | Lit _ -> le - | BinOp (BinOp (a, FTimes, _), FMod, c) - when Expr.equal a c || Expr.equal a c -> Expr.num 0. - | BinOp (x, FTimes, BinOp (y, FDiv, z)) when x = z -> f y - | BinOp (BinOp (x, FDiv, y), FTimes, z) when y = z -> f x - | BinOp (Lit (LList ll), Equal, Lit (LList lr)) -> Lit (Bool (ll = lr)) - | BinOp (left, BImpl, right) -> ( - let left = f left in - match Formula.lift_logic_expr left with - | None -> BinOp (left, BImpl, f right) - | Some (True, _) -> f right - | Some (False, _) -> Lit (Bool true) - | Some (left_f, _) -> - let pfs_with_left = - let copy = PFS.copy pfs in - let () = PFS.extend copy left_f in - copy - in - let right = - reduce_lexpr_loop ~matching ~reduce_lvars pfs_with_left gamma - right - in - BinOp (left, BImpl, right)) - | BinOp (EList le, Equal, Lit (LList ll)) - | BinOp (Lit (LList ll), Equal, EList le) -> - if List.length ll <> List.length le then Lit (Bool false) - else if ll = [] then Lit (Bool true) - else - let eqs = List.map2 (fun x y -> Expr.BinOp (x, Equal, Lit y)) le ll in - let conj = - List.fold_left - (fun ac x -> Expr.BinOp (ac, BAnd, x)) - (List.hd eqs) (List.tl eqs) - in - f conj - | BinOp (EList ll, Equal, EList lr) -> - if List.length ll <> List.length lr then Lit (Bool false) - else if ll = [] then Lit (Bool true) - else - let eqs = List.map2 (fun x y -> Expr.BinOp (x, Equal, y)) ll lr in - let conj = - List.fold_left - (fun ac x -> Expr.BinOp (ac, BAnd, x)) - (List.hd eqs) (List.tl eqs) - in - f conj - | BinOp (ALoc x, Equal, ALoc y) when not matching -> Lit (Bool (x = y)) - | LVar x when reduce_lvars -> ( - let equals = get_equal_expressions pfs (LVar x) in - let lit_equals = - List.filter - (fun eq -> - match eq with - | Expr.Lit _ -> true - | _ -> false) - equals - in - match lit_equals with - | [] -> LVar x - | Lit l :: _ -> Lit l - | _ -> - raise - (Exceptions.Impossible - "reduce_lexpr: LVar x when reducing lvars: guaranteed by \ - match/filter")) - (* Base lists *) - | EList les -> ( - let fles = List.map f les in - let all_literals = - let rec loop l = - match l with - | [] -> Some [] - | Expr.Lit l :: r -> Option.map (fun x -> l :: x) (loop r) - | _ -> None - in - loop fles + (* ------------------------- + Base cases + ------------------------- *) + | Lit _ | PVar _ | ALoc _ -> le + (* ------------------------- + LVar + ------------------------- *) + | LVar _ when reduce_lvars -> + get_equal_expressions pfs le + |> List.find_opt (function + | Expr.Lit _ -> true + | _ -> false) + |> Option.value ~default:le + | LVar _ -> le + (* ------------------------- + EList + ------------------------- *) + | EList les -> List.map f les |> Expr.list + (* ------------------------- + ESet + ------------------------- *) + | ESet les -> ESet (Expr.Set.elements @@ Expr.Set.of_list @@ List.map f les) + (* ------------------------- + ForAll + Exists + ------------------------- *) + (* Given: l = [l0, l1, ..., ln] + Before: ∀ i∈ℕ. i<0 ∨ len(l)<=i ∨ l[i]==e + After: l==[e, e, ..., e] *) + | ForAll + ( [ (x, Some IntType) ], + BinOp + ( BinOp + ( BinOp (LVar a, ILessThan, Lit (Int z)), + Or, + BinOp (Lit (Int len), ILessThanEqual, LVar b) ), + Or, + BinOp (BinOp (EList c, LstNth, LVar d), Equal, e) ) ) + when Z.equal z Z.zero && String.equal x a && String.equal a b + && String.equal b d + && Int.equal (List.compare_length_with c (Z.to_int len)) 0 -> + let rhs = Expr.EList (List_utils.make (Z.to_int len) e) in + BinOp (EList c, Equal, rhs) + (* Given: l = [l0, l1, ..., ln] + Before: ∀ i∈ℕ. (0<=i ∧ i l[i]==k + After: l0=k ∧ l1=k ∧ ... ∧ ln=k *) + | ForAll + ( [ (i, Some IntType) ], + BinOp + ( BinOp + ( BinOp (Lit (Int z), ILessThanEqual, LVar i'), + And, + BinOp (LVar i'', ILessThan, UnOp (LstLen, (EList ll as l))) ), + Impl, + BinOp (BinOp (l', LstNth, LVar i'''), Equal, k) ) ) + when Z.(equal z zero) + && i = i' && i' = i'' && i'' = i''' && Expr.equal l l' -> + List.map (Expr.Infix.( == ) k) ll |> Expr.conjunct + | ForAll (bt, e) | Exists (bt, e) -> ( + (* We create a new pfs and gamma where: + - All shadowed variables are substituted with a fresh variable + - The gamma has been updated with the types given in the binder *) + let new_gamma = Type_env.copy gamma in + let new_pfs = PFS.copy pfs in + let subst_bindings = List.map (fun (x, _) -> (x, LVar.alloc ())) bt in + let subst = + SVal.SESubst.init + (List.map (fun (x, y) -> (Expr.LVar x, Expr.LVar y)) subst_bindings) in - match all_literals with - | Some lits -> Expr.Lit (LList lits) - | None -> EList fles) - (* Base sets *) - | ESet les -> ESet (Expr.Set.elements (Expr.Set.of_list (List.map f les))) - | UnOp (NumToInt, UnOp (IntToNum, le)) -> f le - | UnOp (IntToNum, UnOp (NumToInt, le)) when PFS.mem pfs (IsInt le) -> f le - (* Number-to-string-to-number-to-string-to... *) - | UnOp (ToNumberOp, UnOp (ToStringOp, le)) -> ( - let fle = f le in - match fle with - | Lit (Num _) -> fle - | fle -> ( - let tfle, how = Typing.type_lexpr gamma fle in - match (how, tfle) with - | true, Some NumberType -> fle - | _, _ -> UnOp (ToNumberOp, UnOp (ToStringOp, fle)))) - | UnOp (LstRev, UnOp (LstRev, le)) -> f le - (* Less than and lessthaneq *) - | UnOp (UNot, BinOp (le1, FLessThan, le2)) -> - f (BinOp (f le2, FLessThanEqual, f le1)) - | UnOp (UNot, BinOp (le1, FLessThanEqual, le2)) -> - f (BinOp (f le2, FLessThan, f le1)) - (* Special equality *) - | BinOp - (BinOp (LVar x, FPlus, UnOp (FUnaryMinus, LVar y)), Equal, Lit (Num 0.)) - -> BinOp (LVar x, Equal, LVar y) - | BinOp - (BinOp (LVar x, IPlus, UnOp (IUnaryMinus, LVar y)), Equal, Lit (Int z)) - when Z.equal z Z.zero -> BinOp (LVar x, Equal, LVar y) - (* List indexing *) - | BinOp (le, LstNth, idx) -> ( - let fle = f le in - let fidx = f idx in - match fidx with - (* Index is a non-negative integer *) - | Lit (Int n) when Z.leq Z.zero n -> - if lexpr_is_list gamma fle then - Option.value - ~default:(Expr.BinOp (fle, LstNth, fidx)) - (get_nth_of_list pfs fle (Z.to_int n)) - else - let err_msg = - Fmt.str "LstNth(%a, %a): list is not a GIL list." Expr.pp fle - Expr.pp idx - in - L.normal (fun fmt -> fmt "%s" err_msg); - raise (ReductionException (BinOp (fle, LstNth, fidx), err_msg)) - (* Index is a number, but is either not an integer or is negative *) - | Lit (Int _) | Lit (Num _) -> - let err_msg = - "LstNth(list, index): index is smaller than zero or a float." + List.iter + (fun (x, t) -> + let () = + match Type_env.get new_gamma x with + | Some t -> + let new_var = List.assoc x subst_bindings in + Type_env.update new_gamma new_var t + | None -> () in - raise (ReductionException (BinOp (fle, LstNth, fidx), err_msg)) - (* All other cases *) - | _ -> BinOp (fle, LstNth, fidx)) - (* String indexing *) - | BinOp (le, StrNth, idx) -> ( - let fle = f le in - let fidx = f idx in - match fidx with - (* Index is a non-negative integer *) - | Lit (Num n) when Arith_utils.is_int n && 0. <= n -> ( - match lexpr_is_string gamma fle with - | true -> - Option.value - ~default:(Expr.BinOp (fle, StrNth, fidx)) - (get_nth_of_string fle (int_of_float n)) - | false -> - let err_msg = - "StrNth(str, index): string is not a GIL string." - in - raise - (ReductionException (Expr.BinOp (fle, StrNth, fidx), err_msg)) - ) - (* Index is a number, but is either not an integer or is negative *) - | Lit (Num _) -> - let err_msg = - "StrNth(str, index): index is non-integer or smaller than zero." - in - raise (ReductionException (Expr.BinOp (fle, StrNth, fidx), err_msg)) - (* All other cases *) - | _ -> BinOp (fle, StrNth, fidx)) - | NOp (SetUnion, les) -> ( - let fles = List.map f les in - (* Flatten unions *) - let unions, rest = - List.partition - (fun x -> - match x with - | Expr.NOp (SetUnion, _) -> true - | _ -> false) - fles - in - let unions = - List.fold_left - (fun ac u -> - let ls = - match u with - | Expr.NOp (SetUnion, ls) -> ls - | _ -> - raise (Failure "LSetUnion: flattening unions: impossible.") - in - ac @ ls) - [] unions - in - let fles = unions @ rest in - (* Join ESets *) - let lesets, rest = - List.partition - (fun x -> - match x with - | Expr.ESet _ -> true - | _ -> false) - fles - in - let lesets = - List.fold_left - (fun ac u -> - let ls = - match u with - | Expr.ESet ls -> ls - | _ -> raise (Failure "LSetUnion: joining ESets: impossible.") - in - ac @ ls) - [] lesets - in - let lesets = Expr.Set.elements (Expr.Set.of_list lesets) in - let fles = Expr.ESet lesets :: rest in - (* Remove empty sets *) - let fles = - List.filter - (function - | Expr.ESet [] -> false - | _ -> true) - fles - in - (* Remove duplicates *) - let fles = Expr.Set.elements (Expr.Set.of_list fles) in - match fles with - | [] -> ESet [] - | [ x ] -> x - | _ -> NOp (SetUnion, fles)) - | BinOp (x, LstRepeat, Lit (Int i)) when Z.lt i (Z.of_int 100) -> - let fx = f x in - let result = List.init (Z.to_int i) (fun _ -> fx) in - EList result - | NOp (LstCat, LstSub (x1, Lit (Int z), z1) :: LstSub (x2, y2, z3) :: rest) - when Z.equal z Z.zero && Expr.equal x1 x2 && Expr.equal z1 y2 -> - f - (NOp (LstCat, LstSub (x1, Expr.zero_i, BinOp (z1, IPlus, z3)) :: rest)) - | NOp (LstCat, fst :: rest) when PFS.mem pfs (Eq (fst, EList [])) -> - f (NOp (LstCat, rest)) - | NOp (LstCat, [ x; LstSub (LVar y, UnOp (LstLen, x'), len) ]) - when x = x' - && Cint.canonicalise len - = Cint.canonicalise - (BinOp (UnOp (LstLen, LVar y), IMinus, UnOp (LstLen, x))) - && prefix_catch pfs x y -> LVar y - | NOp (LstCat, les) -> normalise_cat f les - | NOp (SetInter, [ BinOp (le1, SetDiff, le2); ESet le3 ]) -> - f (NOp (SetInter, [ le2; BinOp (ESet le3, SetDiff, le1) ])) - | NOp (SetInter, les) -> ( - let fles = List.map f les in - (* Flatten intersections *) - let inters, rest = - List.partition - (fun x -> - match x with - | Expr.NOp (SetInter, _) -> true - | _ -> false) - fles - in - let inters = - List.fold_left - (fun ac u -> - let ls = - match u with - | Expr.NOp (SetInter, ls) -> ls - | _ -> - raise - (Failure - "LSetInter: flattening intersections: impossible.") - in - ac @ ls) - [] inters - in - let fles = inters @ rest in - (* Join ESets *) - let lesets, rest = - List.partition - (fun x -> - match x with - | Expr.ESet _ -> true - | _ -> false) - fles - in - let lesets = - List.fold_left - (fun ac u -> - let ls = - match u with - | Expr.ESet ls -> ls - | _ -> raise (Failure "LSetUnion: joining ESets: impossible.") - in - ac @ ls) - [] lesets + match t with + | Some t -> Type_env.update new_gamma x t + | None -> Type_env.remove new_gamma x) + bt; + PFS.substitution subst new_pfs; + (* We reduce using our new pfs and gamma *) + let re = + reduce_lexpr_loop ~matching ~reduce_lvars new_pfs new_gamma e in - let lesets = Expr.Set.elements (Expr.Set.of_list lesets) in - let fles = Expr.ESet lesets :: rest in - (* If there is an empty set, the intersection is empty *) - if List.mem (Expr.ESet []) fles then Expr.ESet [] - else - let fles = Expr.Set.elements (Expr.Set.of_list fles) in - match fles with - | [] -> ESet [] - | [ x ] -> x - | _ -> NOp (SetInter, fles)) - | UnOp (FUnaryMinus, UnOp (FUnaryMinus, e)) -> f e - | UnOp (LstLen, BinOp (_, LstRepeat, e)) -> f e - | UnOp (LstLen, LstSub (_, _, e)) -> f e - | UnOp (op, le) -> ( - let fle = f le in - let def = Expr.UnOp (op, fle) in - match fle with - | Lit lit -> ( - try Lit (CExprEval.evaluate_unop op lit) with - | CExprEval.TypeError err_msg -> - raise (ReductionException (def, err_msg)) - | CExprEval.EvaluationError err_msg -> - raise (ReductionException (def, err_msg)) - | e -> raise e) - | _ -> ( - match op with - | UNot -> ( - match fle with - | UnOp (UNot, ex) -> f ex - | BinOp (ex, BAnd, ey) -> - f (BinOp (UnOp (UNot, ex), BOr, UnOp (UNot, ey))) - | BinOp (ex, BOr, ey) -> - f (BinOp (UnOp (UNot, ex), BAnd, UnOp (UNot, ey))) - | _ -> def) - (* The TypeOf operator *) - | TypeOf -> ( - let tfle, how = Typing.type_lexpr gamma fle in - match how with - | false -> - let err_msg = "LTypeOf(le): expression is not typable." in - raise (ReductionException (def, err_msg)) - | true -> ( - match tfle with - | None -> def - | Some t -> Lit (Type t))) - (* List head *) - | Car -> ( - match lexpr_is_list gamma fle with - | true -> - let ohdtl = get_head_and_tail_of_list ~pfs fle in - Option.fold ~some:(fun (hd, _) -> f hd) ~none:def ohdtl - | false -> - let err_msg = "UnOp(Car, list): list is not a GIL list." in - raise (ReductionException (def, err_msg))) - (* List tail *) - | Cdr -> ( - match lexpr_is_list gamma fle with - | true -> - let ohdtl = get_head_and_tail_of_list ~pfs fle in - Option.fold ~some:(fun (_, tl) -> f tl) ~none:def ohdtl - | false -> - let err_msg = "UnOp(Cdr, list): list is not a GIL list." in - raise (ReductionException (def, err_msg))) - (* List length *) - | LstLen -> ( - match lexpr_is_list gamma fle with - | true -> ( - match fle with - | Lit (LList le) -> Expr.int (List.length le) - | EList le -> Expr.int (List.length le) - | NOp (LstCat, les) -> - let les = List.map Expr.list_length les in - let le = - List.fold_left Expr.Infix.( + ) (List.hd les) - (List.tl les) - in - f le - | LstSub (_, _, len) -> len - | _ -> def) - | false -> - let err_msg = - "UnOp(LstLen, list): list is not a GIL list." - in - raise (ReductionException (def, err_msg))) - (* List reverse *) - | LstRev -> ( - match lexpr_is_list gamma fle with - | true -> ( - match fle with - | Lit (LList le) -> Lit (LList (List.rev le)) - | EList le -> EList (List.rev le) - | NOp (LstCat, les) -> - NOp - ( LstCat, - List.rev - (List.map (fun x -> Expr.UnOp (LstRev, x)) les) ) - | _ -> def) - | false -> - let err_msg = - "UnOp(LstRev, list): list is not a GIL list." - in - raise (ReductionException (def, err_msg))) - (* List reverse *) - | SetToList -> ( - match fle with - | ESet le -> EList (Expr.Set.elements (Expr.Set.of_list le)) - | _ -> def) - (* String length *) - | StrLen -> ( - match lexpr_is_string gamma fle with - | true -> - let len = get_length_of_string fle in - Option.fold - ~some:(fun len -> Expr.Lit (Num (float_of_int len))) - ~none:def len - | false -> - let err_msg = - "UnOp(StrLen, list): string is not a GIL string." - in - raise (ReductionException (def, err_msg))) - | FUnaryMinus when lexpr_is_number ~gamma def -> - simplify_num_arithmetic_lexpr pfs gamma def - | IUnaryMinus when lexpr_is_int ~gamma def -> - simplify_int_arithmetic_lexpr pfs gamma def - | _ -> UnOp (op, fle))) - (* Nested L-sub *) - | LstSub (LstSub (ile1, ile2, ile3), fle2, fle3) + let vars = Expr.lvars re in + let bt = List.filter (fun (b, _) -> Containers.SS.mem b vars) bt in + (* We remove all quantifiers that aren't used anymore *) + match (le, bt) with + | _, [] -> re + | ForAll _, _ -> ForAll (bt, re) + | Exists _, _ -> Exists (bt, re) + | _, _ -> failwith "Impossible.") + (* ------------------------- + LstSub + ------------------------- *) + | LstSub (LstSub (ile1, ile2, _), _, _) when match find_lstsub_inn ile1 ile2 with - | LVar x, _ + | (LVar _ as x), _ when List.exists - (fun x -> - match x with + (function | Expr.LVar _ -> false | _ -> true) - (find_equalities pfs (LVar x)) -> true - | _, LVar x + (find_equalities pfs x) -> true + | _, (LVar _ as x) when List.exists - (fun x -> - match x with + (function | Expr.LVar _ -> false | _ -> true) - (find_equalities pfs (LVar x)) -> true - | _ -> false -> ( - let fle1 = Expr.LstSub (ile1, ile2, ile3) in - let base_expr = Expr.LstSub (fle1, fle2, fle3) in - + (find_equalities pfs x) -> true + | _ -> false -> + (* We (painfully) found out that we can substitute something + from an LVar to a non-LVar -- now we do it, avoiding getting + results more than once. *) let inn_lst, inn_start = find_lstsub_inn ile1 ile2 in - match (inn_lst, inn_start) with - | LVar x, _ - when List.exists - (fun x -> - match x with - | Expr.LVar _ -> false - | _ -> true) - (find_equalities pfs (LVar x)) -> - (* L.verbose (fun fmt -> - fmt "Reducing: %a\n1st: Innermost list and start: %a and %a" - Expr.pp base_expr Expr.pp inn_lst Expr.pp inn_start); *) - let eqs = - List.filter - (fun x -> - match x with - | Expr.LVar _ -> false - | _ -> true) - (find_equalities pfs (LVar x)) - in - let subst_expr = List.hd eqs in - let att_exp = - Expr.subst_expr_for_expr ~to_subst:(LVar x) ~subst_with:subst_expr - base_expr - in - let reduced_att_exp = f att_exp in - (* L.verbose (fun fmt -> - fmt "1st: Attempted and reduced expr: %a and %a" Expr.pp att_exp - Expr.pp reduced_att_exp); *) - if att_exp = reduced_att_exp then LstSub (fle1, fle2, fle3) - else reduced_att_exp - | _, LVar x - when List.exists - (fun x -> - match x with - | Expr.LVar _ -> false - | _ -> true) - (find_equalities pfs (LVar x)) -> - (* L.verbose (fun fmt -> - fmt "Reducing: %a\n2nd: Innermost list and start: %a and %a" - Expr.pp base_expr Expr.pp inn_lst Expr.pp inn_start); *) - let eqs = - List.filter - (fun x -> - match x with - | Expr.LVar _ -> false - | _ -> true) - (find_equalities pfs (LVar x)) - in - let subst_expr = List.hd eqs in - let att_exp = - Expr.subst_expr_for_expr ~to_subst:(LVar x) ~subst_with:subst_expr - base_expr - in - let reduced_att_exp = f att_exp in - (* L.verbose (fun fmt -> - fmt "2nd: Attempted and reduced expr: %a and %a" Expr.pp att_exp - Expr.pp reduced_att_exp); *) - if att_exp = reduced_att_exp then LstSub (fle1, fle2, fle3) - else reduced_att_exp - | _, _ -> LstSub (fle1, fle2, fle3)) + let to_subst, subst_with = + let list_eqs = + match inn_lst with + | LVar _ -> + find_equalities pfs inn_lst + |> List.filter (function + | Expr.LVar _ -> false + | _ -> true) + | _ -> [] + in + match list_eqs with + | x :: _ -> (inn_lst, x) + | [] -> + let x = + find_equalities pfs inn_start + |> List.find (function + | Expr.LVar _ -> false + | _ -> true) + in + (inn_start, x) + in + let att_exp = Expr.subst_expr_for_expr ~to_subst ~subst_with le in + let reduced_att_exp = f att_exp in + (* We can't reduce further, so useless - throw away *) + if att_exp = reduced_att_exp then le else reduced_att_exp + (* If: + - l[n..(len(l))] with n a constant + - l is of the form l1 ++ l2 ++ ... ++ lm + - len(l1) = n and !(m = 2 && l2 = l) (ie. a recursive list??) + Then we reduce to l2 ++ ... ++ lm *) | LstSub (l, Lit (Int n), BinOp (UnOp (LstLen, l'), IMinus, Lit (Int n'))) when l = l' && n == n' && @@ -1426,23 +1061,19 @@ and reduce_lexpr_loop | _ -> false) eqs -> Logging.tmi (fun m -> m "REDUCTION: Case l-sub(l, n, (l-len l) - n)"); - let eqs = get_equal_expressions pfs l in - let cat = - List.filter_map - (function - | Expr.NOp (LstCat, EList les :: rest) - when Int.equal (List.compare_length_with les (Z.to_int n)) 0 -> - Some (Expr.NOp (LstCat, rest)) - | NOp (LstCat, Lit (LList les) :: rest) - when Int.equal (List.compare_length_with les (Z.to_int n)) 0 -> - Some (NOp (LstCat, rest)) - | _ -> None) - eqs - in - f (List.hd cat) + get_equal_expressions pfs l + |> List.find_map (function + | Expr.NOp (LstCat, EList les :: rest) + when Int.equal (List.compare_length_with les (Z.to_int n)) 0 -> + Some (Expr.NOp (LstCat, rest)) + | NOp (LstCat, Lit (LList les) :: rest) + when Int.equal (List.compare_length_with les (Z.to_int n)) 0 -> + Some (NOp (LstCat, rest)) + | _ -> None) + |> Option.get | LstSub (e1, Lit (Int z), e3) when Z.equal z Z.zero - && List.mem (Cint.of_expr e3) (find_list_length_eqs pfs e1) -> f e1 + && List.mem (Cint.of_expr e3) (find_list_length_eqs pfs e1) -> e1 | LstSub (le1, le2, le3) -> ( let fle1 = f le1 in let fle2 = substitute_for_list_length pfs (f le2) in @@ -1523,7 +1154,7 @@ and reduce_lexpr_loop in Logging.tmi (fun m -> m "Case 5:\nRes: %a\nOriginal: %a" Expr.pp res Expr.pp le); - f res + res | le, Lit (Int z), Lit (Int n) when Z.equal z Z.zero && (match le with @@ -1583,13 +1214,12 @@ and reduce_lexpr_loop in (* L.tmi (fun fmt -> fmt "EQs: %a" Fmt.(brackets (list ~sep:comma Expr.pp)) eqs); *) - f - (Expr.list_sub ~lst:(Option.get first) ~start:(Expr.int 0) - ~size:(Expr.int_z n)) + Expr.list_sub ~lst:(Option.get first) ~start:(Expr.int 0) + ~size:(Expr.int_z n) | fle1, UnOp (LstLen, lx), fle3 when fst (list_prefix pfs lx fle1) -> L.tmi (fun fmt -> fmt "Case 7"); let _, suffix = list_prefix pfs lx fle1 in - f (LstSub (suffix, Expr.zero_i, fle3)) + LstSub (suffix, Expr.zero_i, fle3) | fle1, Lit (Int z), UnOp (LstLen, LVar lx) when Z.equal z Z.zero && List.exists @@ -1661,10 +1291,7 @@ and reduce_lexpr_loop let new_lstsub = Expr.LstSub (NOp (LstCat, ler), diff, fle3) in L.verbose (fun fmt -> fmt "Recursively calling with: %a" Expr.pp new_lstsub); - let result = f new_lstsub in - L.verbose (fun fmt -> - fmt "LSUB: Start after first result: %a" Expr.pp result); - result + new_lstsub | NOp (LstCat, EList lel :: ler), Lit (Int n), fle3 when Z.gt n Z.zero -> L.tmi (fun fmt -> fmt "Case 13"); @@ -1680,7 +1307,7 @@ and reduce_lexpr_loop ) in let result = - f (LstSub (NOp (LstCat, rest_of_lel :: ler), Expr.zero_i, fle3)) + Expr.LstSub (NOp (LstCat, rest_of_lel :: ler), Expr.zero_i, fle3) in L.verbose (fun fmt -> fmt "LSUB: Start inside first result: %a" Expr.pp result); @@ -1697,16 +1324,15 @@ and reduce_lexpr_loop fmt "LSUB: Contains first: %a" Expr.pp (LstSub (fle1, fle2, fle3))); let result = - f - (NOp - ( LstCat, - [ - lel; - LstSub - ( NOp (LstCat, ler), - Expr.zero_i, - BinOp (fle3, IMinus, UnOp (LstLen, lel)) ); - ] )) + Expr.NOp + ( LstCat, + [ + lel; + LstSub + ( NOp (LstCat, ler), + Expr.zero_i, + BinOp (fle3, IMinus, UnOp (LstLen, lel)) ); + ] ) in L.verbose (fun fmt -> fmt "LSUB: Contains first result: %a" Expr.pp result); @@ -1714,393 +1340,889 @@ and reduce_lexpr_loop | _ -> L.tmi (fun fmt -> fmt "Case 15"); LstSub (fle1, fle2, fle3)) - (* CHECK: FTimes and Div are the same, how does the 'when' scope? *) - | BinOp (lel, op, ler) -> ( - let op_is_or_and () = - match op with - | BOr | BAnd -> true - | _ -> false - in - let flel, fler = - (* If we're reducing A || B or A && B and either side have a reduction exception, it must be false *) - let flel = - try f lel with - | ReductionException _ when op_is_or_and () -> Expr.bool false - | exn -> raise exn - in - let fler = - try f ler with - | ReductionException _ when op_is_or_and () -> Expr.bool false - | exn -> raise exn - in - (flel, fler) - in - let def = Expr.BinOp (flel, op, fler) in - match (flel, fler) with - | Lit ll, Lit lr -> ( - try - Lit - (CExprEval.evaluate_binop (CStore.init []) op (Lit ll) (Lit lr)) - with + (* ------------------------- + UnOp + ------------------------- *) + (* Cancelling *) + | UnOp (NumToInt, UnOp (IntToNum, e)) + | UnOp (FUnaryMinus, UnOp (FUnaryMinus, e)) + | UnOp (IUnaryMinus, UnOp (IUnaryMinus, e)) + | UnOp (LstLen, BinOp (_, LstRepeat, e)) + | UnOp (LstLen, LstSub (_, _, e)) -> e + | UnOp (IntToNum, UnOp (NumToInt, le)) when PFS.mem pfs (UnOp (IsInt, le)) + -> le + (* Number-to-string-to-number-to-string-to... *) + | UnOp (ToNumberOp, UnOp (ToStringOp, le)) -> ( + let fle = f le in + match fle with + | Lit (Num _) -> fle + | _ -> ( + let tfle, how = Typing.type_lexpr gamma fle in + match (how, tfle) with + | true, Some NumberType -> fle + | _, _ -> UnOp (ToNumberOp, UnOp (ToStringOp, fle)))) + | UnOp (LstRev, UnOp (LstRev, le)) -> le + (* Less than and lessthaneq *) + | UnOp (Not, BinOp (le1, FLessThan, le2)) -> BinOp (le2, FLessThanEqual, le1) + | UnOp (Not, BinOp (le1, FLessThanEqual, le2)) -> BinOp (le2, FLessThan, le1) + | UnOp (Not, BinOp (le1, ILessThan, le2)) -> BinOp (le2, ILessThanEqual, le1) + | UnOp (Not, BinOp (le1, ILessThanEqual, le2)) -> BinOp (le2, ILessThan, le1) + | UnOp (op, le) -> ( + let fle = f le in + let def = Expr.UnOp (op, fle) in + match (op, fle) with + | _, Lit lit -> ( + try Lit (CExprEval.evaluate_unop op lit) with | CExprEval.TypeError err_msg -> raise (ReductionException (def, err_msg)) | CExprEval.EvaluationError err_msg -> raise (ReductionException (def, err_msg)) | e -> raise e) - | _ -> ( - match - reduce_binop_inttonum_const matching reduce_lvars pfs gamma flel - fler op - with - | Some e -> e - | None -> ( - match op with - | Equal -> ( - if Expr.equal flel fler then Lit (Bool true) - else if - PFS.exists - (fun e -> - Formula.equal e (Eq (flel, fler)) - || Formula.equal e (Eq (fler, flel))) - pfs - then Lit (Bool true) - else if - PFS.mem pfs (Not (Eq (flel, fler))) - || PFS.mem pfs (Not (Eq (fler, flel))) - then Lit (Bool false) - else - let t1, _ = Typing.type_lexpr gamma flel in - let t2, _ = Typing.type_lexpr gamma fler in - match (t1, t2) with - | Some t1, Some t2 -> - if Type.equal t1 t2 then def else Lit (Bool false) - | _, _ -> ( - match (flel, fler) with - | UnOp (NumToInt, flel'), _ -> - BinOp (flel', op, UnOp (IntToNum, fler)) - | _, UnOp (NumToInt, fler') -> - BinOp (UnOp (IntToNum, flel), op, fler') - | _, _ -> def)) - | (FPlus | FMinus) when lexpr_is_number ~gamma def -> - simplify_num_arithmetic_lexpr pfs gamma def - | (IPlus | IMinus) when lexpr_is_int ~gamma def -> - simplify_int_arithmetic_lexpr pfs gamma def - | FTimes when lexpr_is_number ~gamma def -> ( - match (flel, fler) with - (* 1 is the neutral *) - | Lit (Num 1.), x | x, Lit (Num 1.) -> x - | Lit (Num x), _ when x == nan -> Lit (Num nan) - | _, Lit (Num x) when x == nan -> Lit (Num nan) - | BinOp (Lit (Num x), FTimes, y), Lit (Num z) - | Lit (Num z), BinOp (Lit (Num x), FTimes, y) -> - BinOp (Lit (Num (z *. x)), FTimes, y) - (* Rest *) - | _, _ -> def) - | ITimes when lexpr_is_int ~gamma def -> ( - match (flel, fler) with - | Lit (Int z), x when Z.equal z Z.one -> x - | x, Lit (Int z) when Z.equal z Z.one -> x - | (Lit (Int z) as zero), _ when Z.equal z Z.zero -> zero - | _, (Lit (Int z) as zero) when Z.equal z Z.zero -> zero - | BinOp (Lit (Int x), ITimes, y), Lit (Int z) - | Lit (Int z), BinOp (Lit (Int x), ITimes, y) -> - BinOp (Lit (Int (Z.mul z x)), ITimes, y) - | _, _ -> def) - | FDiv when lexpr_is_number ~gamma def -> ( - match (flel, fler) with - (* 1 is the neutral *) - | x, Lit (Num 1.) -> x - | _, _ -> def) - | IDiv when lexpr_is_int ~gamma def -> ( - match (flel, fler) with - | x, Lit (Int o) when Z.equal o Z.one -> x - | _, _ -> def) - | BAnd when lexpr_is_bool gamma def -> ( - match (flel, fler) with - (* 1 is the neutral *) - | Lit (Bool true), x | x, Lit (Bool true) -> x - | Lit (Bool false), _ | _, Lit (Bool false) -> - Lit (Bool false) - (* Rest *) - | _, _ -> - let fal, nfal = - Option.get (Formula.lift_logic_expr flel) - in - let far, nfar = - Option.get (Formula.lift_logic_expr fler) - in - if PFS.mem pfs nfal || PFS.mem pfs nfar then - Lit (Bool false) - else if PFS.mem pfs fal then f fler - else if PFS.mem pfs far then f flel - else BinOp (flel, BAnd, fler)) - | BOr when lexpr_is_bool gamma def -> ( - match (flel, fler) with - (* 1 is the neutral *) - | Lit (Bool true), _ | _, Lit (Bool true) -> Lit (Bool true) - | Lit (Bool false), x | x, Lit (Bool false) -> x - (* Rest *) - | _, _ -> - let fal, nfal = - Option.get (Formula.lift_logic_expr flel) - in - let far, nfar = - Option.get (Formula.lift_logic_expr fler) - in - if PFS.mem pfs fal || PFS.mem pfs far then - Lit (Bool true) - else if PFS.mem pfs nfal then f fler - else if PFS.mem pfs nfar then f flel - else BinOp (flel, BOr, fler)) - | StrCat when lexpr_is_string gamma def -> ( - match (flel, fler) with - (* Empty list is the neutral *) - | x, Lit (String "") | Lit (String ""), x -> x - (* Rest *) - | BinOp (el, StrCat, Lit (String s1)), Lit (String s2) -> - f (BinOp (el, StrCat, Lit (String (s1 ^ s2)))) - | _, _ -> def) - | SetDiff when lexpr_is_set gamma def -> ( - let pfs = PFS.to_list pfs in - if contained_in_union pfs flel fler then ESet [] - else - match (flel, fler) with - | x, y when x = y -> ESet [] - | ESet [], _ -> ESet [] - | x, ESet [] -> x - | ESet left, ESet right - when Expr.all_literals left && Expr.all_literals right - -> - ESet - (Expr.Set.elements - (Expr.Set.diff (Expr.Set.of_list left) - (Expr.Set.of_list right))) - | ESet left, s when Expr.all_literals left -> - if List.for_all (fun x -> set_member pfs x s) left - then ESet [] - else def - | ESet left, ESet right -> - L.verbose (fun fmt -> - fmt "Inside relevant SetDiff case."); - let candidate_result = - Expr.Set.elements - (Expr.Set.diff (Expr.Set.of_list left) - (Expr.Set.of_list right)) - in - L.verbose (fun fmt -> - fmt "Candidate result: %a" - Fmt.(brackets (list ~sep:comma Expr.pp)) - candidate_result); - let result = - if - List.for_all - (fun x -> not_set_member pfs x (ESet right)) - candidate_result - then Expr.ESet candidate_result - else def - in - L.verbose (fun fmt -> - fmt "Actual result: %a" Expr.pp result); - result - | NOp (SetUnion, les), _ -> - let diffs = - List.map - (fun le -> f (BinOp (le, SetDiff, fler))) - les - in - NOp (SetUnion, diffs) - | _, NOp (SetUnion, les) -> - f - (NOp - ( SetInter, - List.map - (fun le -> Expr.BinOp (flel, SetDiff, le)) - les )) - | x, ESet [ el ] - when List.mem (Formula.Not (SetMem (el, x))) pfs -> x - | LVar _, _ -> - if set_subset pfs flel fler then ESet [] else def - | ESet les, fler -> ( - (* We must know that the elements of les are all different, and for that we need the pure formulae *) - match all_different pfs les with - | false -> def - | true -> - let _, rest = - List.partition - (fun x -> set_member pfs x fler) - les - in - if - List.for_all - (fun x -> not_set_member pfs x fler) - rest - then ESet rest - else BinOp (ESet rest, SetDiff, fler)) - | _, _ -> def) - (* let hM = f (BinOp (flel, SetSub, fler)) in - (match hM with - | Lit (Bool true) -> ESet [] - | _ -> def)) *) - | BSetMem when lexpr_is_bool gamma def -> ( - match (flel, fler) with - | _, ESet [] -> Lit (Bool false) - | _, ESet [ x ] -> BinOp (flel, Equal, x) - | le, ESet les -> ( - match List.mem le les with - | true -> Lit (Bool true) - | false -> ( - match le with - | Lit _ -> - if Expr.all_literals les then Lit (Bool false) - else def - | _ -> def)) - | _, _ -> def) - | BSetSub when lexpr_is_bool gamma def -> ( - match (flel, fler) with - | ESet [], _ -> Lit (Bool true) - | _, ESet [] -> Lit (Bool false) - | ESet left, ESet right - when Expr.all_literals left && Expr.all_literals right -> - Lit - (Bool - (Expr.Set.subset (Expr.Set.of_list left) - (Expr.Set.of_list right))) - | LVar _, NOp (SetUnion, les) -> - if List.mem flel les then Lit (Bool true) else def - | _, _ -> def) - | FLessThan -> - let success, el, er = Cnum.cut flel fler in - let nexpr = Expr.BinOp (el, FLessThan, er) in - if success then f nexpr else nexpr - | ILessThan -> ( - match (flel, fler) with - | x, fler - when let fler_len = substitute_for_list_length pfs fler in - match fler_len with - | UnOp (LstLen, _) -> true - | _ -> false -> - f - (BinOp - ( BinOp (x, IPlus, Lit (Int Z.one)), - ILessThanEqual, - fler )) - | UnOp (LstLen, _), Lit (Int n) when Z.leq n Z.zero -> - Lit (Bool false) - | UnOp (LstLen, le), Lit (Int z) when Z.equal z Z.one -> - BinOp (le, Equal, EList []) - | _ -> - let success, el, er = Cint.cut flel fler in - let nexpr = Expr.BinOp (el, ILessThan, er) in - if success then f nexpr else nexpr - (* | _, _ -> - f - (BinOp - (BinOp (flel, FMinus, fler), FLessThan, Lit (Num 0.))) *) - ) - | FLessThanEqual -> ( - let success, el, er = Cnum.cut flel fler in - if success then f (BinOp (el, FLessThanEqual, er)) - else - match - check_ge_zero_num ~top_level:true pfs - (f (BinOp (fler, FMinus, flel))) - with - | Some x -> Lit (Bool x) - | None -> def) - | ILessThanEqual -> ( - let success, el, er = Cint.cut flel fler in - if success then f (BinOp (el, ILessThanEqual, er)) - else - match - check_ge_zero_int ~top_level:true pfs - (f (BinOp (fler, IMinus, flel))) - with - | Some x -> Lit (Bool x) - | None -> def) - | _ -> def))) - | Exists (bt, e) -> ( - (* We create a new pfs and gamma where: - - All shadowed variables are substituted with a fresh variable - - The gamma has been updated with the types given in the binder *) - let new_gamma = Type_env.copy gamma in - let new_pfs = PFS.copy pfs in - let subst_bindings = List.map (fun (x, _) -> (x, LVar.alloc ())) bt in - let subst = - SVal.SESubst.init - (List.map (fun (x, y) -> (Expr.LVar x, Expr.LVar y)) subst_bindings) + (* Negation *) + | Not, UnOp (Not, ex) -> ex + | Not, BinOp (ex, And, ey) -> BinOp (UnOp (Not, ex), Or, UnOp (Not, ey)) + | Not, BinOp (ex, Or, ey) -> BinOp (UnOp (Not, ex), And, UnOp (Not, ey)) + | Not, _ -> def + (* The TypeOf operator *) + | TypeOf, _ -> ( + let tfle, how = Typing.type_lexpr gamma fle in + match how with + | false -> + let err_msg = "LTypeOf(le): expression is not typable." in + raise (ReductionException (def, err_msg)) + | true -> ( + match tfle with + | None -> def + | Some t -> Lit (Type t))) + (* List operations: head, tail *) + | Car, EList (hd :: _) -> hd + | Car, _ when lexpr_is_list gamma fle -> + let ohdtl = get_head_and_tail_of_list ~pfs fle in + Option.fold ~some:(fun (hd, _) -> f hd) ~none:def ohdtl + | Cdr, EList (_ :: tl) -> EList tl + | Cdr, _ when lexpr_is_list gamma fle -> + let ohdtl = get_head_and_tail_of_list ~pfs fle in + Option.fold ~some:(fun (_, tl) -> f tl) ~none:def ohdtl + (* List operations: length *) + | LstLen, EList le -> Expr.int (List.length le) + | LstLen, NOp (LstCat, []) -> Expr.zero_i + | LstLen, NOp (LstCat, les) when lexpr_is_list gamma fle -> + let les = List.map Expr.list_length les in + List.fold_left Expr.Infix.( + ) (List.hd les) (List.tl les) + | LstLen, LstSub (_, _, len) when lexpr_is_list gamma fle -> len + | LstLen, _ when lexpr_is_list gamma fle -> def + (* List operations: reverse *) + | LstRev, EList le -> EList (List.rev le) + | LstRev, NOp (LstCat, les) when lexpr_is_list gamma fle -> + NOp (LstCat, List.rev_map (fun x -> Expr.UnOp (LstRev, x)) les) + | LstRev, _ when lexpr_is_list gamma fle -> def + (* List operations when not lists *) + | Car, _ | Cdr, _ | LstLen, _ | LstRev, _ -> + let err_msg = + Fmt.str "UnOp(%s, list): list is not a GIL list." (UnOp.str op) + in + raise (ReductionException (def, err_msg)) + (* Set operation *) + | SetToList, ESet le -> EList (Expr.Set.elements (Expr.Set.of_list le)) + (* String length *) + | StrLen, _ when lexpr_is_string gamma fle -> + let len = get_length_of_string fle in + Option.fold + ~some:(fun len -> Expr.Lit (Num (float_of_int len))) + ~none:def len + | StrLen, _ -> + let err_msg = "UnOp(StrLen, list): string is not a GIL string." in + raise (ReductionException (def, err_msg)) + (* Minus *) + | FUnaryMinus, _ when lexpr_is_number ~gamma def -> + simplify_num_arithmetic_lexpr pfs gamma def + | IUnaryMinus, _ when lexpr_is_int ~gamma def -> + simplify_int_arithmetic_lexpr pfs gamma def + (* IsInt *) + | IsInt, UnOp (IntToNum, e) -> ( + match Typing.type_lexpr gamma e with + | Some IntType, _ -> Expr.true_ + | Some _, _ -> Expr.false_ + | None, _ -> BinOp (UnOp (TypeOf, e), Equal, Lit (Type IntType))) + | _, _ -> def) + (* ------------------------- + NOp + ------------------------- *) + (* List concatenation *) + (* l[0..n] ++ l[n..n+m] ++ rest <=> l[0..n+m] ++ rest *) + | NOp (LstCat, LstSub (x1, Lit (Int z), z1) :: LstSub (x2, y2, z3) :: rest) + when Z.equal z Z.zero && Expr.equal x1 x2 && Expr.equal z1 y2 -> + NOp (LstCat, LstSub (x1, Expr.zero_i, Expr.Infix.( + ) z1 z3) :: rest) + | NOp (LstCat, fst :: rest) when PFS.mem pfs (BinOp (fst, Equal, EList [])) + -> NOp (LstCat, rest) + | NOp (LstCat, [ x; LstSub (LVar y, UnOp (LstLen, x'), len) ]) + when x = x' + && Cint.canonicalise len + = Cint.canonicalise + (BinOp (UnOp (LstLen, LVar y), IMinus, UnOp (LstLen, x))) + && prefix_catch pfs x y -> LVar y + | NOp (LstCat, les) -> normalise_cat f les + (* Set union *) + | NOp (SetUnion, les) -> ( + let fles = List.map f les in + (* Flatten unions *) + let fles = + List.concat_map + (function + | Expr.NOp (SetUnion, les) -> les + | le -> [ le ]) + fles in - let () = - List.iter - (fun (x, t) -> - let () = - match Type_env.get new_gamma x with - | Some t -> - let new_var = List.assoc x subst_bindings in - Type_env.update new_gamma new_var t - | None -> () - in - match t with - | Some t -> Type_env.update new_gamma x t - | None -> Type_env.remove new_gamma x) - bt + (* Join ESets *) + let lesets, rest = + List.partition_map + (function + | Expr.ESet es -> Left es + | e -> Right e) + fles in - let () = PFS.substitution subst new_pfs in - (* We reduce using our new pfs and gamma *) - let re = - reduce_lexpr_loop ~matching ~reduce_lvars new_pfs new_gamma e + let lesets = List.concat lesets in + (* Merge together, without duplicates *) + let rest = rest |> Expr.Set.of_list |> Expr.Set.elements in + let fles = + match lesets with + | [] -> rest + | _ -> + (* TODO: Check is List.sort_uniq is faster than Set *) + let lesets = lesets |> Expr.Set.of_list |> Expr.Set.elements in + Expr.ESet lesets :: rest in - let vars = Expr.lvars re in - let bt = List.filter (fun (b, _) -> Containers.SS.mem b vars) bt in - (* We remove all quantifiers that aren't used anymore *) - match bt with - | [] -> re - | _ -> Exists (bt, re)) - | EForall (bt, e) -> ( - (* We create a new pfs and gamma where: - - All shadowed variables are substituted with a fresh variable - - The gamma has been updated with the types given in the binder *) - let new_gamma = Type_env.copy gamma in - let new_pfs = PFS.copy pfs in - let subst_bindings = List.map (fun (x, _) -> (x, LVar.alloc ())) bt in - let subst = - SVal.SESubst.init - (List.map (fun (x, y) -> (Expr.LVar x, Expr.LVar y)) subst_bindings) + (* Remove duplicates *) + match fles with + | [] -> ESet [] + | [ x ] -> x + | _ -> NOp (SetUnion, fles)) + (* Set intersection *) + | NOp (SetInter, [ BinOp (le1, SetDiff, le2); ESet le3 ]) -> + NOp (SetInter, [ le2; BinOp (ESet le3, SetDiff, le1) ]) + | NOp (SetInter, les) -> ( + let fles = List.map f les in + (* Flatten intersections *) + let fles = + List.concat_map + (function + | Expr.NOp (SetInter, es) -> es + | e -> [ e ]) + fles in - let () = - List.iter - (fun (x, t) -> - let () = - match Type_env.get new_gamma x with - | Some t -> - let new_var = List.assoc x subst_bindings in - Type_env.update new_gamma new_var t - | None -> () + (* Join ESets *) + let lesets, rest = + List.partition_map + (function + | Expr.ESet es -> Left es + | e -> Right e) + fles + in + let lesets = List.concat lesets in + (* Merge together, without duplicates *) + match (lesets, rest) with + | [], _ -> ESet [] + | _, [] -> + let lesets = lesets |> Expr.Set.of_list |> Expr.Set.elements in + Expr.ESet lesets + | _ -> + let lesets = lesets |> Expr.Set.of_list |> Expr.Set.elements in + let rest = rest |> Expr.Set.of_list |> Expr.Set.elements in + let fles = Expr.ESet lesets :: rest in + NOp (SetInter, fles)) + (* ------------------------- + BinOp + (terrifying) + ------------------------- *) + (* BinOps: Equalities (basics) *) + | BinOp (e1, Equal, e2) when Expr.equal e1 e2 -> Expr.true_ + (* BinOps: Equalities (injective unops) *) + | BinOp (UnOp (IUnaryMinus, e1), Equal, UnOp (IUnaryMinus, e2)) + | BinOp (UnOp (FUnaryMinus, e1), Equal, UnOp (FUnaryMinus, e2)) + | BinOp (UnOp (BitwiseNot, e1), Equal, UnOp (BitwiseNot, e2)) + | BinOp (UnOp (Not, e1), Equal, UnOp (Not, e2)) + | BinOp (UnOp (LstRev, e1), Equal, UnOp (LstRev, e2)) + | BinOp (UnOp (IntToNum, e1), Equal, UnOp (IntToNum, e2)) + | BinOp (UnOp (ToStringOp, e1), Equal, UnOp (ToStringOp, e2)) -> + BinOp (e1, Equal, e2) + (* BinOps: Equalities (locations) *) + (* This line is the central mechanism to "matching": *) + | BinOp (ALoc x, Equal, ALoc y) when not matching -> Lit (Bool (x = y)) + | BinOp (ALoc _, Equal, Lit (Loc _)) | BinOp (Lit (Loc _), Equal, ALoc _) -> + Expr.false_ + (* BinOps: Equalities (lists) *) + | BinOp (Lit (LList ll), Equal, Lit (LList lr)) -> Expr.bool (ll = lr) + | BinOp (EList le, Equal, Lit (LList ll)) + | BinOp (Lit (LList ll), Equal, EList le) -> + if List.length ll <> List.length le then Expr.false_ + else if ll = [] then Expr.true_ + else + List.map2 (fun x y -> Expr.Infix.( == ) x (Lit y)) le ll + |> Expr.conjunct + | BinOp (EList ll, Equal, EList lr) -> + if List.length ll <> List.length lr then Expr.(false_) + else if ll = [] then Expr.(true_) + else List.map2 Expr.Infix.( == ) ll lr |> Expr.conjunct + (* x = l1 ++ ... ++ ln when x = li and there is a non empty list => false *) + | BinOp (NOp (LstCat, les), Equal, (LVar _ as x)) + when List.mem x les + && List.exists + (function + | Expr.EList (_ :: _) | Lit (LList (_ :: _)) -> true + | _ -> false) + les -> Expr.false_ + (* l[0..n] = l <=> n = len(l) *) + | BinOp (LstSub (e1, Lit (Int z), el), Equal, e2) + when Z.equal z Z.zero && Expr.equal e1 e2 -> + BinOp (UnOp (LstLen, e1), Equal, el) + | BinOp (e2, Equal, LstSub (e1, Lit (Int z), el)) + when Z.equal z Z.zero && Expr.equal e1 e2 -> + BinOp (UnOp (LstLen, e1), Equal, el) + (* (l ++ ...)[0..n] = l <==> n = len(l) *) + | BinOp (e2, Equal, LstSub (NOp (LstCat, e1 :: _), Lit (Int z), el)) + when Z.equal z Z.zero && Expr.equal e1 e2 -> + BinOp (UnOp (LstLen, e1), Equal, el) + | BinOp (LstSub (NOp (LstCat, e1 :: _), Lit (Int z), el), Equal, e2) + when Z.equal z Z.zero && Expr.equal e1 e2 -> + BinOp (UnOp (LstLen, e1), Equal, el) + (* l = (l1 ++ l ++ ...)[n..m] <=> n = len(l1) /\ m = len(l) *) + | BinOp (e2, Equal, LstSub (NOp (LstCat, e3 :: e1 :: _), ex, ey)) + when Expr.equal e1 e2 -> + BinOp + ( BinOp (UnOp (LstLen, e3), Equal, ex), + And, + BinOp (UnOp (LstLen, e1), Equal, ey) ) + | BinOp (LstSub (NOp (LstCat, e3 :: e1 :: _), ex, ey), Equal, e2) + when Expr.equal e1 e2 -> + BinOp + ( BinOp (UnOp (LstLen, e3), Equal, ex), + And, + BinOp (UnOp (LstLen, e1), Equal, ey) ) + (* l ++ l1 = l ++ l2 <=> l1 = l2 *) + | BinOp (NOp (LstCat, fl :: rl), Equal, NOp (LstCat, fr :: rr)) + when Expr.equal fl fr -> BinOp (NOp (LstCat, rl), Equal, NOp (LstCat, rr)) + (* la ++ ... ++ l = lb ++ ... ++ l <=> la ++ ... = lb ++ ... *) + | BinOp + ( NOp (LstCat, (_ :: (_ :: _ as rl) as fl)), + Equal, + NOp (LstCat, (_ :: (_ :: _ as rr) as fr)) ) + when let last l = List.hd @@ List.rev l in + Expr.equal (last rl) (last rr) -> + let rem_last l = List.rev @@ List.tl @@ List.rev l in + BinOp (NOp (LstCat, rem_last fl), Equal, NOp (LstCat, rem_last fr)) + (* l = l[0..s] ++ ... /\ len(l) < s <=> false *) + | BinOp + ( LVar lst, + Equal, + NOp (LstCat, LstSub (LVar lst', Lit (Int z), split) :: _) ) + when Z.equal z Z.zero && String.equal lst lst' + && PFS.mem pfs (BinOp (UnOp (LstLen, LVar lst), ILessThan, split)) -> + Expr.false_ + (* l U {x} = l' U {x} /\ x ∉ l /\ x ∉ l' <=> l = l' *) + | BinOp + ( NOp (SetUnion, [ ls; ESet [ lx ] ]), + Equal, + NOp (SetUnion, [ rs; ESet [ rx ] ]) ) + when lx = rx + && PFS.mem pfs (UnOp (Not, BinOp (lx, SetMem, ls))) + && PFS.mem pfs (UnOp (Not, BinOp (lx, SetMem, rs))) -> + BinOp (ls, Equal, rs) + (* BinOps: Equalities (maths) *) + (* These always map to a boolean so no need for =. + Could be simplified with an fn that maps BinOp -> ret type *) + | BinOp + ( Lit (Bool true), + Equal, + (BinOp + ( _, + ( Equal + | ILessThan + | ILessThanEqual + | FLessThan + | FLessThanEqual + | StrLess + | And + | Or + | Impl + | SetMem + | SetSub ), + _ ) as e) ) -> e + | BinOp (Lit (Bool false), Equal, BinOp (e1, ILessThan, e2)) -> + BinOp (e2, ILessThanEqual, e1) + | BinOp (Lit (Bool false), Equal, BinOp (e1, ILessThanEqual, e2)) -> + BinOp (e2, ILessThan, e1) + | BinOp (Lit (Bool false), Equal, BinOp (e1, FLessThan, e2)) -> + BinOp (e2, FLessThanEqual, e1) + | BinOp (Lit (Bool false), Equal, BinOp (e1, FLessThanEqual, e2)) -> + BinOp (e2, FLessThan, e1) + | BinOp (* x + (-y) = 0f <=> x = y *) + (BinOp (LVar x, FPlus, UnOp (FUnaryMinus, LVar y)), Equal, Lit (Num 0.)) + -> BinOp (LVar x, Equal, LVar y) + | BinOp (* x + (-y) = 0i <=> x = y *) + (BinOp (LVar x, IPlus, UnOp (IUnaryMinus, LVar y)), Equal, Lit (Int z)) + when Z.equal z Z.zero -> BinOp (LVar x, Equal, LVar y) + | BinOp (BinOp (Lit (Num x), FPlus, LVar y), Equal, LVar z) + when x <> 0. && String.equal y z -> Expr.false_ + | BinOp (BinOp (Lit (Int x), IPlus, LVar y), Equal, LVar z) + when (not (Z.equal x Z.zero)) && String.equal y z -> Expr.false_ + (* FIXME: INTEGER BYTE-BY-BYTE BREAKDOWN *) + (* 256 * b1 + b0 = n /\ b0,b1 ∈ [0;256[ <==> b1 = n/256 /\ b0 = n-b1 + Opale: The b0 = n-b1 bit is weird?? Why not mod? *) + | BinOp + ( Lit (Int n), + Equal, + BinOp + ( BinOp (Lit (Int tfs), ITimes, (LVar _ as b1)), + IPlus, + (LVar _ as b0) ) ) + when (*top_level &&*) + Z.equal tfs _256 + && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, b0)) + && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, b1)) + && PFS.mem pfs (BinOp (b0, ILessThan, Lit (Int _256))) + && PFS.mem pfs (BinOp (b1, ILessThan, Lit (Int _256))) -> + if Z.gt n _65535 then Expr.false_ + else + let vb1 = Z.div n _256 in + let vb0 = Z.sub n vb1 in + BinOp + ( BinOp (b1, Equal, Lit (Int vb1)), + And, + BinOp (b0, Equal, Lit (Int vb0)) ) + | BinOp + ( BinOp + ( BinOp (Lit (Int tfs), ITimes, (LVar _ as b1)), + IPlus, + (LVar _ as b0) ), + Equal, + Lit (Int n) ) + when (*top_level &&*) + Z.equal tfs _256 + && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, b0)) + && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, b1)) + && PFS.mem pfs (BinOp (b0, ILessThan, Lit (Int _256))) + && PFS.mem pfs (BinOp (b1, ILessThan, Lit (Int _256))) -> + if Z.gt n _65535 then Expr.false_ + else + let vb1 = Z.div n _256 in + let vb0 = Z.sub n vb1 in + BinOp + ( BinOp (b1, Equal, Lit (Int vb1)), + And, + BinOp (b0, Equal, Lit (Int vb0)) ) + | BinOp (BinOp (e, FTimes, Lit (Num x)), Equal, Lit (Num 0.)) when x <> 0. + -> BinOp (e, Equal, Lit (Num 0.)) + | BinOp (BinOp (Lit (Num x), FTimes, e), Equal, Lit (Num 0.)) when x <> 0. + -> BinOp (e, Equal, Lit (Num 0.)) + | BinOp (BinOp (e, ITimes, Lit (Int x)), Equal, Lit (Int n)) + when Z.equal n Z.zero && not (Z.equal x Z.zero) -> + BinOp (e, Equal, Expr.zero_i) + | BinOp (BinOp (Lit (Int x), ITimes, e), Equal, Lit (Int n)) + when Z.equal n Z.zero && not (Z.equal x Z.zero) -> + BinOp (e, Equal, Expr.zero_i) + | BinOp (BinOp (a, FTimes, b), FMod, c) + when Expr.equal a c || Expr.equal b c -> Expr.num 0. + | BinOp (x, FTimes, BinOp (y, FDiv, z)) when x = z -> y + | BinOp (BinOp (x, FDiv, y), FTimes, z) when y = z -> x + | BinOp (UnOp (NumToInt, x), Equal, y) | BinOp (y, Equal, UnOp (NumToInt, x)) + -> BinOp (UnOp (IntToNum, y), Equal, x) + (* BinOps: Equalities (strings) *) + (* x = y ++ z + /\ |x| < |y| => false + /\ |x| = |y| => x = y /\ z = "" + /\ |x| > |y| => x[0..|y|] = y /\ x[|y|..] = z *) + | BinOp (Lit (String ls), Equal, BinOp (Lit (String rs), StrCat, s)) + | BinOp (BinOp (Lit (String rs), StrCat, s), Equal, Lit (String ls)) -> ( + let lls = String.length ls in + let lrs = String.length rs in + match Stdlib.compare lls lrs with + | -1 -> Expr.false_ + | 0 when ls <> rs -> Expr.false_ + | 0 -> BinOp (s, Equal, Lit (String "")) + | 1 when not (String.starts_with ~prefix:rs ls) -> Expr.false_ + | 1 -> BinOp (s, Equal, Lit (String (String.sub ls lrs (lls - lrs)))) + | _ -> raise (Exceptions.Impossible "int comparison not in {-1, 0, 1}")) + (* a ++ b = a ++ c <=> b = c *) + | BinOp (BinOp (sl1, StrCat, sr1), Equal, BinOp (sl2, StrCat, sr2)) + when sl1 = sl2 -> BinOp (sr1, Equal, sr2) + | BinOp (BinOp (sl1, StrCat, sr1), Equal, BinOp (sl2, StrCat, sr2)) + when sr1 = sr2 -> BinOp (sl1, Equal, sl2) + (* a ++ b = a <=> b = "" *) + | BinOp (BinOp (sl, StrCat, sr), Equal, s) when sl = s -> + BinOp (sr, Equal, Lit (String "")) + | BinOp (BinOp (sl, StrCat, sr), Equal, s) when sr = s -> + BinOp (sl, Equal, Lit (String "")) + | BinOp (s, Equal, BinOp (sl, StrCat, sr)) when sl = s -> + BinOp (sr, Equal, Lit (String "")) + | BinOp (s, Equal, BinOp (sl, StrCat, sr)) when sr = s -> + BinOp (sl, Equal, Lit (String "")) + | BinOp (BinOp (sl, StrCat, sr), Equal, Lit (String "")) -> + BinOp + ( BinOp (sl, Equal, Lit (String "")), + And, + BinOp (sr, Equal, Lit (String "")) ) + (* by injectivity *) + | BinOp (UnOp (ToStringOp, le1), Equal, Lit (String s)) + | BinOp (Lit (String s), Equal, UnOp (ToStringOp, le1)) -> ( + match s with + | "" -> Expr.false_ + | "Infinity" | "-Infinity" | "NaN" -> le + | _ -> ( + try Expr.BinOp (le1, Equal, Lit (Num (Float.of_string s))) + with _ -> Expr.false_)) + (* BinOps: Equalities (Empty?) *) + | BinOp (Lit Empty, Equal, e) | BinOp (e, Equal, Lit Empty) -> ( + match e with + | Lit l when l <> Empty -> Expr.false_ + | EList _ | ESet _ -> Expr.false_ + | _ -> le) + | BinOp (Lit l1, Equal, Lit l2) -> Expr.bool (l1 = l2) + | BinOp (Lit Nono, Equal, PVar _) | BinOp (PVar _, Equal, Lit Nono) -> le + (* JOSE: Why are we considering the case of a logical variable being bound to None? *) + | BinOp (Lit Nono, Equal, LVar x) | BinOp (LVar x, Equal, Lit Nono) -> ( + match Type_env.get gamma x with + | None | Some NoneType -> le + | _ -> Expr.false_) + | BinOp (Lit Nono, Equal, e) | BinOp (e, Equal, Lit Nono) -> ( + let fe = f e in + match fe with + | Lit Nono -> Expr.true_ + | Lit _ -> Expr.false_ + | LVar x when Type_env.get gamma x = Some NoneType -> + BinOp (Lit Nono, Equal, fe) + | PVar _ -> BinOp (Lit Nono, Equal, fe) + | LVar _ -> Expr.false_ + | _ -> Expr.false_) + (* BinOps: Equalities (typing) *) + (* Can this be generalised? add an fn to typing, that maps BinOp -> ret type *) + | BinOp (UnOp (TypeOf, BinOp (_, StrCat, _)), Equal, Lit (Type t)) + when t <> StringType -> Expr.false_ + | BinOp (UnOp (TypeOf, BinOp (_, SetMem, _)), Equal, Lit (Type t)) + when t <> BooleanType -> Expr.false_ + (* BinOps: Logic *) + | BinOp (Lit (Bool true), And, e) + | BinOp (e, And, Lit (Bool true)) + | BinOp (Lit (Bool false), Or, e) + | BinOp (e, Or, Lit (Bool false)) + | BinOp (Lit (Bool true), Impl, e) -> e + | BinOp (Lit (Bool false), And, _) | BinOp (_, And, Lit (Bool false)) -> + Expr.false_ + | BinOp (Lit (Bool true), Or, _) + | BinOp (_, Or, Lit (Bool true)) + | BinOp (Lit (Bool false), Impl, _) + | BinOp (_, Impl, Lit (Bool true)) -> Expr.true_ + | BinOp (left, Impl, Lit (Bool false)) -> UnOp (Not, left) + | BinOp (left, Impl, right) -> ( + let left = f left in + match Expr.as_boolean_expr left with + | None -> BinOp (left, Impl, f right) + | Some (Lit (Bool true), _) -> right + | Some (Lit (Bool false), _) -> Expr.true_ + | Some (left_f, _) -> + let pfs_with_left = PFS.copy pfs in + PFS.extend pfs_with_left left_f; + let right = + reduce_lexpr_loop ~matching ~reduce_lvars pfs_with_left gamma + right + in + BinOp (left, Impl, right)) + (* BinOps: List indexing *) + | BinOp (le, LstNth, idx) -> ( + let fle = f le in + let fidx = f idx in + match fidx with + (* Index is a non-negative integer *) + | Lit (Int n) when Z.leq Z.zero n -> + if lexpr_is_list gamma fle then + Option.value + ~default:(Expr.BinOp (fle, LstNth, fidx)) + (get_nth_of_list pfs fle (Z.to_int n)) + else + let err_msg = + Fmt.str "LstNth(%a, %a): list is not a GIL list." Expr.pp fle + Expr.pp idx in - match t with - | Some t -> Type_env.update new_gamma x t - | None -> Type_env.remove new_gamma x) - bt + L.normal (fun fmt -> fmt "%s" err_msg); + raise (ReductionException (BinOp (fle, LstNth, fidx), err_msg)) + (* Index is a number, but is either not an integer or is negative *) + | Lit (Int _) | Lit (Num _) -> + let err_msg = + "LstNth(list, index): index is smaller than zero or a float." + in + raise (ReductionException (BinOp (fle, LstNth, fidx), err_msg)) + (* All other cases *) + | _ -> BinOp (fle, LstNth, fidx)) + | BinOp (x, LstRepeat, Lit (Int i)) when Z.lt i (Z.of_int 100) -> + let fx = f x in + let result = List.init (Z.to_int i) (fun _ -> fx) in + EList result + (* BinOps: String indexing *) + | BinOp (le, StrNth, idx) -> ( + let fle = f le in + let fidx = f idx in + match fidx with + (* Index is a non-negative integer *) + | Lit (Num n) when Arith_utils.is_int n && 0. <= n -> ( + match lexpr_is_string gamma fle with + | true -> + Option.value + ~default:(Expr.BinOp (fle, StrNth, fidx)) + (get_nth_of_string fle (int_of_float n)) + | false -> + let err_msg = + "StrNth(str, index): string is not a GIL string." + in + raise + (ReductionException (Expr.BinOp (fle, StrNth, fidx), err_msg)) + ) + (* Index is a number, but is either not an integer or is negative *) + | Lit (Num _) -> + let err_msg = + "StrNth(str, index): index is non-integer or smaller than zero." + in + raise (ReductionException (Expr.BinOp (fle, StrNth, fidx), err_msg)) + (* All other cases *) + | _ -> BinOp (fle, StrNth, fidx)) + (* BinOps: Maths *) + | BinOp (Lit (Int z), ILessThanEqual, UnOp (LstLen, _)) + when Z.equal z Z.zero -> Expr.true_ + (* x < y /\ (y <= x \/ y < x) <=> false *) + | BinOp (e1, FLessThan, e2) + when PFS.mem pfs (BinOp (e2, FLessThanEqual, e1)) + || PFS.mem pfs (BinOp (e2, FLessThan, e1)) -> Expr.false_ + | BinOp (e1, ILessThan, e2) + when PFS.mem pfs (BinOp (e2, ILessThanEqual, e1)) + || PFS.mem pfs (BinOp (e2, ILessThan, e1)) -> Expr.false_ + (* x <= y /\ y < x <=> false *) + | BinOp (e1, FLessThanEqual, e2) + when PFS.mem pfs (BinOp (e2, FLessThan, e1)) -> Expr.false_ + | BinOp (e1, ILessThanEqual, e2) + when PFS.mem pfs (BinOp (e2, ILessThan, e1)) -> Expr.false_ + (* x <= y /\ x < y <=> true *) + | BinOp (e1, FLessThanEqual, e2) + when PFS.mem pfs (BinOp (e1, FLessThan, e2)) -> Expr.true_ + | BinOp (e1, ILessThanEqual, e2) + when PFS.mem pfs (BinOp (e1, ILessThan, e2)) -> Expr.true_ + (* x <= y /\ y <= x <=> x = y *) + | BinOp (e1, ((FLessThanEqual | ILessThanEqual) as op), e2) + when PFS.mem pfs (BinOp (e2, op, e1)) -> BinOp (e1, Equal, e2) + (* BinOps: set operations *) + | BinOp (_, SetMem, NOp ((SetUnion | SetInter), [])) -> Expr.false_ + | BinOp (leb, SetMem, NOp (((SetUnion | SetInter) as op), le :: lle)) -> + let bop : BinOp.t = if op = SetUnion then Or else And in + let rle = f le in + let rleb = f leb in + List.fold_left + (fun ac le -> + let rle = f le in + Expr.BinOp (ac, bop, BinOp (rleb, SetMem, rle))) + (Expr.BinOp (rleb, SetMem, rle)) + lle + | BinOp (leb, SetMem, BinOp (lel, SetDiff, ler)) -> + let rleb = f leb in + let rlel = f lel in + let rler = f ler in + BinOp + ( BinOp (rleb, SetMem, rlel), + And, + UnOp (Not, BinOp (rleb, SetMem, rler)) ) + | BinOp (leb, SetMem, ESet les) -> + let rleb = f leb in + let rles = List.map f les in + let result = List.map (fun le -> Expr.BinOp (rleb, Equal, le)) rles in + Expr.disjunct result + (* CHECK: FTimes and Div are the same, how does the 'when' scope? *) + | BinOp (lel, op, ler) -> ( + let open Syntaxes.Option in + (* If we're reducing A || B or A && B and either side have a reduction exception, it must be false *) + let flel, fler, exn = + try (f lel, f ler, false) with + | ReductionException _ when op = Or || op = And -> + (Expr.false_, Expr.false_, true) + | exn -> raise exn in - let () = PFS.substitution subst new_pfs in - (* We reduce using our new pfs and gamma *) - let re = - reduce_lexpr_loop ~matching ~reduce_lvars new_pfs new_gamma e + let- () = if exn then Some Expr.false_ else None in + let def = Expr.BinOp (flel, op, fler) in + let- () = + match (flel, fler) with + | (Lit _ as ll), (Lit _ as lr) -> ( + try + let lit = CExprEval.evaluate_binop (CStore.init []) op ll lr in + Some (Expr.Lit lit) + with + | CExprEval.TypeError err_msg -> + raise (ReductionException (def, err_msg)) + | CExprEval.EvaluationError err_msg -> + raise (ReductionException (def, err_msg)) + | e -> raise e) + | _ -> None in - let vars = Expr.lvars re in - let bt = List.filter (fun (b, _) -> Containers.SS.mem b vars) bt in - (* We remove all quantifiers that aren't used anymore *) - match bt with - | [] -> re - | _ -> EForall (bt, re)) - (* The remaining cases cannot be reduced *) - | _ -> le + let- () = + reduce_binop_inttonum_const matching reduce_lvars pfs gamma flel fler + op + in + match op with + | Equal when Expr.equal flel fler -> Expr.true_ + | Equal -> ( + (* TODO: Here we don't use the 2nd param, is that ok? *) + let t1, _ = Typing.type_lexpr gamma flel in + let t2, _ = Typing.type_lexpr gamma fler in + let is_type typ = Option.fold ~none:true ~some:(Type.equal typ) in + let- () = + match (t1, t2) with + | Some t1, Some t2 when t1 <> t2 -> Some Expr.false_ + | _, _ -> None + in + match (flel, fler) with + (* Lists *) + | EList [], x | x, EList [] | Lit (LList []), x | x, Lit (LList []) + -> ( + match x with + | Lit (LList (_ :: _)) | EList (_ :: _) -> Expr.false_ + | NOp (LstCat, les) + when List.exists + (function + | Expr.EList (_ :: _) | Lit (LList (_ :: _)) -> true + | _ -> false) + les -> Expr.false_ + | _ -> def) + (* Booleans *) + | Lit (Bool true), _ when t2 = Some Type.BooleanType -> fler + | _, Lit (Bool true) when t1 = Some Type.BooleanType -> flel + (* Nested equalities *) + | Lit (Bool b), (BinOp (_, Equal, _) as e) + | (BinOp (_, Equal, _) as e), Lit (Bool b) + | Lit (Bool b), UnOp (Not, (BinOp (_, Equal, _) as e)) + | UnOp (Not, (BinOp (_, Equal, _) as e)), Lit (Bool b) -> + if b then e else UnOp (Not, e) + (* For two non-LVar lists l1 = h1::tl1, l2 = h2::tl2 + l1 = l2 <=> h1 = h2 /\ tl1 = tl2 + The two 'false' cases are if we can't get the head/tail of a list + while it is a LList/EList, meaning it's definitely empty. + These two cases are likely to have been caught before but who knows. *) + | _, _ + when (match (flel, fler) with + | LVar _, _ | _, LVar _ -> false + | _ -> true) + && is_type Type.ListType t1 && is_type Type.ListType t2 -> ( + let htl1, htl2 = + ( get_head_and_tail_of_list ~pfs flel, + get_head_and_tail_of_list ~pfs fler ) + in + match (htl1, htl2, flel, fler) with + | Some (hl1, tl1), Some (hl2, tl2), _, _ -> + BinOp (BinOp (hl1, Equal, hl2), And, BinOp (tl1, Equal, tl2)) + | None, Some _, (Lit (LList _) | EList _), _ -> Expr.false_ + | Some _, None, _, (Lit (LList _) | EList _) -> Expr.false_ + | _ -> def) + (* FPlus theory -> theory? I would not go that far *) + | _, _ when is_type Type.NumberType t1 && is_type Type.NumberType t2 + -> + let success, le1', le2' = Cnum.cut flel fler in + if success then BinOp (le1', Equal, le2') else def + | le1, le2 when is_type Type.IntType t1 && is_type Type.IntType t2 + -> + let success, le1', le2' = Cint.cut le1 le2 in + if success then BinOp (le1', Equal, le2') else def + | _, _ -> def) + | (FPlus | FMinus) when lexpr_is_number ~gamma def -> + simplify_num_arithmetic_lexpr pfs gamma def + | (IPlus | IMinus) when lexpr_is_int ~gamma def -> + simplify_int_arithmetic_lexpr pfs gamma def + | FTimes when lexpr_is_number ~gamma def -> ( + match (flel, fler) with + (* 1 is the neutral *) + | Lit (Num 1.), x | x, Lit (Num 1.) -> x + | Lit (Num x), _ when x == nan -> Lit (Num nan) + | _, Lit (Num x) when x == nan -> Lit (Num nan) + | BinOp (Lit (Num x), FTimes, y), Lit (Num z) + | Lit (Num z), BinOp (Lit (Num x), FTimes, y) -> + BinOp (Lit (Num (z *. x)), FTimes, y) + (* Rest *) + | _, _ -> def) + | ITimes when lexpr_is_int ~gamma def -> ( + match (flel, fler) with + | Lit (Int z), x when Z.equal z Z.one -> x + | x, Lit (Int z) when Z.equal z Z.one -> x + | (Lit (Int z) as zero), _ when Z.equal z Z.zero -> zero + | _, (Lit (Int z) as zero) when Z.equal z Z.zero -> zero + | BinOp (Lit (Int x), ITimes, y), Lit (Int z) + | Lit (Int z), BinOp (Lit (Int x), ITimes, y) -> + BinOp (Lit (Int (Z.mul z x)), ITimes, y) + | _, _ -> def) + | FDiv when lexpr_is_number ~gamma def -> ( + match (flel, fler) with + (* 1 is the neutral *) + | x, Lit (Num 1.) -> x + | _, _ -> def) + | IDiv when lexpr_is_int ~gamma def -> ( + match (flel, fler) with + | x, Lit (Int o) when Z.equal o Z.one -> x + | _, _ -> def) + | And when lexpr_is_bool gamma def -> ( + match (flel, fler) with + (* 1 is the neutral *) + | Lit (Bool true), x | x, Lit (Bool true) -> x + | Lit (Bool false), _ | _, Lit (Bool false) -> Lit (Bool false) + (* Rest *) + | _, _ -> + let fal, nfal = Option.get @@ Expr.as_boolean_expr flel in + let far, nfar = Option.get @@ Expr.as_boolean_expr fler in + if PFS.mem pfs nfal || PFS.mem pfs nfar then Lit (Bool false) + else if PFS.mem pfs fal then f fler + else if PFS.mem pfs far then f flel + else BinOp (flel, And, fler)) + | Or when lexpr_is_bool gamma def -> ( + match (flel, fler) with + (* 1 is the neutral *) + | Lit (Bool true), _ | _, Lit (Bool true) -> Lit (Bool true) + | Lit (Bool false), x | x, Lit (Bool false) -> x + (* Rest *) + | _, _ -> + let fal, nfal = Option.get @@ Expr.as_boolean_expr flel in + let far, nfar = Option.get @@ Expr.as_boolean_expr fler in + if PFS.mem pfs fal || PFS.mem pfs far then Lit (Bool true) + else if PFS.mem pfs nfal then f fler + else if PFS.mem pfs nfar then f flel + else BinOp (flel, Or, fler)) + | StrCat when lexpr_is_string gamma def -> ( + match (flel, fler) with + (* Empty list is the neutral *) + | x, Lit (String "") | Lit (String ""), x -> x + (* Rest *) + | BinOp (el, StrCat, Lit (String s1)), Lit (String s2) -> + BinOp (el, StrCat, Lit (String (s1 ^ s2))) + | _, _ -> def) + | SetDiff when lexpr_is_set gamma def -> ( + let pfs = PFS.to_list pfs in + if contained_in_union pfs flel fler then ESet [] + else + match (flel, fler) with + | x, y when x = y -> ESet [] + | ESet [], _ -> ESet [] + | x, ESet [] -> x + | ESet left, ESet right + when Expr.all_literals left && Expr.all_literals right -> + ESet Expr.Set.(elements (diff (of_list left) (of_list right))) + | ESet left, s when Expr.all_literals left -> + if List.for_all (fun x -> set_member pfs x s) left then + ESet [] + else def + | ESet left, ESet right -> + L.verbose (fun fmt -> fmt "Inside relevant SetDiff case."); + let candidate_result = + Expr.Set.(elements (diff (of_list left) (of_list right))) + in + L.verbose (fun fmt -> + fmt "Candidate result: %a" + Fmt.(brackets (list ~sep:comma Expr.pp)) + candidate_result); + let result = + if + List.for_all + (fun x -> not_set_member pfs x (ESet right)) + candidate_result + then Expr.ESet candidate_result + else def + in + L.verbose (fun fmt -> fmt "Actual result: %a" Expr.pp result); + result + | NOp (SetUnion, les), _ -> + let diffs = + List.map (fun le -> f (BinOp (le, SetDiff, fler))) les + in + NOp (SetUnion, diffs) + | _, NOp (SetUnion, les) -> + NOp + ( SetInter, + List.map (fun le -> Expr.BinOp (flel, SetDiff, le)) les ) + | x, ESet [ el ] + when List.mem (Expr.UnOp (Not, BinOp (el, SetMem, x))) pfs -> x + | LVar _, _ -> if set_subset pfs flel fler then ESet [] else def + | ESet les, fler when all_different pfs les -> + (* We must know that the elements of les are all different, and for that we need the pure formulae *) + let _, rest = + List.partition (fun x -> set_member pfs x fler) les + in + if List.for_all (fun x -> not_set_member pfs x fler) rest then + ESet rest + else BinOp (ESet rest, SetDiff, fler) + | _, _ -> def) + (* let hM = f (BinOp (flel, SetSub, fler)) in + (match hM with + | Lit (Bool true) -> ESet [] + | _ -> def)) *) + | SetMem when lexpr_is_bool gamma def -> ( + match (flel, fler) with + | _, ESet [] -> Lit (Bool false) + | _, ESet [ x ] -> BinOp (flel, Equal, x) + | le, ESet les -> ( + match List.mem le les with + | true -> Lit (Bool true) + | false -> ( + match le with + | Lit _ -> + if Expr.all_literals les then Lit (Bool false) else def + | _ -> def)) + | _, _ -> def) + | SetSub when lexpr_is_bool gamma def -> ( + match (flel, fler) with + | ESet [], _ -> Lit (Bool true) + | _, ESet [] -> Lit (Bool false) + | ESet left, ESet right + when Expr.all_literals left && Expr.all_literals right -> + Lit + (Bool + (Expr.Set.subset (Expr.Set.of_list left) + (Expr.Set.of_list right))) + | LVar _, NOp (SetUnion, les) -> + if List.mem flel les then Lit (Bool true) else def + | _, _ -> def) + | FLessThan -> + let success, el, er = Cnum.cut flel fler in + if success then Expr.BinOp (el, FLessThan, er) else def + | ILessThan -> ( + match (flel, fler) with + | x, fler + when let fler_len = substitute_for_list_length pfs fler in + match fler_len with + | UnOp (LstLen, _) -> true + | _ -> false -> + BinOp (BinOp (x, IPlus, Lit (Int Z.one)), ILessThanEqual, fler) + | UnOp (LstLen, _), Lit (Int n) when Z.leq n Z.zero -> + Lit (Bool false) + | UnOp (LstLen, le), Lit (Int z) when Z.equal z Z.one -> + BinOp (le, Equal, EList []) + | _ -> + let success, el, er = Cint.cut flel fler in + if success then Expr.BinOp (el, ILessThan, er) else def) + | FLessThanEqual -> ( + let success, el, er = Cnum.cut flel fler in + if success then BinOp (el, FLessThanEqual, er) + else + match + check_ge_zero_num ~top_level:true pfs + (f (BinOp (fler, FMinus, flel))) + with + | Some x -> Lit (Bool x) + | None -> def) + | ILessThanEqual -> ( + let success, el, er = Cint.cut flel fler in + if success then BinOp (el, ILessThanEqual, er) + else + match + check_ge_zero_int ~top_level:true pfs + (f (BinOp (fler, IMinus, flel))) + with + | Some x -> Lit (Bool x) + | None -> def) + | _ -> def) in - let result = normalise_list_expressions result in - if not (Expr.equal le result) then ( + if Expr.equal le result then result + else ( L.tmi (fun m -> m "\tReduce_lexpr: %a -> %a" Expr.pp le Expr.pp result); f result) - else result and reduce_lexpr ?(matching = false) @@ -2111,6 +2233,8 @@ and reduce_lexpr (* let t = Sys.time () in *) let result = reduce_lexpr_loop ~matching ~reduce_lvars pfs gamma le in (* Utils.Statistics.update_statistics "Reduce Expression" (Sys.time () -. t); *) + Logging.normal (fun f -> + f "reduce_lexpr: @[%a -> %a@]" Expr.pp le Expr.pp result); result and simplify_num_arithmetic_lexpr @@ -2144,13 +2268,11 @@ and simplify_int_arithmetic_lexpr | BinOp (l, IPlus, Lit (Int z)) when Z.equal z Z.zero -> l | BinOp (Lit (Int z), IPlus, l) when Z.equal z Z.zero -> l (* Binary minus to unary minus *) + (* Opale: how is this any better? *) | BinOp (l, IMinus, r) -> f (BinOp (l, IPlus, UnOp (IUnaryMinus, r))) (* Unary minus distributes over + *) - | UnOp (IUnaryMinus, e) -> ( - match e with - | BinOp (l, IPlus, r) -> - f (BinOp (UnOp (IUnaryMinus, l), IPlus, UnOp (IUnaryMinus, r))) - | _ -> le) + | UnOp (IUnaryMinus, BinOp (l, IPlus, r)) -> + f (BinOp (UnOp (IUnaryMinus, l), IPlus, UnOp (IUnaryMinus, r))) (* IPlus - we collect the positives and the negatives, see what we have and deal with them *) | BinOp (l, IPlus, r) -> let cl = Cint.of_expr l in @@ -2159,7 +2281,7 @@ and simplify_int_arithmetic_lexpr | _ -> le (** Checks if an int expression is greater than zero. - + @returns [Some true] if definitely > 0, [Some false] if definitely < 0, and [None] if both outcomes are satisfiable. *) and check_ge_zero_int ?(top_level = false) (pfs : PFS.t) (e : Expr.t) : @@ -2171,11 +2293,14 @@ and check_ge_zero_int ?(top_level = false) (pfs : PFS.t) (e : Expr.t) : | UnOp (LstLen, _) | UnOp (StrLen, _) -> Some true | (LVar _ | PVar _) when not top_level -> if - List.exists - (fun pf -> PFS.mem pfs pf) - [ Formula.ILessEq (Expr.zero_i, e); Formula.ILess (Expr.zero_i, e) ] + List.exists (PFS.mem pfs) + [ + Expr.BinOp (Expr.zero_i, ILessThanEqual, e); + Expr.BinOp (Expr.zero_i, ILessThan, e); + ] then Some true - else if PFS.mem pfs (Formula.ILess (e, Expr.zero_i)) then Some false + else if PFS.mem pfs (Expr.BinOp (e, ILessThan, Expr.zero_i)) then + Some false else None | LVar _ | PVar _ -> None | UnOp (IUnaryMinus, _) -> None @@ -2212,9 +2337,13 @@ and check_ge_zero_num ?(top_level = false) (pfs : PFS.t) (e : Expr.t) : if List.exists (fun pf -> PFS.mem pfs pf) - [ Formula.FLessEq (Lit (Num 0.), e); Formula.FLess (Lit (Num 0.), e) ] + [ + Expr.BinOp (Lit (Num 0.), FLessThanEqual, e); + BinOp (Lit (Num 0.), FLessThan, e); + ] then Some true - else if PFS.mem pfs (Formula.FLess (e, Lit (Num 0.))) then Some false + else if PFS.mem pfs (Expr.BinOp (e, FLessThan, Lit (Num 0.))) then + Some false else None | LVar _ | PVar _ -> None | UnOp (FUnaryMinus, _) -> None @@ -2395,11 +2524,11 @@ and substitute_for_list_length (pfs : PFS.t) (le : Expr.t) : Expr.t = List.filter_map (fun pf -> match pf with - | Formula.Eq (UnOp (LstLen, LVar x), lex) + | Expr.BinOp (UnOp (LstLen, LVar x), Equal, lex) when match lex with | UnOp (LstLen, LVar _) | Lit _ -> false | _ -> true -> Some (Expr.LVar x, lex) - | Eq (lex, UnOp (LstLen, LVar x)) + | BinOp (lex, Equal, UnOp (LstLen, LVar x)) when match lex with | UnOp (LstLen, LVar _) | Lit _ -> false | _ -> true -> Some (Expr.LVar x, lex) @@ -2412,638 +2541,84 @@ and substitute_for_list_length (pfs : PFS.t) (le : Expr.t) : Expr.t = let resolve_expr_to_location (pfs : PFS.t) (gamma : Type_env.t) (e : Expr.t) : string option = - let max_fuel = 5 in + let max_fuel = 10 in + + let loc_name = function + | Expr.ALoc loc | Lit (Loc loc) -> Some loc + | _ -> None + in let rec resolve_expr_to_location_aux (fuel : int) (tried : Expr.Set.t) (to_try : Expr.t list) : string option = - let f = resolve_expr_to_location_aux (fuel - 1) in - match fuel = 0 with - | true -> None - | false -> ( - match to_try with - | [] -> None - | e :: _rest -> ( - match e with - | Lit (Loc loc) | ALoc loc -> Some loc - | _ -> ( - let equal_e = get_equal_expressions pfs e in - let equal_e = - equal_e @ List.map (reduce_lexpr ~pfs ~gamma) equal_e - in - let ores = - List.find_opt - (fun x -> - match x with - | Expr.ALoc _ | Lit (Loc _) -> true - | _ -> false) - equal_e - in - match ores with - | Some (ALoc loc) | Some (Lit (Loc loc)) -> Some loc - | _ -> ( - let lvars_e = - List.map - (fun x -> Expr.LVar x) - (Containers.SS.elements (Expr.lvars e)) - in - let found_subst = - List.map - (fun e -> (e, get_equal_expressions pfs e)) - lvars_e - in - let found_subst = - List.filter_map - (fun (e, es) -> - match es with - | [] -> None - | es :: _ -> Some (e, es)) - found_subst - in - let subst_e = - List.fold_left - (fun (e : Expr.t) (e_to, e_with) -> - Expr.subst_expr_for_expr ~to_subst:e_to - ~subst_with:e_with e) - e found_subst - in - let subst_e = reduce_lexpr ~pfs ~gamma subst_e in - match subst_e with - | ALoc loc | Lit (Loc loc) -> Some loc - | _ -> - let new_tried = Expr.Set.add e tried in - let new_to_try = equal_e @ [ subst_e ] in - let new_to_try = - List.filter - (fun e -> not (Expr.Set.mem e new_tried)) - new_to_try - in - f new_tried new_to_try)))) - in - - resolve_expr_to_location_aux max_fuel Expr.Set.empty [ e ] - -let rec reduce_formula_loop - ?(top_level = false) - ?(rpfs = false) - (matching : bool) - (pfs : PFS.t) - (gamma : Type_env.t) - ?(previous = Formula.True) - (a : Formula.t) : Formula.t = - Logging.tmi (fun m -> - m "Reduce formula: %a -> %a" - (fun ft f -> - match f with - | Formula.True -> - Fmt.pf ft "STARTING TO REDUCE: matching %b, rpfs %b" matching rpfs - | _ -> Formula.pp ft f) - previous Formula.pp a); - if Formula.equal a previous then - let () = - Logging.tmi (fun m -> m "Finished reducing, obtained: %a" Formula.pp a) + let open Syntaxes.Option in + L.tmi (fun m -> m "to_try: %a" (Fmt.Dump.list Expr.pp) to_try); + let* () = if fuel <= 0 then None else Some () in + let* e, rest = + match to_try with + | [] -> None + | e :: rest -> Some (e, rest) in - a - else - let f = reduce_formula_loop ~rpfs matching pfs gamma in - let fe = reduce_lexpr_loop ~matching pfs gamma in - let result : Formula.t = - match a with - | Eq (e1, e2) when Expr.equal e1 e2 -> True - (* DEDICATED SIMPLIFICATIONS - this should probably be handled properly by SMT... *) - | Eq (BinOp (Lit (Num x), FPlus, LVar y), LVar z) - when x <> 0. && String.equal y z -> False - | Eq (BinOp (Lit (Int x), IPlus, LVar y), LVar z) - when (not (Z.equal x Z.zero)) && String.equal y z -> False - | ForAll - ( [ (x, Some IntType) ], - Or - ( Or (ILess (LVar a, Lit (Int z)), ILessEq (Lit (Int len), LVar b)), - Eq (BinOp (EList c, LstNth, LVar d), e) ) ) - when Z.equal z Z.zero && String.equal x a && String.equal a b - && String.equal b d - && Int.equal (List.compare_length_with c (Z.to_int len)) 0 -> - let rhs = Expr.EList (List_utils.make (Z.to_int len) e) in - Eq (EList c, rhs) - (* FIXME: INTEGER BYTE-BY-BYTE BREAKDOWN *) - | Eq - ( Lit (Int n), - BinOp (BinOp (Lit (Int tfs), ITimes, LVar b1), IPlus, LVar b0) ) - when top_level && Z.equal tfs _256 - && PFS.mem pfs (ILessEq (Expr.zero_i, LVar b0)) - && PFS.mem pfs (ILessEq (Expr.zero_i, LVar b1)) - && PFS.mem pfs (ILess (LVar b0, Lit (Int _256))) - && PFS.mem pfs (ILess (LVar b1, Lit (Int _256))) -> - if Z.gt n _65535 then False - else - let vb1 = Z.div n _256 in - let vb0 = Z.sub n vb1 in - Formula.And - (Eq (LVar b1, Lit (Int vb1)), Eq (LVar b0, Lit (Int vb0))) - | Eq - ( BinOp (BinOp (Lit (Int tfs), ITimes, LVar b1), IPlus, LVar b0), - Lit (Int n) ) - when top_level && Z.equal tfs _256 - && PFS.mem pfs (ILessEq (Expr.zero_i, LVar b0)) - && PFS.mem pfs (ILessEq (Expr.zero_i, LVar b1)) - && PFS.mem pfs (ILess (LVar b0, Lit (Int _256))) - && PFS.mem pfs (ILess (LVar b1, Lit (Int _256))) -> - if Z.gt n _65535 then False - else - let vb1 = Z.div n _256 in - let vb0 = Z.sub n vb1 in - Formula.And - (Eq (LVar b1, Lit (Int vb1)), Eq (LVar b0, Lit (Int vb0))) - | Eq (BinOp (e, FTimes, Lit (Num x)), Lit (Num 0.)) when x <> 0. -> - Eq (e, Lit (Num 0.)) - | Eq (BinOp (e, ITimes, Lit (Int x)), Lit (Int n)) - when Z.equal n Z.zero && not (Z.equal x Z.zero) -> Eq (e, Expr.zero_i) - | Eq (BinOp (Lit (Num x), FTimes, e), Lit (Num 0.)) when x <> 0. -> - Eq (e, Lit (Num 0.)) - | Eq (BinOp (Lit (Int x), ITimes, e), Lit (Int z)) - when Z.equal z Z.zero && not (Z.equal x Z.zero) -> Eq (e, Expr.zero_i) - | Eq (Lit (LList ll), Lit (LList lr)) -> if ll = lr then True else False - | Eq (EList le, Lit (LList ll)) | Eq (Lit (LList ll), EList le) -> - if List.length ll <> List.length le then False - else if ll = [] then True - else - let eqs = List.map2 (fun x y -> Formula.Eq (x, Lit y)) le ll in - let conj = - List.fold_left - (fun ac x -> Formula.And (ac, x)) - (List.hd eqs) (List.tl eqs) - in - conj - | Eq (EList ll, EList lr) -> - if List.length ll <> List.length lr then False - else if ll = [] then True - else - let eqs = List.map2 (fun x y -> Formula.Eq (x, y)) ll lr in - let conj = - List.fold_left - (fun ac x -> Formula.And (ac, x)) - (List.hd eqs) (List.tl eqs) - in - conj - | Eq (left_list, right_list) - when (match - ( Typing.type_lexpr gamma left_list, - Typing.type_lexpr gamma right_list ) - with - | (Some Type.ListType, _), (Some Type.ListType, _) -> true - | _ -> false) - && - match - fe - (Expr.Infix.( - ) - (Expr.list_length left_list) - (Expr.list_length right_list)) - with - | Expr.Lit (Int k) when not (Z.equal k Z.zero) -> true - | _ -> false -> - (* If we have two lists but can reduce the equality of their lengths to false, - then we know the lists cannot be equal*) - False - | Eq (NOp (LstCat, les), LVar x) - when List.mem (Expr.LVar x) les - && List.exists - (fun e -> - match e with - | Expr.EList (_ :: _) | Lit (LList (_ :: _)) -> true - | _ -> false) - les -> False - | Eq (UnOp (NumToInt, le), re) -> Eq (le, UnOp (IntToNum, re)) - | Eq (le, UnOp (NumToInt, re)) -> Eq (UnOp (IntToNum, le), re) - | And (a1, a2) -> ( - let fa1 = f a1 in - let fa2 = f a2 in - match (fa1, fa2) with - | False, _ | _, False -> False - | True, a | a, True -> a - | _, _ -> And (fa1, fa2)) - | Or (a1, a2) -> ( - let fa1 = f a1 in - let fa2 = f a2 in - match (fa1, fa2) with - | False, a | a, False -> a - | True, _ | _, True -> True - | _, _ -> - if PFS.mem pfs fa1 || PFS.mem pfs fa2 then True - else if PFS.mem pfs (Not fa1) then fa2 - else if PFS.mem pfs (Not fa2) then fa1 - else Or (fa1, fa2)) - (* JOSE: why the recursive call? *) - | Not a -> ( - let fa = f a in - match a with - | True -> False - | False -> True - | Not a -> a - | Or (a1, a2) -> And (Not a1, Not a2) - | And (a1, a2) -> Or (Not a1, Not a2) - | FLess (e1, e2) -> FLessEq (e2, e1) - | FLessEq (e1, e2) -> FLess (e2, e1) - | ILess (e1, e2) -> ILessEq (e2, e1) - | ILessEq (e1, e2) -> ILess (e2, e1) - | _ -> Not fa) - | Eq (e1, e2) -> ( - let re1 = fe e1 in - let re2 = fe e2 in - (* Warning - NaNs, infinities, this and that, this is not good enough *) - let eq = re1 = re2 in - if eq then True - else - let t1, s1 = Typing.type_lexpr gamma re1 in - let t2, s2 = Typing.type_lexpr gamma re2 in - if - s1 && s2 - && - match (t1, t2) with - | Some t1, Some t2 -> t1 <> t2 - | _, _ -> false - then False - else - let ite a b : Formula.t = if a = b then True else False in - let default re1 re2 : Formula.t = Eq (re1, re2) in - match (re1, re2) with - (* DEDICATED RPFS REDUCTIONS *) - | NOp (LstCat, _), LVar y when rpfs && prefix_catch pfs re1 y -> - Eq (UnOp (LstLen, re1), UnOp (LstLen, re2)) - | LVar x, NOp (LstCat, LstSub (y, UnOp (LstLen, z), len) :: t) - when rpfs - && PFS.mem pfs - (Eq (NOp (LstCat, y :: t), NOp (LstCat, [ z; LVar x ]))) - && Cint.canonicalise len - = Cint.canonicalise - (BinOp (UnOp (LstLen, y), IMinus, UnOp (LstLen, z))) - -> True - (* USUAL REDUCTIONS *) - | ALoc _, Lit (Loc _) | Lit (Loc _), ALoc _ -> False - | ALoc x, ALoc y when (not matching) && x <> y -> False - | EList [], x - | x, EList [] - | Lit (LList []), x - | x, Lit (LList []) -> ( - match x with - | Lit (LList lst) when List.length lst > 0 -> False - | EList lst when List.length lst > 0 -> False - | NOp (LstCat, les) -> - if - List.exists - (fun (x : Expr.t) -> - match x with - | EList le when List.length le > 0 -> true - | Lit (LList le) when List.length le > 0 -> true - | _ -> false) - les - then False - else Eq (re1, re2) - | _ -> Eq (re1, re2)) - (* Lifting *) - | Lit (Bool true), BinOp (x, Equal, y) - | BinOp (x, Equal, y), Lit (Bool true) -> Eq (x, y) - | Lit (Bool true), UnOp (UNot, BinOp (x, Equal, y)) -> - Not (Eq (x, y)) - | UnOp (UNot, BinOp (x, Equal, y)), Lit (Bool true) -> - Not (Eq (x, y)) - | Lit (Bool false), BinOp (x, Equal, y) -> Not (Eq (x, y)) - | BinOp (x, Equal, y), Lit (Bool false) -> Not (Eq (x, y)) - | Lit (Bool false), UnOp (UNot, BinOp (x, Equal, y)) -> - Not (Eq (x, y)) - | UnOp (UNot, BinOp (x, Equal, y)), Lit (Bool false) -> - Not (Eq (x, y)) - | UnOp (LstRev, ll), UnOp (LstRev, rl) -> Eq (ll, rl) - (* TODO: This is a specialised simplification, not sure for what, disabled for now - | UnOp (LstRev, full_list), BinOp (UnOp (LstRev, plist_left), LstCat, plist_right) - | BinOp (UnOp (LstRev, plist_left), LstCat, plist_right), UnOp (LstRev, full_list) - -> - f (Eq (full_list, BinOp (UnOp (LstRev, plist_right), LstCat, plist_left))) *) - | LstSub (e1, Lit (Int z), el), e2 - when Z.equal z Z.zero && Expr.equal e1 e2 -> - Eq (UnOp (LstLen, e1), el) - | e2, LstSub (e1, Lit (Int z), el) - when Z.equal z Z.zero && Expr.equal e1 e2 -> - Eq (UnOp (LstLen, e1), el) - | e2, LstSub (NOp (LstCat, e1 :: _), Lit (Int z), el) - when Z.equal z Z.zero && Expr.equal e1 e2 -> - Eq (UnOp (LstLen, e1), el) - | LstSub (NOp (LstCat, e1 :: _), Lit (Int z), el), e2 - when Z.equal z Z.zero && Expr.equal e1 e2 -> - Eq (UnOp (LstLen, e1), el) - | e2, LstSub (NOp (LstCat, e3 :: e1 :: _), ex, ey) - when Expr.equal e1 e2 -> - And (Eq (UnOp (LstLen, e3), ex), Eq (UnOp (LstLen, e1), ey)) - | LstSub (NOp (LstCat, e3 :: e1 :: _), ex, ey), e2 - when Expr.equal e1 e2 -> - And (Eq (UnOp (LstLen, e3), ex), Eq (UnOp (LstLen, e1), ey)) - | NOp (LstCat, fl :: rl), NOp (LstCat, fr :: rr) - when Expr.equal fl fr -> Eq (NOp (LstCat, rl), NOp (LstCat, rr)) - | NOp (LstCat, fl :: rl), NOp (LstCat, fr :: rr) - when Expr.equal - (List.hd (List.rev (fl :: rl))) - (List.hd (List.rev (fr :: rr))) -> - f - (Eq - ( NOp (LstCat, List.rev (List.tl (List.rev (fl :: rl)))), - NOp (LstCat, List.rev (List.tl (List.rev (fr :: rr)))) - )) - | ( LVar lst, - NOp (LstCat, LstSub (LVar lst', Lit (Int z), split) :: _rest) - ) - when Z.equal z Z.zero && String.equal lst lst' - && PFS.mem pfs (ILess (UnOp (LstLen, LVar lst), split)) -> - False - | le1, le2 - when (match le1 with - | LVar _ -> false - | _ -> true) - && (match le2 with - | LVar _ -> false - | _ -> true) - && lexpr_is_list gamma le1 && lexpr_is_list gamma le2 -> ( - let htl1, htl2 = - ( get_head_and_tail_of_list ~pfs le1, - get_head_and_tail_of_list ~pfs le2 ) - in - match (htl1, htl2) with - | Some (hl1, tl1), Some (hl2, tl2) -> - And (Eq (hl1, hl2), Eq (tl1, tl2)) - | None, Some _ -> ( - match le1 with - | Lit (LList _) | EList _ -> False - | _ -> Eq (re1, re2)) - | Some _, None -> ( - match le2 with - | Lit (LList _) | EList _ -> False - | _ -> Eq (re1, re2)) - | None, None -> Eq (re1, re2)) - (* Strings #1 *) - | Lit (String ls), BinOp (Lit (String rs), StrCat, s) - | BinOp (Lit (String rs), StrCat, s), Lit (String ls) -> ( - let lls = String.length ls in - let lrs = String.length rs in - match Stdlib.compare lls lrs with - | -1 -> False - | 0 -> if ls <> rs then False else Eq (s, Lit (String "")) - | 1 -> - let sub = String.sub ls 0 lrs in - if sub <> rs then False - else Eq (s, Lit (String (String.sub ls lrs (lls - lrs)))) - | _ -> - raise - (Exceptions.Impossible - "reduce_formula: string stuff: guaranteed by \ - match/filter")) - (* String #2 *) - | BinOp (sl1, StrCat, sr1), BinOp (sl2, StrCat, sr2) - when sl1 = sl2 -> Eq (sr1, sr2) - | BinOp (sl1, StrCat, sr1), BinOp (sl2, StrCat, sr2) - when sr1 = sr2 -> Eq (sl1, sl2) - (* String #3 *) - | BinOp (sl, StrCat, sr), s when sl = s -> Eq (sr, Lit (String "")) - | BinOp (sl, StrCat, sr), s when sr = s -> Eq (sl, Lit (String "")) - | s, BinOp (sl, StrCat, sr) when sl = s -> Eq (sr, Lit (String "")) - | s, BinOp (sl, StrCat, sr) when sr = s -> Eq (sl, Lit (String "")) - | BinOp (sl, StrCat, sr), Lit (String "") -> - And (Eq (sl, Lit (String "")), Eq (sr, Lit (String ""))) - (* Num-to-String injectivity *) - | UnOp (ToStringOp, le1), UnOp (ToStringOp, le2) -> Eq (le1, le2) - (* Num-to-String understanding *) - | UnOp (ToStringOp, le1), Lit (String s) - | Lit (String s), UnOp (ToStringOp, le1) -> ( - match s with - | "" -> False - | "Infinity" | "-Infinity" | "NaN" -> default re1 re2 - | _ -> ( - let num = try Some (Float.of_string s) with _ -> None in - match num with - | Some num -> Eq (le1, Lit (Num num)) - | None -> False)) - (* The empty business *) - | _, Lit Empty -> ( - match re1 with - | Lit l when l <> Empty -> False - | EList _ | ESet _ -> False - | _ -> default re1 re2) - | Lit l1, Lit l2 -> ite l1 l2 - | Lit Nono, PVar _ | PVar _, Lit Nono -> default re1 re2 - (* JOSE: Why are we considering the case of a logical variable being bound to None? *) - | Lit Nono, LVar x | LVar x, Lit Nono -> ( - let tx = Type_env.get gamma x in - match tx with - | None | Some NoneType -> default re1 re2 - | _ -> False) - | Lit Nono, _ | _, Lit Nono -> False - | Lit (Bool true), BinOp (e1, FLessThan, e2) -> FLess (e1, e2) - | Lit (Bool false), BinOp (e1, FLessThan, e2) -> - Not (FLess (e1, e2)) - | Lit (Bool true), BinOp (e1, ILessThan, e2) -> ILess (e1, e2) - | Lit (Bool false), BinOp (e1, ILessThan, e2) -> - Not (ILess (e1, e2)) - (* FPlus theory -> theory? I would not go that far *) - | le1, le2 when lexpr_is_number le1 && lexpr_is_number le2 -> - let success, le1', le2' = Cnum.cut le1 le2 in - if success then Eq (le1', le2') else Eq (le1, le2) - | le1, le2 when lexpr_is_int le1 && lexpr_is_int le2 -> - let success, le1', le2' = Cint.cut le1 le2 in - if success then Eq (le1', le2') else Eq (le1, le2) - (* Very special cases *) - | UnOp (TypeOf, BinOp (_, StrCat, _)), Lit (Type t) - when t <> StringType -> False - | UnOp (TypeOf, BinOp (_, BSetMem, _)), Lit (Type t) - when t <> BooleanType -> False - (* Set unions *) - | ( NOp (SetUnion, [ ls; ESet [ lx ] ]), - NOp (SetUnion, [ rs; ESet [ rx ] ]) ) - when lx = rx -> - if - PFS.mem pfs (Not (SetMem (lx, ls))) - && PFS.mem pfs (Not (SetMem (lx, rs))) - then Eq (ls, rs) - else default re1 re2 - | _, _ -> default re1 re2) - | FLess (e1, e2) -> - if PFS.mem pfs (FLessEq (e2, e1)) then False - else if PFS.mem pfs (FLess (e2, e1)) then False - else - let le = Option.get (Formula.to_expr (FLess (e1, e2))) in - let re = fe le in - let result, _ = Option.get (Formula.lift_logic_expr re) in - result - | ILess (e1, e2) -> - if PFS.mem pfs (ILessEq (e2, e1)) then False - else if PFS.mem pfs (ILess (e2, e1)) then False - else - let le = Option.get (Formula.to_expr (ILess (e1, e2))) in - let re = fe le in - let result, _ = Option.get (Formula.lift_logic_expr re) in - result - | ILessEq (Lit (Int z), UnOp (LstLen, _)) when Z.equal z Z.zero -> True - | FLessEq (e1, e2) -> - if PFS.mem pfs (FLessEq (e2, e1)) then Eq (e1, e2) - else if PFS.mem pfs (FLess (e1, e2)) then True - else if PFS.mem pfs (FLess (e2, e1)) then False - else - let le = Option.get (Formula.to_expr (FLessEq (e1, e2))) in - let re = fe le in - let result, _ = Option.get (Formula.lift_logic_expr re) in - result - | ILessEq (e1, e2) -> - if PFS.mem pfs (ILessEq (e2, e1)) then Eq (e1, e2) - else if PFS.mem pfs (ILess (e1, e2)) then True - else if PFS.mem pfs (ILess (e2, e1)) then False - else - let le = Option.get (Formula.to_expr (ILessEq (e1, e2))) in - let re = fe le in - let result, _ = Option.get (Formula.lift_logic_expr re) in - result - | SetMem (leb, NOp (SetUnion, lle)) -> - let rleb = fe leb in - let formula : Formula.t = - match lle with - | [] -> False - | le :: lle -> - let rle = fe le in - List.fold_left - (fun ac le : Formula.t -> - let rle = fe le in - Or (ac, SetMem (rleb, rle))) - (SetMem (rleb, rle)) - lle - in - formula - | SetMem (leb, NOp (SetInter, lle)) -> - let rleb = fe leb in - let formula : Formula.t = - match lle with - | [] -> False - | le :: lle -> - let rle = fe le in - List.fold_left - (fun ac le : Formula.t -> - let rle = fe le in - And (ac, SetMem (rleb, rle))) - (SetMem (rleb, rle)) - lle - in - formula - | SetMem (leb, BinOp (lel, SetDiff, ler)) -> - let rleb = fe leb in - let rlel = fe lel in - let rler = fe ler in - And (SetMem (rleb, rlel), Not (SetMem (rleb, rler))) - | SetMem (leb, ESet les) -> - let rleb = fe leb in - let rles = List.map (fun le -> fe le) les in - let result : Formula.t list = - List.map (fun le : Formula.t -> Eq (rleb, le)) rles - in - List.fold_left - (fun ac eq : Formula.t -> - match (ac : Formula.t) with - | False -> eq - | _ -> Or (ac, eq)) - False result - | IsInt e -> ( - match fe e with - | UnOp (UnOp.IntToNum, e) -> ( - let t, _ = Typing.type_lexpr gamma e in - match t with - | Some IntType -> True - | Some _ -> False - | None -> f @@ Eq (UnOp (TypeOf, e), Lit (Type IntType))) - | _ -> a) - | Impl (left, right) -> ( - let pfs_with_left = - let copy = PFS.copy pfs in - let () = PFS.extend copy left in - copy - in - let reduced_left = - reduce_formula_loop ~rpfs:true matching pfs_with_left gamma left - in - match (reduced_left, f right) with - | True, _ -> right - | False, _ | _, True -> True - | _, False -> f (Not left) - | _ -> Impl (left, right)) - | ForAll - ( [ (i, Some IntType) ], - Impl - ( And - ( ILessEq (Lit (Int z), LVar i'), - ILess (LVar i'', UnOp (LstLen, l)) ), - Eq (BinOp (l', LstNth, LVar i'''), k) ) ) - when Z.(equal z zero) - && i = i' && i' = i'' && i'' = i''' && Expr.equal l l' - && - match l with - | EList _ -> true - | _ -> false -> - let l = - match l with - | EList l -> l - | _ -> failwith "unreachable" - in - List.map (fun x -> Formula.Infix.(x #== k)) l - |> List.fold_left Formula.Infix.( #&& ) Formula.True - | ForAll (bt, a) -> ( - (* We create a new pfs and gamma where: - - All shadowed variables are substituted with a fresh variable - - The gamma has been updated with the types given in the binder *) - let new_gamma = Type_env.copy gamma in - let new_pfs = PFS.copy pfs in - let subst_bindings = List.map (fun (x, _) -> (x, LVar.alloc ())) bt in - let subst = - SVal.SESubst.init - (List.map - (fun (x, y) -> (Expr.LVar x, Expr.LVar y)) - subst_bindings) - in - let () = - List.iter - (fun (x, t) -> - let () = - match Type_env.get new_gamma x with - | Some t -> - let new_var = List.assoc x subst_bindings in - Type_env.update new_gamma new_var t - | None -> () - in - match t with - | Some t -> Type_env.update new_gamma x t - | None -> Type_env.remove new_gamma x) - bt + let f = resolve_expr_to_location_aux (fuel - 1) in + (* If e is a loc name, we return it *) + let/ () = loc_name e in + let equal_e = get_equal_expressions pfs e in + let equal_e = equal_e @ List.map (reduce_lexpr ~pfs ~gamma) equal_e in + (* If we find a loc in there, we return it *) + let/ () = List.find_map loc_name equal_e in + (* We actually want to try all possible substs! *) + let all_lvars = Containers.SS.elements (Expr.lvars e) in + let subst_for_each_lvar = + List.map + (fun x -> + let e = Expr.LVar x in + let with_eq = + List.map (fun eq -> (e, eq)) (get_equal_expressions pfs e) in - let () = PFS.substitution subst new_pfs in - (* We reduce using our new pfs and gamma *) - let ra = reduce_formula_loop ~rpfs matching new_pfs new_gamma a in - let vars = Formula.lvars ra in - let bt = List.filter (fun (b, _) -> Containers.SS.mem b vars) bt in - (* We remove all quantifiers that aren't used anymore *) - match bt with - | [] -> ra - | _ -> ForAll (bt, ra)) - | _ -> a + (e, e) :: with_eq) + all_lvars in - - f ~previous:a result - -let reduce_formula - ?(matching = false) - ?(rpfs = false) - ?time:_ - ?(pfs : PFS.t = PFS.init ()) - ?(gamma = Type_env.init ()) - (a : Formula.t) : Formula.t = - reduce_formula_loop ~top_level:true ~rpfs matching pfs gamma a + L.tmi (fun m -> + m "subst_for_each_lvar: %a" + (Fmt.Dump.list (Fmt.Dump.list (Fmt.Dump.pair Expr.pp Expr.pp))) + subst_for_each_lvar); + let found_substs = + List.fold_left + (fun l1 l2 -> List_utils.cross_product l1 l2 (fun l x -> x :: l)) + [ [] ] subst_for_each_lvar + in + L.tmi (fun m -> + m "found_substs: %a" + (Fmt.Dump.list (Fmt.Dump.list (Fmt.Dump.pair Expr.pp Expr.pp))) + found_substs); + (* lvar and substs is a list [ (ei, esi) ] where for each ei, esi is a list of equal expressions. + We are going to build the product of each esi to obtain *) + let subst_es = + List.map + (List.fold_left + (fun (e : Expr.t) (e_to, e_with) -> + Expr.subst_expr_for_expr ~to_subst:e_to ~subst_with:e_with e) + e) + found_substs + in + L.tmi (fun m -> m "subst_es: %a" (Fmt.Dump.list Expr.pp) subst_es); + let subst_es = List.map (reduce_lexpr ~pfs ~gamma) subst_es in + let/ () = List.find_map loc_name subst_es in + let new_tried = Expr.Set.add e tried in + let new_to_try = rest @ equal_e @ subst_es in + let new_to_try = + List.filter (fun e -> not (Expr.Set.mem e new_tried)) new_to_try + in + f new_tried new_to_try + in + resolve_expr_to_location_aux max_fuel Expr.Set.empty [ e ] let relate_llen (pfs : PFS.t) (gamma : Type_env.t) (e : Expr.t) - (lcat : Expr.t list) : (Formula.t * Containers.SS.t) option = + (lcat : Expr.t list) : (Expr.t * Containers.SS.t) option = (* Loop *) let rec relate_llen_loop (llen : Cint.t) @@ -3114,15 +2689,15 @@ let relate_llen | [] -> [] | _ -> [ Expr.EList new_lvars ] in - let pf = Formula.Eq (e, NOp (LstCat, les @ new_lvars)) in - L.verbose (fun fmt -> fmt "Constructed equality: %a" Formula.pp pf); + let pf = Expr.BinOp (e, Equal, NOp (LstCat, les @ new_lvars)) in + L.verbose (fun fmt -> fmt "Constructed equality: %a" Expr.pp pf); (pf, Containers.SS.of_list new_vars) | false, exp -> let rest_var = LVar.alloc () in let rest = Expr.LVar rest_var in - let pfeq = Formula.Eq (e, NOp (LstCat, les @ [ rest ])) in - let pflen = Formula.Eq (UnOp (LstLen, rest), exp) in - (Formula.And (pfeq, pflen), Containers.SS.singleton rest_var) + let pfeq = Expr.BinOp (e, Equal, NOp (LstCat, les @ [ rest ])) in + let pflen = Expr.BinOp (UnOp (LstLen, rest), Equal, exp) in + (Expr.BinOp (pfeq, And, pflen), Containers.SS.singleton rest_var) | _ -> failwith "Impossible by construction") (relate_llen_loop llen [] lcat) in @@ -3142,7 +2717,7 @@ let understand_lstcat (pfs : PFS.t) (gamma : Type_env.t) (lcat : Expr.t list) - (rcat : Expr.t list) : (Formula.t * Containers.SS.t) option = + (rcat : Expr.t list) : (Expr.t * Containers.SS.t) option = L.tmi (fun fmt -> fmt "Understanding LstCat: %a, %a" Fmt.(brackets (list ~sep:semi Expr.pp)) @@ -3172,59 +2747,52 @@ end module ETSet = Set.Make (MyET) let reduce_types (a : Asrt.t) : Asrt.t = - let rec separate (a : Asrt.t) = - match a with - | Pure True -> ([], []) - | Pure False -> raise PFSFalse - | Pure (Eq (UnOp (TypeOf, e), Lit (Type t))) - | Pure (Eq (Lit (Type t), UnOp (TypeOf, e))) -> ([], [ (e, t) ]) - | Star (a1, a2) -> - let fa1, ft1 = separate a1 in - let fa2, ft2 = separate a2 in - (fa1 @ fa2, ft1 @ ft2) - | Types ets -> ([], ets) - | _ -> ([ a ], []) - in - try - let others, ets = separate a in + let others, ets = + List.fold_left + (fun (others, ets) -> function + | Asrt.Pure (Lit (Bool true)) -> (others, ets) + | Asrt.Pure (Lit (Bool false)) -> raise PFSFalse + | Asrt.Pure (BinOp (UnOp (TypeOf, e), Equal, Lit (Type t))) + | Asrt.Pure (BinOp (Lit (Type t), Equal, UnOp (TypeOf, e))) -> + (others, (e, t) :: ets) + | Asrt.Types ets' -> (others, ets' @ ets) + | a -> (a :: others, ets)) + ([], []) a + in let ets = ETSet.elements (ETSet.of_list ets) in match (others, ets) with - | [], [] -> Pure True - | [], ets -> Types ets - | a, ets -> - let result = Asrt.star a in - if ets = [] then result else Star (Types ets, result) - with PFSFalse -> Pure False + | [], [] -> [ Asrt.Pure (Lit (Bool true)) ] (* Could this be []? *) + | [], ets -> [ Asrt.Types ets ] + | others, [] -> others + | others, ets -> Asrt.Types ets :: others + with PFSFalse -> [ Asrt.Pure (Lit (Bool false)) ] (* Reduction of assertions *) -let rec reduce_assertion_loop +let reduce_assertion_loop (matching : bool) (pfs : PFS.t) (gamma : Type_env.t) (a : Asrt.t) : Asrt.t = - let f = reduce_assertion_loop matching pfs gamma in let fe = reduce_lexpr_loop ~matching pfs gamma in - let result = - match a with + let f : Asrt.atom -> Asrt.t = function (* Empty heap *) - | Emp -> Asrt.Emp + | Asrt.Emp -> [] (* Star *) - | Star (a1, a2) -> ( - match (f a1, f a2) with - | Emp, a | a, Emp -> a - | Pure False, _ | _, Pure False -> Asrt.Pure False - | Pure True, a | a, Pure True -> a - | fa1, fa2 -> Star (fa1, fa2)) | Wand { lhs = lname, largs; rhs = rname, rargs } -> - Wand - { lhs = (lname, List.map fe largs); rhs = (rname, List.map fe rargs) } + [ + Wand + { + lhs = (lname, List.map fe largs); + rhs = (rname, List.map fe rargs); + }; + ] (* Predicates *) - | Pred (name, les) -> Pred (name, List.map fe les) + | Pred (name, les) -> [ Pred (name, List.map fe les) ] (* Pure assertions *) - | Pure True -> Emp - | Pure f -> Pure (reduce_formula_loop ~top_level:true matching pfs gamma f) + | Pure (Lit (Bool true)) -> [] + | Pure f -> [ Pure (reduce_lexpr ~matching ~pfs ~gamma f) ] (* Types *) | Types lvt -> ( try @@ -3232,29 +2800,34 @@ let rec reduce_assertion_loop List.fold_right (fun (e, t) ac -> match (e : Expr.t) with - | Lit lit -> - if t <> Literal.type_of lit then raise WrongType else ac + | Lit lit when t <> Literal.type_of lit -> raise WrongType + | Lit _ -> ac | _ -> (e, t) :: ac) lvt [] in - if lvt = [] then Emp else Types lvt - with WrongType -> Pure False) + if lvt = [] then [] else [ Types lvt ] + with WrongType -> [ Pure (Lit (Bool false)) ]) (* General action *) - | GA (act, l_ins, l_outs) -> GA (act, List.map fe l_ins, List.map fe l_outs) + | CorePred (act, l_ins, l_outs) -> + [ CorePred (act, List.map fe l_ins, List.map fe l_outs) ] + in + let result = List.concat_map f a in + let result = + if List.mem (Asrt.Pure (Lit (Bool false))) result then + [ Asrt.Pure (Lit (Bool false)) ] + else result in - if a <> result && not (a == result) then ( - L.(tmi (fun m -> m "Reduce_assertion: %a -> %a" Asrt.pp a Asrt.pp result)); - f result) - else result + (if a <> result && not (a == result) then + L.(tmi (fun m -> m "Reduce_assertion: %a -> %a" Asrt.pp a Asrt.pp result))); + result -let rec extract_lvar_equalities (a : Asrt.t) = - match a with - | Pure (Eq (LVar x, v) | Eq (v, LVar x)) -> - if Names.is_lvar_name x && not (Names.is_spec_var_name x) then [ (x, v) ] - else [] - | Star (a1, a2) -> extract_lvar_equalities a1 @ extract_lvar_equalities a2 - | _ -> [] +let extract_lvar_equalities : Asrt.t -> (string * Expr.t) list = + List.filter_map @@ function + | Asrt.Pure (BinOp (LVar x, Equal, v) | BinOp (v, Equal, LVar x)) -> + if Names.is_lvar_name x && not (Names.is_spec_var_name x) then Some (x, v) + else None + | _ -> None let reduce_assertion ?(matching = false) @@ -3286,6 +2859,4 @@ let reduce_assertion loop a let is_tautology ?pfs ?gamma formula = - match reduce_formula ?pfs ?gamma formula with - | True -> true - | _ -> false + reduce_lexpr ?pfs ?gamma formula = Lit (Bool true) diff --git a/GillianCore/engine/FOLogic/Reduction.mli b/GillianCore/engine/FOLogic/Reduction.mli index bad6f5c5..dfa70eab 100644 --- a/GillianCore/engine/FOLogic/Reduction.mli +++ b/GillianCore/engine/FOLogic/Reduction.mli @@ -18,7 +18,7 @@ val understand_lstcat : Type_env.t -> Expr.t list -> Expr.t list -> - (Formula.t * Containers.SS.t) option + (Expr.t * Containers.SS.t) option (** [reduce_lexpr ?matching ?reduce_lvars ?pfs ?gamma e] reduces the expression [e] given (optional) pure formulae [pfs] and typing environment [gamma]. @@ -31,18 +31,6 @@ val reduce_lexpr : Gil_syntax.Expr.t -> Gil_syntax.Expr.t -(** [reduce_formula ?matching ?pfs ?gamma pf] reduces the formula [pf] - given (optional) pure formulae [pfs] and typing environment [gamma]. - The [matching] flag should not be used by Gillian instantiation developers. *) -val reduce_formula : - ?matching:bool -> - ?rpfs:bool -> - ?time:string -> - ?pfs:PFS.t -> - ?gamma:Type_env.t -> - Gil_syntax.Formula.t -> - Gil_syntax.Formula.t - (** [reduce_assertion ?matching ?pfs ?gamma a] reduces the assertion [a] given (optional) pure formulae [pfs] and typing environment [gamma]. The [matching] flag should not be used by Gillian instantiation developers. *) @@ -53,5 +41,4 @@ val reduce_assertion : Gil_syntax.Asrt.t -> Gil_syntax.Asrt.t -val is_tautology : - ?pfs:PFS.t -> ?gamma:Type_env.t -> Gil_syntax.Formula.t -> bool +val is_tautology : ?pfs:PFS.t -> ?gamma:Type_env.t -> Gil_syntax.Expr.t -> bool diff --git a/GillianCore/engine/FOLogic/Simplifications.ml b/GillianCore/engine/FOLogic/Simplifications.ml index 3603cfec..a6a856ec 100644 --- a/GillianCore/engine/FOLogic/Simplifications.ml +++ b/GillianCore/engine/FOLogic/Simplifications.ml @@ -5,7 +5,7 @@ module SB = Containers.SB type simpl_key_type = { kill_new_lvars : bool option; gamma_list : (Var.t * Type.t) list; - pfs_list : Formula.t list; + pfs_list : Expr.t list; existentials : SS.t; matching : bool; save_spec_vars : (SS.t * bool) option; (* rpfs_lvars : CCommon.SS.t *) @@ -13,7 +13,7 @@ type simpl_key_type = { type simpl_val_type = { simpl_gamma : (Var.t * Type.t) list; - simpl_pfs : Formula.t list; + simpl_pfs : Expr.t list; simpl_existentials : SS.t; subst : SVal.SESubst.t; } @@ -30,7 +30,7 @@ let simplification_cache : (simpl_key_type, simpl_val_type) Hashtbl.t = (*************************************) let reduce_pfs_in_place ?(matching = false) _ gamma (pfs : PFS.t) = - PFS.map_inplace (Reduction.reduce_formula ~matching ~gamma ~pfs) pfs + PFS.map_inplace (Reduction.reduce_lexpr ~matching ~gamma ~pfs) pfs let sanitise_pfs ?(matching = false) store gamma pfs = let old_pfs = ref (PFS.init ()) in @@ -50,24 +50,25 @@ let sanitise_pfs_no_store ?(matching = false) = let clean_up_stuff (left : PFS.t) (right : PFS.t) = let sleft = PFS.to_set left in let pf_sym pfa pfb = - match ((pfa, pfb) : Formula.t * Formula.t) with - | Eq (a, b), Eq (c, d) when a = d && b = c -> true - | Not (Eq (a, b)), Not (Eq (c, d)) when a = d && b = c -> true + match ((pfa, pfb) : Expr.t * Expr.t) with + | BinOp (a, Equal, b), BinOp (c, Equal, d) when a = d && b = c -> true + | UnOp (Not, BinOp (a, Equal, b)), UnOp (Not, BinOp (c, Equal, d)) + when a = d && b = c -> true | _ -> false in let eq_or_sym pfa pfb = pfa = pfb || pf_sym pfa pfb in - let keep pf = not (Formula.Set.exists (eq_or_sym pf) sleft) in + let keep pf = not (Expr.Set.exists (eq_or_sym pf) sleft) in let cond pf = let npf = match pf with - | Formula.Not pf -> pf - | _ -> Not pf + | Expr.UnOp (Not, pf) -> pf + | _ -> UnOp (Not, pf) in - Formula.Set.exists (eq_or_sym npf) sleft + Expr.Set.exists (eq_or_sym npf) sleft in if PFS.filter_stop_cond ~keep ~cond right then let () = PFS.clear right in - PFS.set left [ False ] + PFS.set left [ Expr.false_ ] (* Set intersections *) let get_num_set_intersections pfs = @@ -76,16 +77,22 @@ let get_num_set_intersections pfs = List.iter (fun pf -> - match (pf : Formula.t) with + match (pf : Expr.t) with | ForAll ( [ (x, Some NumberType) ], - Or (Not (SetMem (LVar y, LVar set)), FLess (LVar elem, LVar z)) ) + BinOp + ( UnOp (Not, BinOp (LVar y, SetMem, LVar set)), + Or, + BinOp (LVar elem, FLessThan, LVar z) ) ) when x = y && x = z -> L.(verbose (fun m -> m "Got left: %s, %s" elem set)); Hashtbl.add lvars elem set | ForAll ( [ (x, Some NumberType) ], - Or (Not (SetMem (LVar y, LVar set)), FLess (LVar z, LVar elem)) ) + BinOp + ( UnOp (Not, BinOp (LVar y, SetMem, LVar set)), + Or, + BinOp (LVar z, FLessThan, LVar elem) ) ) when x = y && x = z -> L.(verbose (fun m -> m "Got right: %s, %s" elem set)); Hashtbl.add rvars elem set @@ -133,8 +140,8 @@ let get_num_set_intersections pfs = (* 4. *) List.iter (fun a -> - match (a : Formula.t) with - | FLess (LVar v1, LVar v2) -> ( + match (a : Expr.t) with + | BinOp (LVar v1, FLessThan, LVar v2) -> ( match (Hashtbl.mem lvars v1, Hashtbl.mem lvars v2) with | true, true -> intersections := @@ -181,35 +188,25 @@ let _resolve_set_existentials (List.map (fun e -> (Fmt.to_to_string Expr.pp) e) s)) intersections)))); - let filter_map_fun (formula_to_filter : Formula.t) = + let filter_map_fun (formula_to_filter : Expr.t) = match formula_to_filter with - | Eq (NOp (SetUnion, ul), NOp (SetUnion, ur)) -> + | BinOp (NOp (SetUnion, ul), Equal, NOp (SetUnion, ur)) -> (* Expand ESets *) - let ul = - List.flatten - (List.map - (fun (u : Expr.t) : Expr.t list -> - match (u : Expr.t) with - | ESet x -> - List.map (fun (x : Expr.t) : Expr.t -> ESet [ x ]) x - | _ -> [ u ]) - ul) - in - let ur = - List.flatten - (List.map - (fun (u : Expr.t) : Expr.t list -> - match u with - | ESet x -> List.map (fun x : Expr.t -> ESet [ x ]) x - | _ -> [ u ]) - ur) + let aux e = + List.concat_map + (function + | Expr.ESet x -> List.map (fun x : Expr.t -> ESet [ x ]) x + | u -> [ u ]) + e in + let ul = aux ul in + let ur = aux ur in let sul = Expr.Set.of_list ul in let sur = Expr.Set.of_list ur in L.verbose (fun m -> m "Resolve set existentials: I have found a union equality."); - L.verbose (fun m -> m "%a" Formula.pp formula_to_filter); + L.verbose (fun m -> m "%a" Expr.pp formula_to_filter); (* Trying to cut the union *) let same_parts = Expr.Set.inter sul sur in @@ -291,7 +288,7 @@ let _resolve_set_existentials Type_env.remove gamma v done; None - | _ -> Some (Formula.Eq (lhs, rhs)) + | _ -> Some (Expr.BinOp (lhs, Equal, rhs)) else Some formula_to_filter) else Some formula_to_filter | _ -> Some formula_to_filter @@ -342,9 +339,9 @@ let simplify_pfs_and_gamma PFS.set lpfs simpl_pfs; (* Deal with rpfs *) - if PFS.length lpfs > 0 && PFS.get_nth 0 lpfs == Some False then ( + if PFS.length lpfs > 0 && PFS.get_nth 0 lpfs == Some Expr.false_ then ( PFS.clear rpfs; - PFS.extend rpfs True); + PFS.extend rpfs Expr.true_); (SESubst.copy subst, simpl_existentials) | false -> @@ -378,9 +375,9 @@ let simplify_pfs_and_gamma (* Pure formulae false *) let pfs_false lpfs rpfs : unit = PFS.clear lpfs; - PFS.extend lpfs False; + PFS.extend lpfs Expr.false_; PFS.clear rpfs; - PFS.extend rpfs True + PFS.extend rpfs Expr.true_ in let stop_explain (msg : string) : [> `Stop ] = @@ -388,12 +385,12 @@ let simplify_pfs_and_gamma `Stop in (* PF simplification *) - let rec filter_mapper_formula (pfs : PFS.t) (pf : Formula.t) : - [ `Stop | `Replace of Formula.t | `Filter ] = + let rec filter_mapper_formula (pfs : PFS.t) (pf : Expr.t) : + [ `Stop | `Replace of Expr.t | `Filter ] = (* Reduce current assertion *) let rec_call = filter_mapper_formula pfs in let extend_with = PFS.extend pfs in - let whole = Reduction.reduce_formula ~matching ~gamma ~pfs pf in + let whole = Reduction.reduce_lexpr ~matching ~gamma ~pfs pf in match whole with (* These we must not encounter here *) | ForAll (bt, _) -> @@ -401,15 +398,15 @@ let simplify_pfs_and_gamma List.iter (fun x -> Type_env.remove gamma x) lx; `Replace whole (* And is expanded *) - | And (a1, a2) -> + | BinOp (a1, And, a2) -> extend_with a2; rec_call a1 (* If we find true, we can delete it *) - | True -> `Filter + | Lit (Bool true) -> `Filter (* If we find false, the entire pfs are false *) - | False -> stop_explain "False in pure formulae" + | Lit (Bool false) -> stop_explain "False in pure formulae" (* Inequality of things with different types *) - | Not (Eq (le1, le2)) -> ( + | UnOp (Not, BinOp (le1, Equal, le2)) -> ( let te1, _ = Typing.type_lexpr gamma le1 in let te2, _ = Typing.type_lexpr gamma le2 in match (te1, te2) with @@ -420,8 +417,8 @@ let simplify_pfs_and_gamma || te1 = NoneType) -> stop_explain "Inequality of two undefined/null/empty/none" | _ -> `Replace whole) - | Eq (BinOp (lst, LstNth, idx), elem) - | Eq (elem, BinOp (lst, LstNth, idx)) -> ( + | BinOp (BinOp (lst, LstNth, idx), Equal, elem) + | BinOp (elem, Equal, BinOp (lst, LstNth, idx)) -> ( match idx with | Lit (Int nx) -> let prepend_lvars = @@ -435,36 +432,39 @@ let simplify_pfs_and_gamma let prepend = List.map (fun x -> Expr.LVar x) prepend_lvars in let append = Expr.LVar append_lvar in rec_call - (Eq + (BinOp ( lst, + Equal, NOp ( LstCat, [ EList (List.append prepend [ elem ]); append ] ) )) | Lit (Num _) -> failwith "l-nth(l, f) where f is Num and not Int!" | _ -> `Replace whole) - | Eq (UnOp (LstLen, le), Lit (Int z)) when Z.equal z Z.zero -> - rec_call (Eq (le, EList [])) - | Eq (Lit (Int z), UnOp (LstLen, le)) when Z.equal z Z.zero -> - rec_call (Eq (le, EList [])) - | Eq (UnOp (LstLen, le), Lit (Int len)) - | Eq (Lit (Int len), UnOp (LstLen, le)) + | BinOp (UnOp (LstLen, le), Equal, Lit (Int z)) when Z.equal z Z.zero -> + rec_call (BinOp (le, Equal, EList [])) + | BinOp (Lit (Int z), Equal, UnOp (LstLen, le)) when Z.equal z Z.zero -> + rec_call (BinOp (le, Equal, EList [])) + | BinOp (UnOp (LstLen, le), Equal, Lit (Int len)) + | BinOp (Lit (Int len), Equal, UnOp (LstLen, le)) when (not matching) && Z.leq len (Z.of_int 100) -> let len = Z.to_int len in if len >= 0 then ( let le_vars = List.init len (fun _ -> LVar.alloc ()) in vars_to_kill := SS.union !vars_to_kill (SS.of_list le_vars); let le' = List.map (fun x -> Expr.LVar x) le_vars in - rec_call (Eq (le, EList le'))) + rec_call (BinOp (le, Equal, EList le'))) else stop_explain "List length an unexpected integer." - | Eq (NOp (LstCat, les), EList []) - | Eq (NOp (LstCat, les), Lit (LList [])) - | Eq (EList [], NOp (LstCat, les)) - | Eq (Lit (LList []), NOp (LstCat, les)) -> - let eqs = List.map (fun le -> Formula.Eq (le, EList [])) les in - List.iter (fun eq -> extend_with eq) eqs; + | BinOp (NOp (LstCat, les), Equal, EList []) + | BinOp (NOp (LstCat, les), Equal, Lit (LList [])) + | BinOp (EList [], Equal, NOp (LstCat, les)) + | BinOp (Lit (LList []), Equal, NOp (LstCat, les)) -> + let eqs = + List.map (fun le -> Expr.BinOp (le, Equal, EList [])) les + in + List.iter extend_with eqs; `Filter (* Two list concats, Satan save us *) - | Eq (NOp (LstCat, lcat), NOp (LstCat, rcat)) -> ( + | BinOp (NOp (LstCat, lcat), Equal, NOp (LstCat, rcat)) -> ( match Reduction.understand_lstcat lpfs gamma lcat rcat with | None -> `Replace whole | Some (pf, new_vars) -> @@ -472,21 +472,23 @@ let simplify_pfs_and_gamma vars_to_kill := SS.union !vars_to_kill new_vars; `Replace whole) (* *) - | Eq (UnOp (LstLen, x), BinOp (Lit (Int n), IPlus, LVar z)) + | BinOp (UnOp (LstLen, x), Equal, BinOp (Lit (Int n), IPlus, LVar z)) when Z.geq n Z.zero -> let new_lvars = List.init (Z.to_int n) (fun _ -> Expr.LVar (LVar.alloc ())) in let rest = LVar.alloc () in let lst_eq = - Formula.Eq (x, NOp (LstCat, [ EList new_lvars; LVar rest ])) + Expr.BinOp (x, Equal, NOp (LstCat, [ EList new_lvars; LVar rest ])) + in + let len_rest = + Expr.BinOp (UnOp (LstLen, LVar rest), Equal, LVar z) in - let len_rest = Formula.Eq (UnOp (LstLen, LVar rest), LVar z) in extend_with len_rest; `Replace lst_eq (* Sublist *) - | Eq (LstSub (lst, start, num), sl) | Eq (sl, LstSub (lst, start, num)) - -> + | BinOp (LstSub (lst, start, num), Equal, sl) + | BinOp (sl, Equal, LstSub (lst, start, num)) -> let prefix_lvar = LVar.alloc () in let suffix_lvar = LVar.alloc () in vars_to_kill := @@ -502,17 +504,21 @@ let simplify_pfs_and_gamma fmt "Reduced suffix length: %a" Expr.pp suffix_len); let lst_eq = if suffix_len = Expr.zero_i then - Formula.Eq (lst, NOp (LstCat, [ LVar prefix_lvar; sl ])) + Expr.BinOp (lst, Equal, NOp (LstCat, [ LVar prefix_lvar; sl ])) else - Formula.Eq - (lst, NOp (LstCat, [ LVar prefix_lvar; sl; LVar suffix_lvar ])) + Expr.BinOp + ( lst, + Equal, + NOp (LstCat, [ LVar prefix_lvar; sl; LVar suffix_lvar ]) ) + in + let len_pr = + Expr.BinOp (UnOp (LstLen, LVar prefix_lvar), Equal, start) in - let len_pr = Formula.Eq (UnOp (LstLen, LVar prefix_lvar), start) in - let len_sl = Formula.Eq (UnOp (LstLen, sl), num) in + let len_sl = Expr.BinOp (UnOp (LstLen, sl), Equal, num) in extend_with len_pr; extend_with len_sl; `Replace lst_eq - | Eq (le1, le2) -> ( + | BinOp (le1, Equal, le2) -> ( let te1, _ = Typing.type_lexpr gamma le1 in let te2, _ = Typing.type_lexpr gamma le2 in match (te1, te2) with @@ -555,7 +561,7 @@ let simplify_pfs_and_gamma in PFS.substitution temp_subst lpfs; let substituted = - SESubst.substitute_formula ~partial:true temp_subst whole + SESubst.subst_in_expr ~partial:true temp_subst whole in rec_call substituted | ALoc alocl, ALoc alocr when not matching -> @@ -612,7 +618,7 @@ let simplify_pfs_and_gamma ((Fmt.to_to_string Expr.pp) le) ((Fmt.to_to_string Expr.pp) le'))); *) if le <> le' then - PFS.extend lpfs (Eq (le, le'))); + PFS.extend lpfs (BinOp (le, Equal, le'))); SESubst.iter result (fun x le -> let sle = SESubst.subst_in_expr temp_subst @@ -704,21 +710,22 @@ let simplify_pfs_and_gamma (fun (lens, cats, xcats) pf -> match pf with (* List length direct equality *) - | Eq (UnOp (LstLen, LVar x), UnOp (LstLen, LVar y)) + | BinOp (UnOp (LstLen, LVar x), Equal, UnOp (LstLen, LVar y)) when not (String.equal x y) -> let lens = map_add (UnOp (LstLen, LVar y)) (LVar x) lens in (map_add (UnOp (LstLen, LVar x)) (LVar y) lens, cats, xcats) (* List length equals some other expression on the right *) - | Eq (UnOp (LstLen, LVar x), rhs) + | BinOp (UnOp (LstLen, LVar x), Equal, rhs) when not (List.mem (Expr.LVar x) (Expr.base_elements rhs)) -> (map_add rhs (LVar x) lens, cats, xcats) (* List length equals some other expression on the left *) - | Eq (lhs, UnOp (LstLen, LVar x)) + | BinOp (lhs, Equal, UnOp (LstLen, LVar x)) when not (List.mem (Expr.LVar x) (Expr.base_elements lhs)) -> (map_add lhs (LVar x) lens, cats, xcats) (*************** CATS **************) (* Two cats *) - | Eq (NOp (LstCat, LVar a :: b), NOp (LstCat, LVar c :: d)) + | BinOp + (NOp (LstCat, LVar a :: b), Equal, NOp (LstCat, LVar c :: d)) when a <> c -> let cats = map_map_add @@ -744,12 +751,12 @@ let simplify_pfs_and_gamma (NOp (LstCat, LVar a :: b)) xcats ) (* One cat on the left *) - | Eq (NOp (LstCat, LVar a :: b), rhs) -> + | BinOp (NOp (LstCat, LVar a :: b), Equal, rhs) -> ( lens, map_map_add rhs (Expr.LVar a) (NOp (LstCat, b)) cats, map_add (NOp (LstCat, LVar a :: b)) rhs xcats ) (* One cat on the right *) - | Eq (lhs, NOp (LstCat, LVar a :: b)) -> + | BinOp (lhs, Equal, NOp (LstCat, LVar a :: b)) -> ( lens, map_map_add lhs (Expr.LVar a) (NOp (LstCat, b)) cats, map_add (NOp (LstCat, LVar a :: b)) lhs xcats ) @@ -772,7 +779,7 @@ let simplify_pfs_and_gamma L.verbose (fun fmt -> fmt "ULTRA LSTCAT: cat equality: %a and %a" Expr.pp x Expr.pp y); - PFS.extend pfs (Eq (x, y)) + PFS.extend pfs (BinOp (x, Equal, y)) done done) eqs) @@ -787,7 +794,7 @@ let simplify_pfs_and_gamma L.verbose (fun fmt -> fmt "ULTRA LSTCAT: xcat equality: %a and %a" Expr.pp x Expr.pp y); - PFS.extend pfs (Eq (x, y)) + PFS.extend pfs (BinOp (x, Equal, y)) done done) xcats; @@ -820,13 +827,13 @@ let simplify_pfs_and_gamma L.verbose (fun fmt -> fmt "ULTRA LSTCAT: head equality: %a and %a" Expr.pp x Expr.pp y); - PFS.extend pfs (Eq (x, y)); + PFS.extend pfs (Expr.BinOp (x, Equal, y)); let x = Expr.Map.find x eqcats in let y = Expr.Map.find y eqcats in L.verbose (fun fmt -> fmt "ULTRA LSTCAT: tail equality: %a and %a" Expr.pp x Expr.pp y); - PFS.extend pfs (Eq (x, y)) + PFS.extend pfs (Expr.BinOp (x, Equal, y)) done done) cats) @@ -859,7 +866,7 @@ let simplify_pfs_and_gamma if PFS.length lpfs = 0 - || (PFS.length lpfs > 0 && not (PFS.get_nth 0 lpfs = Some False)) + || (PFS.length lpfs > 0 && not (PFS.get_nth 0 lpfs = Some Expr.false_)) then ( (* Step 3 - Bring back my variables *) SESubst.iter result (fun v le -> @@ -871,7 +878,7 @@ let simplify_pfs_and_gamma || (kill_new_lvars && SS.mem v vars_to_save) || ((not kill_new_lvars) && vars_to_save <> SS.empty)) && not (Names.is_aloc_name v) - then PFS.extend lpfs (Eq (LVar v, le)) + then PFS.extend lpfs (BinOp (LVar v, Equal, le)) | _ -> ()); sanitise_pfs_no_store ~matching gamma lpfs; @@ -885,7 +892,10 @@ let simplify_pfs_and_gamma match t with | Type.ListType -> PFS.extend lpfs - (ILessEq (Expr.zero_i, UnOp (LstLen, Expr.from_var_name v))) + (BinOp + ( Expr.zero_i, + ILessThanEqual, + UnOp (LstLen, Expr.from_var_name v) )) | _ -> ()); analyse_list_structure lpfs; @@ -894,8 +904,8 @@ let simplify_pfs_and_gamma done; L.verbose (fun m -> m "PFS/Gamma simplification completed:\n"); - L.(verbose (fun m -> m "PFS:@\n%a@\n" PFS.pp lpfs)); - L.(verbose (fun m -> m "Gamma:@\n%a@\n" Type_env.pp gamma)); + L.verbose (fun m -> m "PFS:@\n%a@\n" PFS.pp lpfs); + L.verbose (fun m -> m "Gamma:@\n%a@\n" Type_env.pp gamma); let cached_simplification = { @@ -946,13 +956,14 @@ let simplify_implication (gamma : Type_env.t) = (* let t = Sys.time () in *) List.iter - (fun (pf : Formula.t) -> + (fun (pf : Expr.t) -> match pf with - | Eq (NOp (LstCat, lex), NOp (LstCat, ley)) -> + | BinOp (NOp (LstCat, lex), Equal, NOp (LstCat, ley)) -> let flen_eq = - Reduction.reduce_formula ~gamma ~pfs:lpfs - (Eq + Reduction.reduce_lexpr ~gamma ~pfs:lpfs + (BinOp ( UnOp (LstLen, NOp (LstCat, lex)), + Equal, UnOp (LstLen, NOp (LstCat, ley)) )) in PFS.extend lpfs flen_eq @@ -964,7 +975,7 @@ let simplify_implication PFS.substitution subst rpfs; (* Additional *) - PFS.map_inplace (Reduction.reduce_formula ~rpfs:true ~gamma ~pfs:lpfs) rpfs; + PFS.map_inplace (Reduction.reduce_lexpr ~gamma ~pfs:lpfs) rpfs; L.verbose (fun fmt -> fmt "REDUCED RPFS:\n%a" PFS.pp rpfs); sanitise_pfs_no_store ~matching gamma rpfs; @@ -997,11 +1008,7 @@ let admissible_assertion (a : Asrt.t) : bool = let a = Asrt.pvars_to_lvars a in - let rec separate (a : Asrt.t) = - match a with - | Star (a1, a2) -> - separate a1; - separate a2 + let separate : Asrt.atom -> unit = function | Pure f -> PFS.extend pfs f | Types ets -> List.iter @@ -1013,11 +1020,10 @@ let admissible_assertion (a : Asrt.t) : bool = | _ -> () in try - separate a; + List.iter separate a; let _ = simplify_pfs_and_gamma ~kill_new_lvars:true pfs gamma in - let res = not (PFS.mem pfs Formula.False) in - if res then L.tmi (fun m -> m "Admissible !!") - else L.tmi (fun m -> m "Not admissible !!"); + let res = not (PFS.mem pfs Expr.false_) in + L.tmi (fun m -> m "Admissible? %b" res); res with e -> L.tmi (fun m -> diff --git a/GillianCore/engine/FOLogic/type_env.ml b/GillianCore/engine/FOLogic/type_env.ml index 80a69b16..2cb62659 100644 --- a/GillianCore/engine/FOLogic/type_env.ml +++ b/GillianCore/engine/FOLogic/type_env.ml @@ -30,9 +30,9 @@ let empty (x : t) : bool = Hashtbl.length x == 0 (* Type of a variable *) let get_unsafe (x : t) (var : string) : Type.t = - match Hashtbl.mem x var with - | true -> Hashtbl.find x var - | false -> + match Hashtbl.find_opt x var with + | Some t -> t + | None -> raise (Failure ("Type_env.get_unsafe: variable " ^ var ^ " not found.")) (* Get all matchable elements *) diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index 9548b955..edb1327e 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -19,8 +19,8 @@ module Infer_types_to_gamma = struct (tt : Type.t) = let f = f flag gamma new_gamma in match op with - | UNot -> tt = BooleanType && f le BooleanType - | M_isNaN -> tt = BooleanType && f le NumberType + | Not -> tt = BooleanType && f le BooleanType + | IsInt | M_isNaN -> tt = BooleanType && f le NumberType | IUnaryMinus -> tt = IntType && f le IntType | FUnaryMinus | BitwiseNot @@ -70,13 +70,12 @@ module Infer_types_to_gamma = struct (Some IntType, Some IntType, Some BooleanType) | FLessThan | FLessThanEqual -> (Some NumberType, Some NumberType, Some BooleanType) - | SLessThan -> (Some StringType, Some StringType, Some BooleanType) - | BAnd | BOr | BImpl -> - (Some BooleanType, Some BooleanType, Some BooleanType) + | StrLess -> (Some StringType, Some StringType, Some BooleanType) + | And | Or | Impl -> (Some BooleanType, Some BooleanType, Some BooleanType) | StrCat -> (Some StringType, Some StringType, Some StringType) - | BSetMem -> (None, Some SetType, Some BooleanType) + | SetMem -> (None, Some SetType, Some BooleanType) | SetDiff -> (Some SetType, Some SetType, Some SetType) - | BSetSub -> (Some SetType, Some SetType, Some BooleanType) + | SetSub -> (Some SetType, Some SetType, Some BooleanType) | LstNth -> (Some ListType, Some IntType, None) | LstRepeat -> (None, Some IntType, Some ListType) | StrNth -> (Some ListType, Some NumberType, None) @@ -154,30 +153,7 @@ module Infer_types_to_gamma = struct tt = ListType && f le1 ListType && f le2 IntType && f le3 IntType | UnOp (op, le) -> infer_unop flag gamma new_gamma op le tt | BinOp (le1, op, le2) -> infer_binop flag gamma new_gamma op le1 le2 tt - | Exists (bt, le) -> - if not (tt = BooleanType) then false - else - let gamma_copy = Type_env.copy gamma in - let new_gamma_copy = Type_env.copy new_gamma in - let () = - List.iter - (fun (x, t) -> - let () = - match t with - | Some t -> Type_env.update gamma_copy x t - | None -> Type_env.remove gamma_copy x - in - Type_env.remove new_gamma_copy x) - bt - in - let ret = f' gamma_copy new_gamma_copy le BooleanType in - (* We've updated our new_gamma_copy with a bunch of things. - We need to import everything except the quantified variables to the new_gamma *) - Type_env.iter new_gamma_copy (fun x t -> - if not (List.exists (fun (y, _) -> String.equal x y) bt) then - Type_env.update new_gamma x t); - ret - | EForall (bt, le) -> + | Exists (bt, le) | ForAll (bt, le) -> if not (tt = BooleanType) then false else let gamma_copy = Type_env.copy gamma in @@ -238,17 +214,21 @@ let rec infer_types_expr gamma le : unit = (* Set union and intersection - all members must be sets, plus any additional information from the members themselves *) | NOp (SetUnion, lle) | NOp (SetInter, lle) -> e le SetType; - List.iter (fun le -> f le) lle + List.iter f lle | NOp (LstCat, lle) -> e le ListType; - List.iter (fun le -> f le) lle - | EList lle | ESet lle -> List.iter (fun le -> f le) lle + List.iter f lle + | EList lle | ESet lle -> List.iter f lle | BinOp (le1, op, le2) -> ( match op with - | FPlus | FMinus | FTimes | FDiv | FMod -> + | Equal -> () + | And | Or | Impl -> + e le1 BooleanType; + e le2 BooleanType + | FPlus | FMinus | FTimes | FDiv | FMod | FLessThan | FLessThanEqual -> e le1 NumberType; e le2 NumberType - | IPlus | IMinus | ITimes | IDiv | IMod -> + | IPlus | IMinus | ITimes | IDiv | IMod | ILessThan | ILessThanEqual -> e le1 IntType; e le2 IntType | LstNth -> @@ -260,36 +240,23 @@ let rec infer_types_expr gamma le : unit = | StrNth -> e le1 StringType; e le2 NumberType + | StrLess -> + e le1 StringType; + e le2 StringType + | SetMem -> e le2 SetType + | SetSub | SetDiff -> + e le1 SetType; + e le2 SetType (* FIXME: Specify cases *) | _ -> ()) (* FIXME: Specify cases *) - | _ -> () - -let rec infer_types_formula (gamma : Type_env.t) (a : Formula.t) : unit = - let f = infer_types_formula gamma in - let e = safe_extend_gamma gamma in - - match a with - (* LForAll can be more precise *) - | True | False | ForAll _ -> () - | Not a -> f a - | And (a1, a2) | Or (a1, a2) -> - f a1; - f a2 - | FLess (e1, e2) | FLessEq (e1, e2) -> - e e1 NumberType; - e e2 NumberType - | ILess (e1, e2) | ILessEq (e1, e2) -> - e e1 IntType; - e e2 IntType - | StrLess (e1, e2) -> - e e1 StringType; - e e2 StringType - | SetMem (_, e2) -> e e2 SetType - | SetSub (e1, e2) -> - e e1 SetType; - e e2 SetType - (* FIXME: Specify cases *) + | UnOp (op, le) -> ( + match op with + | Not -> e le BooleanType + | IsInt | M_isNaN -> e le NumberType + | IUnaryMinus -> e le IntType + (* FIXME: Specify cases *) + | _ -> ()) | _ -> () (*****************) @@ -357,7 +324,7 @@ module Type_lexpr = struct let (tt : Type.t) = match op with | TypeOf -> TypeType - | UNot | M_isNaN -> BooleanType + | Not | M_isNaN | IsInt -> BooleanType | ToStringOp -> StringType | Car | Cdr -> ListType | LstRev | SetToList -> ListType @@ -406,12 +373,12 @@ module Type_lexpr = struct | ILessThanEqual | FLessThan | FLessThanEqual - | SLessThan - | BAnd - | BOr - | BImpl - | BSetMem - | BSetSub -> infer_type le BooleanType + | StrLess + | And + | Or + | Impl + | SetMem + | SetSub -> infer_type le BooleanType | SetDiff -> infer_type le SetType | StrCat -> infer_type le StringType | IPlus @@ -497,7 +464,7 @@ module Type_lexpr = struct | EList _ -> def_pos (Some ListType) (* Sets are always typable *) | ESet _ -> def_pos (Some SetType) - | Exists (bt, e) | EForall (bt, e) -> type_quantified_expr gamma le bt e + | Exists (bt, e) | ForAll (bt, e) -> type_quantified_expr gamma le bt e | UnOp (op, e) -> type_unop gamma le op e | BinOp (e1, op, e2) -> type_binop gamma le op e1 e2 | NOp (SetUnion, les) | NOp (SetInter, les) -> @@ -540,15 +507,16 @@ let te_of_list (vt : (Expr.t * Type.t) list) : Type_env.t option = let naively_infer_type_information (pfs : PFS.t) (gamma : Type_env.t) : unit = PFS.iter (fun a -> - match (a : Formula.t) with - | Eq (LVar x, le) | Eq (le, LVar x) -> + match (a : Expr.t) with + | Expr.BinOp (LVar x, Equal, le) | Expr.BinOp (le, Equal, LVar x) -> if not (Type_env.mem gamma x) then let le_type, _ = type_lexpr gamma le in Option.fold ~some:(fun x_type -> Type_env.update gamma x x_type) ~none:() le_type - | Eq (UnOp (TypeOf, LVar x), Lit (Type t)) - | Eq (Lit (Type t), UnOp (TypeOf, LVar x)) -> Type_env.update gamma x t + | Expr.BinOp (UnOp (TypeOf, LVar x), Equal, Lit (Type t)) + | Expr.BinOp (Lit (Type t), Equal, UnOp (TypeOf, LVar x)) -> + Type_env.update gamma x t | _ -> ()) pfs diff --git a/GillianCore/engine/FOLogic/typing.mli b/GillianCore/engine/FOLogic/typing.mli index 97456174..962ecc0d 100644 --- a/GillianCore/engine/FOLogic/typing.mli +++ b/GillianCore/engine/FOLogic/typing.mli @@ -9,7 +9,6 @@ val type_lexpr : Type_env.t -> Expr.t -> Type.t option * bool val infer_types_expr : Type_env.t -> Expr.t -> unit -val infer_types_formula : Type_env.t -> Formula.t -> unit val reverse_type_lexpr : bool -> Type_env.t -> (Expr.t * Type.t) list -> Type_env.t option diff --git a/GillianCore/engine/concrete_semantics/CExprEval.ml b/GillianCore/engine/concrete_semantics/CExprEval.ml index 8ce5e890..95b0ce28 100644 --- a/GillianCore/engine/concrete_semantics/CExprEval.ml +++ b/GillianCore/engine/concrete_semantics/CExprEval.ml @@ -6,259 +6,169 @@ module CStore = Store.Make (CVal.M) exception TypeError of string exception EvaluationError of string -let unary_int_thing (lit : CVal.M.t) (f : Z.t -> Z.t) emsg : CVal.M.t = - let num = - match lit with - | Int n -> n - | _ -> raise (TypeError (Fmt.str "%s %a" emsg CVal.M.pp lit)) - in +let evalerr msg = raise (EvaluationError (Fmt.str "Evaluation Error: %s" msg)) + +let typeerr ?msg typ lit = + raise + (TypeError + (match msg with + | Some msg -> Fmt.str "Expected %s, got %a (%s)" typ Literal.pp lit msg + | None -> Fmt.str "Expected %s, got %a" typ Literal.pp lit)) + +let as_str ?msg = function + | Literal.String s -> s + | lit -> typeerr ?msg "string" lit + +let as_bool ?msg = function + | Literal.Bool b -> b + | lit -> typeerr ?msg "boolean" lit + +let as_int ?msg = function + | Literal.Int i -> i + | lit -> typeerr ?msg "integer" lit + +let as_num ?msg = function + | Literal.Num n -> n + | lit -> typeerr ?msg "number" lit + +let as_list ?msg = function + | Literal.LList l -> l + | lit -> typeerr ?msg "list" lit + +let unary_int_thing ?msg (lit : CVal.M.t) (f : Z.t -> Z.t) : CVal.M.t = + let num = as_int ?msg lit in let res = f num in Int res -let unary_num_thing (lit : CVal.M.t) (f : float -> float) emsg : CVal.M.t = - let num = - match lit with - | Num n -> n - | _ -> raise (TypeError (Fmt.str "%s %a" emsg CVal.M.pp lit)) - in +let unary_num_thing ?msg (lit : CVal.M.t) (f : float -> float) : CVal.M.t = + let num = as_num ?msg lit in let res = f num in Num res -let evaluate_unop (op : UnOp.t) (lit : CVal.M.t) : CVal.M.t = - match op with - | UNot -> ( - match (lit : CVal.M.t) with - | Bool b -> Bool (not b) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: Negation: expected boolean, got %a" - CVal.M.pp lit))) - | IUnaryMinus -> - unary_int_thing lit - (fun x -> Z.neg x) - "Type Error: Integer unary minus: expected integer, got " - | FUnaryMinus -> - unary_num_thing lit - (fun x -> -.x) - "Type Error: Float unary minus: expected float, got " - | BitwiseNot -> - unary_num_thing lit int32_bitwise_not - "Type Error: Bitwise not: expected number, got" - | M_abs -> - unary_num_thing lit abs_float - "Type Error: Absolute value: expected number, got" - | M_acos -> - unary_num_thing lit acos "Type Error: Arc cosine: expected number, got" - | M_asin -> - unary_num_thing lit asin "Type Error: Arc sine: expected number, got" - | M_atan -> - unary_num_thing lit atan "Type Error: Arc tangent: expected number, got" - | M_ceil -> - unary_num_thing lit ceil "Type Error: Ceiling: expected number, got" - | M_cos -> unary_num_thing lit cos "Type Error: Cosine: expected number, got" - | M_exp -> - unary_num_thing lit exp "Type Error: Exponentiation: expected number, got" - | M_floor -> - unary_num_thing lit floor "Type Error: Floor: expected number, got" - | M_log -> - unary_num_thing lit log "Type Error: Unary minus: expected number, got" - | M_round -> ( - match lit with - | Num n -> ( - let sign = copysign 1.0 n in - match sign < 0.0 && n >= -0.5 with - | true -> Num (-0.0) - | _ -> - (* This complex rounding is needed for edge case in OCaml: 0.49999999999999994 *) - let round_nearest_lb = -.(2. ** 52.) in - let round_nearest_ub = 2. ** 52. in - - let round_nearest t = - if t >= round_nearest_lb && t <= round_nearest_ub then - floor (t +. 0.49999999999999994) - else t - in - Num (round_nearest n)) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: Round: expected number, got %a" CVal.M.pp - lit))) - | M_sgn -> - unary_num_thing lit - (fun x -> copysign 1.0 x) - "Type Error: Sign: expected number, got" - | M_sin -> unary_num_thing lit sin "Type Error: Sine: expected number, got" - | M_sqrt -> - unary_num_thing lit sqrt "Type Error: Square root: expected number, got" - | M_tan -> unary_num_thing lit tan "Type Error: Tangent: expected number, got" - | ToStringOp -> ( - match lit with - | Num n -> String (float_to_string_inner n) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: Number to string: expected number, got %a" - CVal.M.pp lit))) - | ToIntOp -> - unary_num_thing lit to_int - "Type Error: Number to integer: expected number, got" - | ToUint16Op -> - unary_num_thing lit to_uint16 - "Type Error: Number to unsigned 16-bit integer: expected number, got" - | ToInt32Op -> - unary_num_thing lit to_int32 - "Type Error: Number to 32-bit integer: expected number, got" - | ToUint32Op -> - unary_num_thing lit to_uint32 - "Type Error: Number to unsigned 32-bit integer: expected number, got" - | ToNumberOp -> ( - match lit with - | String s -> - if s = "" then Num 0. - else - let num = try Float.of_string s with Failure _ -> nan in - Num num - | _ -> - raise - (TypeError - (Fmt.str "Type Error: ToNumber: expected string, got %a" - CVal.M.pp lit))) - | IntToNum -> ( - match lit with - | Int x -> Num (Z.to_float x) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: IntToNum: expected integer, got %a" - CVal.M.pp lit))) - | NumToInt -> ( - match lit with - | Num x -> Int (Z.of_float x) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: NumToInt: expected number, got %a" - CVal.M.pp lit))) - | TypeOf -> Type (Literal.type_of lit) - | Car -> ( - match lit with - | LList ll -> ( - match ll with - | [] -> - raise - (EvaluationError "Evaluation Error: List head of empty list") - | lit :: _ -> lit) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: List head: expected list, got %a" CVal.M.pp - lit))) - | Cdr -> ( - match lit with - | LList ll -> ( - match ll with - | [] -> - raise - (EvaluationError "Evaluation Error: List tail of empty list") - | _ :: ll -> LList ll) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: List tail: expected list, got %a" CVal.M.pp - lit))) - | LstLen -> ( - match lit with - | LList l -> Int (Z.of_int (List.length l)) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: List length: expected list, got: %a" - CVal.M.pp lit))) - | LstRev -> ( - match lit with - | LList l -> LList (List.rev l) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: List reverse: expected list, got: %a" - CVal.M.pp lit))) - | StrLen -> ( - match lit with - | String s -> Num (float_of_int (String.length s)) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: String length: expected string, got: %a" - CVal.M.pp lit))) - | M_isNaN -> ( - match lit with - | Num x when x == nan -> Bool true - | Num _ -> Bool false - | _ -> - raise - (TypeError - (Fmt.str "Type Error: M_isNan: expected number, got: %a" - CVal.M.pp lit))) - | SetToList -> - raise (Exceptions.Unsupported "eval_unop concrete: set-to-list") - let binary_num_thing + ?msg (lit1 : CVal.M.t) (lit2 : CVal.M.t) - (f : float -> float -> float) - emsg : CVal.M.t = - let num1, num2 = - match (lit1, lit2) with - | Num n1, Num n2 -> (n1, n2) - | _ -> - raise - (TypeError (Fmt.str "%s %a and %a" emsg CVal.M.pp lit1 CVal.M.pp lit2)) - in - Num (f num1 num2) + (f : float -> float -> float) = + let num1 = as_num ?msg lit1 in + let num2 = as_num ?msg lit2 in + Literal.Num (f num1 num2) let binary_int_thing + ?msg (lit1 : CVal.M.t) (lit2 : CVal.M.t) - (f : Z.t -> Z.t -> Z.t) - emsg : CVal.M.t = - let num1, num2 = - match (lit1, lit2) with - | Int n1, Int n2 -> (n1, n2) - | _ -> - raise - (TypeError (Fmt.str "%s %a and %a" emsg CVal.M.pp lit1 CVal.M.pp lit2)) - in - Int (f num1 num2) + (f : Z.t -> Z.t -> Z.t) = + let num1 = as_int ?msg lit1 in + let num2 = as_int ?msg lit2 in + Literal.Int (f num1 num2) let binary_int_bool_thing + ?msg (lit1 : CVal.M.t) (lit2 : CVal.M.t) - (f : Z.t -> Z.t -> bool) - emsg : CVal.M.t = - let num1, num2 = - match (lit1, lit2) with - | Int n1, Int n2 -> (n1, n2) - | _ -> - raise - (TypeError (Fmt.str "%s %a and %a" emsg CVal.M.pp lit1 CVal.M.pp lit2)) - in - Bool (f num1 num2) + (f : Z.t -> Z.t -> bool) = + let num1 = as_int ?msg lit1 in + let num2 = as_int ?msg lit2 in + Literal.Bool (f num1 num2) let binary_num_bool_thing + ?msg (lit1 : CVal.M.t) (lit2 : CVal.M.t) - (f : float -> float -> bool) - emsg : CVal.M.t = - let num1, num2 = - match (lit1, lit2) with - | Num n1, Num n2 -> (n1, n2) - | _ -> - raise - (TypeError (Fmt.str "%s %a and %a" emsg CVal.M.pp lit1 CVal.M.pp lit2)) - in - Bool (f num1 num2) + (f : float -> float -> bool) = + let num1 = as_num ?msg lit1 in + let num2 = as_num ?msg lit2 in + Literal.Bool (f num1 num2) + +let evaluate_unop (op : UnOp.t) (lit : CVal.M.t) : CVal.M.t = + let unary_int_thing = unary_int_thing ~msg:(UnOp.str op) in + let unary_num_thing = unary_num_thing ~msg:(UnOp.str op) in + match op with + | Not -> + let b = as_bool lit in + Bool (not b) + | IUnaryMinus -> unary_int_thing lit Z.neg + | FUnaryMinus -> unary_num_thing lit (fun x -> -.x) + | BitwiseNot -> unary_num_thing lit int32_bitwise_not + | M_abs -> unary_num_thing lit abs_float + | M_acos -> unary_num_thing lit acos + | M_asin -> unary_num_thing lit asin + | M_atan -> unary_num_thing lit atan + | M_ceil -> unary_num_thing lit ceil + | M_cos -> unary_num_thing lit cos + | M_exp -> unary_num_thing lit exp + | M_floor -> unary_num_thing lit floor + | M_log -> unary_num_thing lit log + | M_round -> + let f n = + let sign = copysign 1.0 n in + match sign < 0.0 && n >= -0.5 with + | true -> -0.0 + | _ -> + (* This complex rounding is needed for edge case in OCaml: 0.49999999999999994 *) + let round_nearest_lb = -.(2. ** 52.) in + let round_nearest_ub = 2. ** 52. in + + let round_nearest t = + if t >= round_nearest_lb && t <= round_nearest_ub then + floor (t +. 0.49999999999999994) + else t + in + round_nearest n + in + unary_num_thing lit f + | M_sgn -> unary_num_thing lit (fun x -> copysign 1.0 x) + | M_sin -> unary_num_thing lit sin + | M_sqrt -> unary_num_thing lit sqrt + | M_tan -> unary_num_thing lit tan + | ToStringOp -> + let n = as_num lit in + String (float_to_string_inner n) + | ToIntOp -> unary_num_thing lit to_int + | ToUint16Op -> unary_num_thing lit to_uint16 + | ToInt32Op -> unary_num_thing lit to_int32 + | ToUint32Op -> unary_num_thing lit to_uint32 + | ToNumberOp -> + let s = as_str lit in + if s = "" then Num 0. + else + let num = try Float.of_string s with Failure _ -> nan in + Num num + | IntToNum -> + let x = as_int lit in + Num (Z.to_float x) + | NumToInt -> + let x = as_num lit in + Int (Z.of_float x) + | TypeOf -> Type (Literal.type_of lit) + | Car -> ( + let ll = as_list lit in + match ll with + | [] -> evalerr "List head of empty list" + | lit :: _ -> lit) + | Cdr -> ( + let ll = as_list lit in + match ll with + | [] -> evalerr "List tail of empty list" + | _ :: ll -> LList ll) + | LstLen -> + let ll = as_list lit in + Int (Z.of_int (List.length ll)) + | LstRev -> + let ll = as_list lit in + LList (List.rev ll) + | StrLen -> + let s = as_str lit in + Num (float_of_int (String.length s)) + | M_isNaN -> + let x = as_num lit in + Bool (x <> x) + | SetToList -> + raise (Exceptions.Unsupported "eval_unop concrete: set-to-list") + | IsInt -> + let x = as_num lit in + Bool (is_int x) let rec evaluate_binop (store : CStore.t) @@ -267,47 +177,30 @@ let rec evaluate_binop (e2 : Expr.t) : CVal.M.t = let ee = evaluate_expr store in let lit1 = ee e1 in + let binary_int_bool_thing = binary_int_bool_thing ~msg:(BinOp.str op) in + let binary_num_bool_thing = binary_num_bool_thing ~msg:(BinOp.str op) in + let binary_int_thing = binary_int_thing ~msg:(BinOp.str op) in + let binary_num_thing = binary_num_thing ~msg:(BinOp.str op) in match op with - | BImpl -> ee (BinOp (UnOp (UNot, Expr.Lit lit1), BOr, e2)) - | BAnd -> ( - match lit1 with - | Bool false -> Bool false - | Bool true -> ( - match ee e2 with - | Bool b2 -> Bool b2 - | lit2 -> - raise - (TypeError - (Fmt.str "Type Error: Conjunction: expected boolean, got: %a" - CVal.M.pp lit2))) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: Conjunction: expected boolean, got: %a" - CVal.M.pp lit1))) - | BOr -> ( - match lit1 with - | Bool true -> Bool true - | Bool false -> ( - let lit2 = ee e2 in - match lit2 with - | Bool b2 -> Bool b2 - | _ -> - raise - (TypeError - (Fmt.str "Type Error: Disjunction: expected boolean, got: %a" - CVal.M.pp lit2))) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: Disjunction: expected boolean, got: %a" - CVal.M.pp lit1))) + | Impl -> ee (BinOp (UnOp (Not, Expr.Lit lit1), Or, e2)) + | And -> + let b1 = as_bool ~msg:"And" lit1 in + if not b1 then Bool false + else + let b2 = as_bool ~msg:"And" @@ ee e2 in + Bool b2 + | Or -> + let b1 = as_bool ~msg:"Or" lit1 in + if b1 then Bool true + else + let b2 = as_bool ~msg:"Or" @@ ee e2 in + Bool b2 | _ -> ( let lit2 = ee e2 in match op with - | SetDiff | BSetMem | BSetSub -> + | SetDiff | SetMem | SetSub -> raise (Exceptions.Unsupported "eval_binop concrete: set operator") - | BOr | BAnd | BImpl -> + | Or | And | Impl -> raise (Exceptions.Impossible "eval_binop concrete: by construction") | Equal -> ( match (lit1, lit2) with @@ -325,198 +218,85 @@ let rec evaluate_binop | Nono, Nono -> Bool true | _, _ -> Bool false) | LstNth -> ( - match (lit1, lit2) with - | LList list, Int n -> List.nth list (Z.to_int n) - | LList list, Num n when is_int n -> List.nth list (int_of_float n) - | LList list, Num -0. -> List.nth list 0 - | _, _ -> - raise - (TypeError - (Fmt.str - "Type Error: List indexing: expected list and number, \ - got %a and %a" - CVal.M.pp lit1 CVal.M.pp lit2))) - | LstRepeat -> ( + let list = as_list ~msg:"LstNth" lit1 in match lit2 with - | Int n -> - let n = Z.to_int n in - let elements = List.init n (fun _ -> lit1) in - LList elements - | _ -> - raise - (TypeError - (Fmt.str "Type Error: List repeat: expected integer, got %a" - CVal.M.pp lit2))) + | Int n -> List.nth list (Z.to_int n) + | Num n when is_int n -> List.nth list (int_of_float n) + | Num -0. -> List.nth list 0 + | _ -> typeerr ~msg:"LstNth" "integer or number" lit2) + | LstRepeat -> + let n = as_int ~msg:"LstRepeat" lit2 in + let n = Z.to_int n in + let elements = List.init n (fun _ -> lit1) in + LList elements | StrNth -> ( - match (lit1, lit2) with - | String s, Num n when is_int n -> - String (String.make 1 s.[int_of_float n]) - | String s, Num -0. -> String (String.make 1 s.[0]) - | _, _ -> - raise - (TypeError - (Fmt.str - "Type Error: List indexing: expected string and number, \ - got %a and %a" - CVal.M.pp lit1 CVal.M.pp lit2))) - | ILessThan -> - binary_int_bool_thing lit1 lit2 - (fun x y -> x < y) - "Type Error: Less than: expected integers, got " - | FLessThan -> - binary_num_bool_thing lit1 lit2 - (fun x y -> x < y) - "Type Error: Less than: expected numbers, got " - | SLessThan -> ( - match (lit1, lit2) with - | String s1, String s2 -> Bool (s1 < s2) - | _, _ -> raise (Failure "Non-string arguments to LessThanString")) - | ILessThanEqual -> - binary_int_bool_thing lit1 lit2 - (fun x y -> x <= y) - "Type Error: Less than or equal: expected integers, got " - | FLessThanEqual -> - binary_num_bool_thing lit1 lit2 - (fun x y -> x <= y) - "Type Error: Less than or equal: expected numbers, got " - | IPlus -> - binary_int_thing lit1 lit2 Z.add - "Type Error: Integer Addition: expected integers, got " - | IMinus -> - binary_int_thing lit1 lit2 Z.sub - "Type Error: Subtraction: expected integers, got " - | ITimes -> - binary_int_thing lit1 lit2 Z.mul - "Type Error: Multiplication: expected integers, got " - | IDiv -> - binary_int_thing lit1 lit2 Z.div - "Type Error: Division: expected integers, got " - | IMod -> - binary_int_thing lit1 lit2 Z.( mod ) - "Type Error: IModulus: expected ints, got " - | FPlus -> - binary_num_thing lit1 lit2 - (fun x y -> x +. y) - "Type Error: Addition: expected numbers, got " - | FMinus -> - binary_num_thing lit1 lit2 - (fun x y -> x -. y) - "Type Error: Subtraction: expected numbers, got " - | FTimes -> - binary_num_thing lit1 lit2 - (fun x y -> x *. y) - "Type Error: Multiplication: expected numbers, got " - | FDiv -> - binary_num_thing lit1 lit2 - (fun x y -> x /. y) - "Type Error: Division: expected numbers, got " - | FMod -> - binary_num_thing lit1 lit2 mod_float - "Type Error: FModulus: expected numbers, got " - | BitwiseAnd -> - binary_int_thing lit1 lit2 Z.logand - "Type Error: Bitwise conjunction: expected numbers, got " - | BitwiseOr -> - binary_int_thing lit1 lit2 Z.logor - "Type Error: Bitwise disjunction: expected numbers, got " - | BitwiseXor -> - binary_int_thing lit1 lit2 Z.logxor - "Type Error: Bitwise exclusive disjunction: expected numbers, got " + let s = as_str ~msg:"StrNth" lit1 in + match lit2 with + | Num n when is_int n -> String (String.make 1 s.[int_of_float n]) + | Num -0. -> String (String.make 1 s.[0]) + | _ -> typeerr ~msg:"StrNth" "number" lit2) + | ILessThan -> binary_int_bool_thing lit1 lit2 ( < ) + | FLessThan -> binary_num_bool_thing lit1 lit2 ( < ) + | StrLess -> + let s1 = as_str lit1 in + let s2 = as_str lit2 in + Bool (s1 < s2) + | ILessThanEqual -> binary_int_bool_thing lit1 lit2 ( <= ) + | FLessThanEqual -> binary_num_bool_thing lit1 lit2 ( <= ) + | IPlus -> binary_int_thing lit1 lit2 Z.add + | IMinus -> binary_int_thing lit1 lit2 Z.sub + | ITimes -> binary_int_thing lit1 lit2 Z.mul + | IDiv -> binary_int_thing lit1 lit2 Z.div + | IMod -> binary_int_thing lit1 lit2 Z.( mod ) + | FPlus -> binary_num_thing lit1 lit2 ( +. ) + | FMinus -> binary_num_thing lit1 lit2 ( -. ) + | FTimes -> binary_num_thing lit1 lit2 ( *. ) + | FDiv -> binary_num_thing lit1 lit2 ( /. ) + | FMod -> binary_num_thing lit1 lit2 mod_float + | BitwiseAnd -> binary_int_thing lit1 lit2 Z.logand + | BitwiseOr -> binary_int_thing lit1 lit2 Z.logor + | BitwiseXor -> binary_int_thing lit1 lit2 Z.logxor | LeftShift -> - binary_int_thing lit1 lit2 - (fun x y -> Z.shift_left x (Z.to_int y)) - "Type Error: Left shift: expected numbers, got " + binary_int_thing lit1 lit2 (fun x y -> Z.shift_left x (Z.to_int y)) | SignedRightShift -> - binary_int_thing lit1 lit2 - (fun x y -> Z.shift_right x (Z.to_int y)) - "Type Error: Signed right shift: expected numbers, got " + binary_int_thing lit1 lit2 (fun x y -> Z.shift_right x (Z.to_int y)) | UnsignedRightShift -> - binary_int_thing lit1 lit2 - (fun x y -> Z.shift_right x (Z.to_int y)) - "Type Error: Unsigned right shift: expected integers, got " - | BitwiseAndL -> - binary_int_thing lit1 lit2 int64_bitwise_and - "Type Error: Bitwise 64bit conjunction: expected integers, got " - | BitwiseOrL -> - binary_int_thing lit1 lit2 int64_bitwise_or - "Type Error: Bitwise 64bit disjunction: expected integers, got " - | BitwiseXorL -> - binary_int_thing lit1 lit2 int64_bitwise_xor - "Type Error: Bitwise 64bit exclusive disjunction: expected \ - numbers, got " - | LeftShiftL -> - binary_int_thing lit1 lit2 int64_left_shift - "Type Error: 64bit Left shift: expected integers, got " + binary_int_thing lit1 lit2 (fun x y -> Z.shift_right x (Z.to_int y)) + | BitwiseAndL -> binary_int_thing lit1 lit2 int64_bitwise_and + | BitwiseOrL -> binary_int_thing lit1 lit2 int64_bitwise_or + | BitwiseXorL -> binary_int_thing lit1 lit2 int64_bitwise_xor + | LeftShiftL -> binary_int_thing lit1 lit2 int64_left_shift | SignedRightShiftL -> - binary_int_thing lit1 lit2 - (fun x y -> Z.shift_right x (Z.to_int y)) - "Type Error: 64bit Signed right shift: expected numbers, got " + binary_int_thing lit1 lit2 (fun x y -> Z.shift_right x (Z.to_int y)) | UnsignedRightShiftL -> - binary_int_thing lit1 lit2 - (fun x y -> Z.shift_right x (Z.to_int y)) - "Type Error: 64bit Unsigned right shift: expected integers, got " - | BitwiseAndF -> - binary_num_thing lit1 lit2 int32_bitwise_and - "Type Error: Bitwise float conjunction: expected floats, got " - | BitwiseOrF -> - binary_num_thing lit1 lit2 int32_bitwise_or - "Type Error: Bitwise float disjunction: expected floats, got " - | BitwiseXorF -> - binary_num_thing lit1 lit2 int32_bitwise_xor - "Type Error: Bitwise float exclusive disjunction: expected floats, \ - got " - | LeftShiftF -> - binary_num_thing lit1 lit2 int32_left_shift - "Type Error: Float Left shift: expected floats, got " - | SignedRightShiftF -> - binary_num_thing lit1 lit2 int32_right_shift - "Type Error: Float Signed right shift: expected floats, got " - | UnsignedRightShiftF -> - binary_num_thing lit1 lit2 uint32_right_shift_f - "Type Error: Float Unsigned right shift: expected floats, got " - | M_atan2 -> - binary_num_thing lit1 lit2 atan2 - "Type Error: Arc tangent: expected numbers, got " - | M_pow -> - binary_num_thing lit1 lit2 - (fun x y -> x ** y) - "Type Error: Exponentiation: expected numbers, got " - | StrCat -> ( - match (lit1, lit2) with - | String s1, String s2 -> String (s1 ^ s2) - | _, _ -> - raise - (Failure - (Fmt.str - "Type Error: List concatenation: expected lists, got %a \ - and %a" - CVal.M.pp lit1 CVal.M.pp lit2)))) + binary_int_thing lit1 lit2 (fun x y -> Z.shift_right x (Z.to_int y)) + | BitwiseAndF -> binary_num_thing lit1 lit2 int32_bitwise_and + | BitwiseOrF -> binary_num_thing lit1 lit2 int32_bitwise_or + | BitwiseXorF -> binary_num_thing lit1 lit2 int32_bitwise_xor + | LeftShiftF -> binary_num_thing lit1 lit2 int32_left_shift + | SignedRightShiftF -> binary_num_thing lit1 lit2 int32_right_shift + | UnsignedRightShiftF -> binary_num_thing lit1 lit2 uint32_right_shift_f + | M_atan2 -> binary_num_thing lit1 lit2 atan2 + | M_pow -> binary_num_thing lit1 lit2 ( ** ) + | StrCat -> + let s1 = as_str lit1 in + let s2 = as_str lit2 in + String (s1 ^ s2)) and evaluate_nop (nop : NOp.t) (ll : Literal.t list) : CVal.M.t = match nop with - | LstCat -> - LList - (List.fold_left - (fun ac (l : Literal.t) -> - match l with - | LList l -> List.append ac l - | _ -> - raise (Failure "List concat: supplied expression not a list.")) - [] ll) - | _ -> raise (Exceptions.Unsupported "Concrete evaluate_nop: set operators") + | LstCat -> LList (List.concat_map (as_list ~msg:"LstCat") ll) + | SetInter | SetUnion -> + raise (Exceptions.Unsupported "Concrete evaluate_nop: set operators") and evaluate_elist store (ll : Expr.t list) : CVal.M.t = match ll with | [] -> LList [] - | e :: ll -> ( + | e :: ll -> let ve = evaluate_expr store e in let vll = evaluate_expr store (EList ll) in - match vll with - | LList vll -> LList (ve :: vll) - | _ -> - raise - (Exceptions.Impossible - "eval_expr concrete: list reduces to non-list")) + let vll = as_list vll in + LList (ve :: vll) and evaluate_lstsub (store : CStore.t) (e1 : Expr.t) (e2 : Expr.t) (e3 : Expr.t) : CVal.M.t = @@ -524,23 +304,20 @@ and evaluate_lstsub (store : CStore.t) (e1 : Expr.t) (e2 : Expr.t) (e3 : Expr.t) let ve1 = ee e1 in let ve2 = ee e2 in let ve3 = ee e3 in - match (ve1, ve2, ve3) with - | LList les, Int start, Int len -> - let sub_list = - List_utils.list_sub les (Z.to_int start) (Z.to_int len) |> Option.get - in - LList sub_list - | _ -> - raise (Exceptions.Impossible "eval_expr concrete: lstsub type mismatch") + let les = as_list ve1 in + let start = as_int ve2 in + let len = as_int ve3 in + let sub_list = + List_utils.list_sub les (Z.to_int start) (Z.to_int len) |> Option.get + in + LList sub_list and evaluate_expr (store : CStore.t) (e : Expr.t) : CVal.M.t = try let ee = evaluate_expr store in match e with - | Lit l -> ( - match l with - | Constant c -> Literal.evaluate_constant c - | x -> x) + | Lit (Constant c) -> Literal.evaluate_constant c + | Lit lit -> lit | PVar x -> ( match CStore.get store x with | None -> @@ -553,12 +330,14 @@ and evaluate_expr (store : CStore.t) (e : Expr.t) : CVal.M.t = | NOp (nop, le) -> evaluate_nop nop (List.map ee le) | EList ll -> evaluate_elist store ll | LstSub (e1, e2, e3) -> evaluate_lstsub store e1 e2 e3 - | ALoc _ | LVar _ | ESet _ | Exists _ | EForall _ -> + | ALoc _ | LVar _ | ESet _ | Exists _ | ForAll _ -> raise - (Exceptions.Impossible "eval_expr concrete: aloc, lvar, set or exists") + (Exceptions.Impossible + "eval_expr concrete: aloc, lvar, set, exists or for all") with - | TypeError msg -> raise (TypeError msg) - | EvaluationError msg -> raise (EvaluationError msg) + | TypeError msg -> raise (TypeError (msg ^ Fmt.str " in %a" Expr.pp e)) + | EvaluationError msg -> + raise (EvaluationError (msg ^ Fmt.str " in %a" Expr.pp e)) | Division_by_zero -> raise (EvaluationError "Division by zero") | e -> let msg = Printexc.to_string e in diff --git a/GillianCore/engine/concrete_semantics/CState.ml b/GillianCore/engine/concrete_semantics/CState.ml index 71bb9c00..b305d9d8 100644 --- a/GillianCore/engine/concrete_semantics/CState.ml +++ b/GillianCore/engine/concrete_semantics/CState.ml @@ -70,29 +70,15 @@ end = struct | Bool false -> [] | _ -> raise (Failure "assume. illegal argument to assume") - let assume_a - ?matching:_ - ?production:_ - ?time:_ - (state : t) - (ps : Formula.t list) : t option = - let les : Expr.t option list = List.map Formula.to_expr ps in - let bs : CVal.M.t option list = - List.map (Option.map (eval_expr state)) les - in - if - List.for_all - (function - | Some (Bool true) -> true - | _ -> false) - bs - then Some state - else None + let assume_a ?matching:_ ?production:_ ?time:_ (state : t) (ps : Expr.t list) + : t option = + let bs : CVal.M.t list = List.map (eval_expr state) ps in + if List.for_all (( = ) (Bool true)) bs then Some state else None let assume_t (state : t) (v : vt) (t : Type.t) : t option = if Literal.type_of v = t then Some state else None - let assert_a (state : t) (ps : Formula.t list) : bool = + let assert_a (state : t) (ps : Expr.t list) : bool = Option.fold ~some:(fun _ -> true) ~none:false (assume_a state ps) let sat_check (_ : t) (l : Literal.t) : bool = @@ -101,7 +87,7 @@ end = struct | _ -> raise (Failure "SAT Check: non-boolean argument") (* Implentation MISSING!!! *) - let sat_check_f (_ : t) (_ : Formula.t list) : st option = None + let sat_check_f (_ : t) (_ : Expr.t list) : st option = None let pp fmt state = let heap, store, _ = state in @@ -141,7 +127,7 @@ end = struct let get_lvars _ = raise (Failure "ERROR: get_lvars called for concrete executions") - let to_assertions ?to_keep:_ (_ : t) : Asrt.t list = + let to_assertions ?to_keep:_ (_ : t) : Asrt.t = raise (Failure "ERROR: to_assertions called for concrete executions") let run_spec @@ -152,7 +138,7 @@ end = struct (_ : (string * (string * vt) list) option) = raise (Failure "ERROR: run_spec called for non-abstract execution") - let unfolding_vals (_ : t) (_ : Formula.t list) : vt list = + let unfolding_vals (_ : t) (_ : Expr.t list) : vt list = raise (Failure "ERROR: unfolding_vals called for non-abstract execution") let evaluate_slcmd (_ : 'a MP.prog) (_ : SLCmd.t) (_ : t) : @@ -183,7 +169,7 @@ end = struct let update_subst (_ : t) (_ : st) : unit = () - let mem_constraints (_ : t) : Formula.t list = + let mem_constraints (_ : t) : Expr.t list = raise (Failure "DEATH. mem_constraints") let get_recovery_tactic _ = @@ -207,9 +193,9 @@ end = struct "Concrete printer: non-memory and non-type error") let can_fix (_ : err_t) : bool = false - let get_failing_constraint (_ : err_t) : Formula.t = True + let get_failing_constraint (_ : err_t) : Expr.t = Lit (Bool true) - let get_fixes (_ : err_t) : Asrt.t list list = + let get_fixes (_ : err_t) : Asrt.t list = raise (Failure "Concrete: get_fixes not implemented in CState.Make") let get_equal_values _ vs = vs diff --git a/GillianCore/engine/general_semantics/eSubst.ml b/GillianCore/engine/general_semantics/eSubst.ml index b2936fe5..73db6e83 100644 --- a/GillianCore/engine/general_semantics/eSubst.ml +++ b/GillianCore/engine/general_semantics/eSubst.ml @@ -84,8 +84,6 @@ module type S = sig (** Optional substitution inside a logical expression *) val subst_in_expr_opt : t -> Expr.t -> Expr.t option - val substitute_formula : t -> partial:bool -> Formula.t -> Formula.t - val substitute_in_formula_opt : t -> Formula.t -> Formula.t option val substitute_asrt : t -> partial:bool -> Asrt.t -> Asrt.t val substitute_slcmd : t -> partial:bool -> SLCmd.t -> SLCmd.t val substitute_lcmd : t -> partial:bool -> LCmd.t -> LCmd.t @@ -421,7 +419,7 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct Seq.iter (fun (x, le_x) -> put self_subst (LVar x) le_x) binder_substs; if new_expr == e then this else Exists (bt, new_expr) - method! visit_EForall () this bt e = + method! visit_ForAll () this bt e = let binders = List.to_seq bt |> Seq.map fst in let binder_substs = binders @@ -433,21 +431,7 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct binders; let new_expr = self#visit_expr () e in Seq.iter (fun (x, le_x) -> put self_subst (LVar x) le_x) binder_substs; - if new_expr == e then this else EForall (bt, new_expr) - - method! visit_ForAll () this bt form = - let binders = List.to_seq bt |> Seq.map fst in - let binders_substs = - binders - |> Seq.filter_map (fun x -> - Option.map (fun x_v -> (x, x_v)) (get self_subst (LVar x))) - in - Seq.iter - (fun x -> put self_subst (LVar x) (Val.from_lvar_name x)) - binders; - let new_formula = self#visit_formula () form in - Seq.iter (fun (x, le_x) -> put self_subst (LVar x) le_x) binders_substs; - if new_formula == form then this else ForAll (bt, new_formula) + if new_expr == e then this else ForAll (bt, new_expr) end (** @@ -489,7 +473,7 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct List.iter (fun (x, _) -> Hashtbl.remove subst (Expr.LVar x)) bt; let result = Option.map (fun e' -> Expr.Exists (bt, e')) e' in (result, false) - | EForall (bt, e) -> + | ForAll (bt, e) -> (* We use Hashtbl.add so that we can later remove the binding and recover the old one! *) List.iter (fun (x, _) -> @@ -499,7 +483,7 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct bt; let e' = subst_in_expr_opt subst e in List.iter (fun (x, _) -> Hashtbl.remove subst (Expr.LVar x)) bt; - let result = Option.map (fun e' -> Expr.EForall (bt, e')) e' in + let result = Option.map (fun e' -> Expr.ForAll (bt, e')) e' in (result, false) | _ -> (Some le, true) in @@ -507,45 +491,6 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct let is_empty (subst : t) : bool = Hashtbl.length subst = 0 - let substitute_formula (subst : t) ~(partial : bool) (a : Formula.t) : - Formula.t = - substitutor#init ~partial ~subst; - let res = substitutor#visit_formula () a in - substitutor#clear (); - res - - let substitute_in_formula_opt (subst : t) (a : Formula.t) : Formula.t option = - let open Formula in - let old_binders_substs = ref [] in - let f_before a = - match a with - | ForAll (bt, _) -> - let binders, _ = List.split bt in - let binders_substs = - List.map - (fun x -> Option.map (fun x_v -> (x, x_v)) (get subst (LVar x))) - binders - in - let binders_substs = - try List.filter_map (fun x -> x) binders_substs - with _ -> raise (Failure "DEATH. asrt_substitution") - in - old_binders_substs := binders_substs; - List.iter (fun x -> put subst (LVar x) (Val.from_lvar_name x)) binders; - (Some a, true) - | _ -> (Some a, true) - in - let f_after a = - match a with - | ForAll _ -> - List.iter - (fun (x, le_x) -> put subst (LVar x) le_x) - !old_binders_substs; - a - | _ -> a - in - map_opt (Some f_before) (Some f_after) (Some (subst_in_expr_opt subst)) a - let substitute_asrt (subst : t) ~(partial : bool) (a : Asrt.t) : Asrt.t = substitutor#init ~partial ~subst; let res = substitutor#visit_assertion () a in diff --git a/GillianCore/engine/general_semantics/general/g_interpreter.ml b/GillianCore/engine/general_semantics/general/g_interpreter.ml index 43253fe7..db98b455 100644 --- a/GillianCore/engine/general_semantics/general/g_interpreter.ml +++ b/GillianCore/engine/general_semantics/general/g_interpreter.ml @@ -486,13 +486,19 @@ struct let eval_assume f state = let store_subst = Store.to_ssubst (State.get_store state) in - let f' = SVal.SESubst.substitute_formula store_subst ~partial:true f in + let f' = SVal.SESubst.subst_in_expr store_subst ~partial:true f in (* Printf.printf "Assuming %s\n" (Formula.str f'); *) let open Syntaxes.List in let* f'', state = (* Sacha: I don't know why something different is happening in bi-exec *) if Exec_mode.is_biabduction_exec !Config.current_exec_mode then - let fos = Formula.get_disjuncts f' in + let fos = + let rec aux = function + | Expr.BinOp (e1, Or, e2) -> aux e1 @ aux e2 + | e -> [ e ] + in + aux f' + in match fos with | [] -> [] | [ f' ] -> [ (f', state) ] @@ -518,18 +524,18 @@ struct let eval_assert f state = let store_subst = Store.to_ssubst (State.get_store state) in - let f' = SVal.SESubst.substitute_formula store_subst ~partial:true f in + let f' = SVal.SESubst.subst_in_expr store_subst ~partial:true f in match State.assert_a state [ f' ] with | true -> Res_list.return state | false -> let err = StateErr.EPure f' in - let failing_model = State.sat_check_f state [ Not f' ] in + let failing_model = State.sat_check_f state [ Expr.Infix.not f' ] in let msg = Fmt.str "Assert failed with argument @[%a@].@\n\ @[Failing Model:@\n\ %a@]@\n" - Formula.pp f' + Expr.pp f' Fmt.(option ~none:(any "CANNOT CREATE MODEL") ESubst.pp) failing_model in @@ -544,7 +550,7 @@ struct | None -> Res_list.vanish in let right_states = - match State.assume_a state' [ Not fof ] with + match State.assume_a state' [ Expr.Infix.not fof ] with | Some state -> Res_list.return state | None -> Res_list.vanish in @@ -581,9 +587,9 @@ struct and eval_if e lcmds_t lcmds_e prog annot state eval_expr = let ve = eval_expr e in let e = Val.to_expr ve in - match Formula.lift_logic_expr e with - | Some (True, False) -> eval_lcmds prog lcmds_t ~annot state - | Some (False, True) -> eval_lcmds prog lcmds_e ~annot state + match Expr.as_boolean_expr e with + | Some (Expr.Lit (Bool true), _) -> eval_lcmds prog lcmds_t ~annot state + | Some (Expr.Lit (Bool false), _) -> eval_lcmds prog lcmds_e ~annot state | Some (foe, nfoe) -> let state' = State.copy state in let then_states = @@ -1252,7 +1258,7 @@ struct match lvt with | Some (Bool true) -> vfalse | Some (Bool false) -> vtrue - | _ -> eval_expr (UnOp (UNot, e)) + | _ -> eval_expr (Expr.Infix.not e) in L.verbose (fun fmt -> fmt "Evaluated expressions: %a, %a" Val.pp vt Val.pp vf); diff --git a/GillianCore/engine/general_semantics/state.ml b/GillianCore/engine/general_semantics/state.ml index c677d0e4..d20e9055 100644 --- a/GillianCore/engine/general_semantics/state.ml +++ b/GillianCore/engine/general_semantics/state.ml @@ -52,7 +52,7 @@ module type S = sig ?production:bool -> ?time:string -> t -> - Formula.t list -> + Expr.t list -> t option (** Assume type *) @@ -61,10 +61,10 @@ module type S = sig (** Satisfiability check *) val sat_check : t -> vt -> bool - val sat_check_f : t -> Formula.t list -> st option + val sat_check_f : t -> Expr.t list -> st option (** Assert assertion *) - val assert_a : t -> Formula.t list -> bool + val assert_a : t -> Expr.t list -> bool (** Value Equality *) val equals : t -> vt -> vt -> bool @@ -107,7 +107,7 @@ module type S = sig val get_lvars : t -> Var.Set.t (** Turns a state into a list of assertions *) - val to_assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t list + val to_assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t val evaluate_slcmd : 'a MP.prog -> SLCmd.t -> t -> (t, err_t) Res_list.t @@ -133,7 +133,7 @@ module type S = sig (t * Flag.t, err_t) Res_list.t val sure_is_nonempty : t -> bool - val unfolding_vals : t -> Formula.t list -> vt list + val unfolding_vals : t -> Expr.t list -> vt list val try_recovering : t -> vt Recovery_tactic.t -> (t list, string) result val substitution_in_place : ?subst_all:bool -> st -> t -> t list val clean_up : ?keep:Expr.Set.t -> t -> unit @@ -141,10 +141,10 @@ module type S = sig val produce_posts : t -> st -> Asrt.t list -> t list val produce : t -> st -> Asrt.t -> (t, err_t) Res_list.t val update_subst : t -> st -> unit - val mem_constraints : t -> Formula.t list + val mem_constraints : t -> Expr.t list val can_fix : err_t -> bool - val get_failing_constraint : err_t -> Formula.t - val get_fixes : err_t -> Asrt.t list list + val get_failing_constraint : err_t -> Expr.t + val get_fixes : err_t -> Asrt.t list val get_equal_values : t -> vt list -> vt list val get_heap : t -> heap_t end diff --git a/GillianCore/engine/general_semantics/stateErr.ml b/GillianCore/engine/general_semantics/stateErr.ml index 88375c25..3e799dd4 100644 --- a/GillianCore/engine/general_semantics/stateErr.ml +++ b/GillianCore/engine/general_semantics/stateErr.ml @@ -5,9 +5,9 @@ type ('mem_err, 'value) t = | EMem of 'mem_err (** Memory error, depends on instantiation *) | EType of 'value * Type.t option * Type.t (** Incorrect type, depends on value *) - | EPure of Formula.t (* Missing formula that should be true *) + | EPure of Expr.t (* Missing formula that should be true *) | EVar of Var.t (* Undefined variable *) - | EAsrt of ('value list * Formula.t * Asrt.t list list) + | EAsrt of ('value list * Expr.t * Asrt.t list) | EOther of string (* We want all errors to be proper errors - this is a temporary placeholder *) [@@deriving yojson, show] @@ -36,15 +36,13 @@ let pp_err Fmt.pf fmt "EType(%a, %a, %s)" pp_v v (Fmt.option ~none:(Fmt.any "None") (Fmt.of_to_string Type.str)) t1 (Type.str t2) - | EPure f -> Fmt.pf fmt "EPure(%a)" Formula.pp f + | EPure f -> Fmt.pf fmt "EPure(%a)" Expr.pp f | EVar x -> Fmt.pf fmt "EVar(%s)" x | EAsrt (vs, f, asrtss) -> - let pp_asrts fmt asrts = - Fmt.pf fmt "[%a]" (Fmt.list ~sep:(Fmt.any ", ") Asrt.pp) asrts - in + let pp_asrts fmt asrts = Fmt.pf fmt "[%a]" Asrt.pp asrts in Fmt.pf fmt "EAsrt(%a; %a; %a)" (Fmt.list ~sep:(Fmt.any ", ") pp_v) - vs Formula.pp f + vs Expr.pp f (Fmt.list ~sep:(Fmt.any ", ") pp_asrts) asrtss | EOther msg -> Fmt.pf fmt "%s" msg @@ -52,16 +50,15 @@ let pp_err let can_fix (can_fix_mem : 'a -> bool) (err : ('a, 'b) t) : bool = match err with | EMem mem_err -> can_fix_mem mem_err - | EPure pf -> Reduction.reduce_formula pf <> False + | EPure pf -> Reduction.reduce_lexpr pf <> Expr.false_ | EAsrt (_, pf, _) -> - let result = Reduction.reduce_formula pf <> True in - Logging.verbose (fun fmt -> fmt "Can fix: %a: %b" Formula.pp pf result); + let result = Reduction.reduce_lexpr pf <> Expr.true_ in + Logging.verbose (fun fmt -> fmt "Can fix: %a: %b" Expr.pp pf result); result | _ -> false -let get_failing_constraint (err : ('a, 'b) t) (mem_fc : 'a -> Formula.t) : - Formula.t = +let get_failing_constraint (err : ('a, 'b) t) (mem_fc : 'a -> Expr.t) : Expr.t = match err with | EMem m_err -> mem_fc m_err - | EPure f -> Not f - | _ -> True + | EPure f -> Expr.Infix.not f + | _ -> Expr.true_ diff --git a/GillianCore/engine/general_semantics/subst.ml b/GillianCore/engine/general_semantics/subst.ml index d03a84ea..48058da9 100644 --- a/GillianCore/engine/general_semantics/subst.ml +++ b/GillianCore/engine/general_semantics/subst.ml @@ -77,7 +77,6 @@ module type S = sig (** Optional substitution inside a logical expression *) val subst_in_expr_opt : t -> Expr.t -> Expr.t option - val substitute_formula : t -> partial:bool -> Formula.t -> Formula.t val substitute_asrt : t -> partial:bool -> Asrt.t -> Asrt.t val substitute_slcmd : t -> partial:bool -> SLCmd.t -> SLCmd.t val substitute_lcmd : t -> partial:bool -> LCmd.t -> LCmd.t @@ -324,6 +323,8 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct generating fresh: %s" x lvar)); Expr.LVar lvar) + + (* Need to handle visit_ForAll ?? *) end in mapper#visit_expr () le @@ -345,56 +346,12 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct let is_empty (subst : t) : bool = Hashtbl.length subst = 0 - let substitute_formula (subst : t) ~(partial : bool) (a : Formula.t) : - Formula.t = - let open Formula in - let old_binders_substs = ref [] in - let f_before a = - match a with - | ForAll (bt, _) -> - let binders, _ = List.split bt in - let binders_substs = - List.map - (fun x -> Option.map (fun x_v -> (x, x_v)) (get subst x)) - binders - in - let binders_substs = - try - List.map Option.get - (List.filter (fun x -> not (x = None)) binders_substs) - with _ -> raise (Failure "DEATH. asrt_substitution") - in - old_binders_substs := binders_substs; - List.iter (fun x -> put subst x (Val.from_lvar_name x)) binders; - (a, true) - | _ -> (a, true) - in - let f_after a = - match a with - | ForAll _ -> - List.iter (fun (x, le_x) -> put subst x le_x) !old_binders_substs; - a - | _ -> a - in - map (Some f_before) (Some f_after) (Some (subst_in_expr subst ~partial)) a - - let substitute_asrt (subst : t) ~(partial : bool) (a : Asrt.t) : Asrt.t = - Asrt.map None None - (Some (subst_in_expr subst ~partial)) - (Some (substitute_formula subst ~partial)) - a - - let substitute_slcmd (subst : t) ~(partial : bool) (lcmd : SLCmd.t) : SLCmd.t - = - SLCmd.map None - (Some (substitute_asrt subst ~partial)) - (Some (subst_in_expr subst ~partial)) - lcmd - - let substitute_lcmd (subst : t) ~(partial : bool) (lcmd : LCmd.t) : LCmd.t = - LCmd.map None - (Some (subst_in_expr subst ~partial)) - (Some (substitute_formula subst ~partial)) - (Some (substitute_slcmd subst ~partial)) - lcmd + let substitute_asrt (subst : t) ~(partial : bool) : Asrt.t -> Asrt.t = + Asrt.map (subst_in_expr subst ~partial) + + let substitute_slcmd (subst : t) ~(partial : bool) : SLCmd.t -> SLCmd.t = + SLCmd.map (substitute_asrt subst ~partial) (subst_in_expr subst ~partial) + + let substitute_lcmd (subst : t) ~(partial : bool) : LCmd.t -> LCmd.t = + LCmd.map (subst_in_expr subst ~partial) (substitute_slcmd subst ~partial) end diff --git a/GillianCore/engine/symbolic_semantics/Legacy_s_memory.ml b/GillianCore/engine/symbolic_semantics/Legacy_s_memory.ml index 07fd9b00..43b92eb9 100644 --- a/GillianCore/engine/symbolic_semantics/Legacy_s_memory.ml +++ b/GillianCore/engine/symbolic_semantics/Legacy_s_memory.ml @@ -4,18 +4,18 @@ module type S = sig type init_data (** Type of GIL values *) - type vt = SVal.M.t + type vt := SVal.M.t (** Type of GIL substitutions *) - type st = SVal.SESubst.t + type st := SVal.SESubst.t type err_t [@@deriving yojson, show] (** Type of GIL general states *) type t [@@deriving yojson] - type action_ret = - ( (t * vt list * Formula.t list * (string * Type.t) list) list, + type action_ret := + ( (t * vt list * Expr.t list * (string * Type.t) list) list, err_t list ) result @@ -54,33 +54,26 @@ module type S = sig gamma:Type_env.t -> st -> t -> - (t * Formula.Set.t * (string * Type.t) list) list + (t * Expr.Set.t * (string * Type.t) list) list val clean_up : ?keep:Expr.Set.t -> t -> Expr.Set.t * Expr.Set.t val lvars : t -> Containers.SS.t val alocs : t -> Containers.SS.t - val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t list - val mem_constraints : t -> Formula.t list + val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t + val mem_constraints : t -> Expr.t list val get_recovery_tactic : t -> err_t -> vt Recovery_tactic.t val pp_err : Format.formatter -> err_t -> unit - val get_failing_constraint : err_t -> Formula.t + val get_failing_constraint : err_t -> Expr.t val can_fix : err_t -> bool - val get_fixes : err_t -> Asrt.t list list + val get_fixes : err_t -> Asrt.t list val sure_is_nonempty : t -> bool end module Dummy : S with type init_data = unit = struct type init_data = unit - type vt = SVal.M.t - type st = SVal.SESubst.t type err_t = unit [@@deriving yojson, show] type t = unit [@@deriving yojson] - type action_ret = - ( (t * vt list * Formula.t list * (string * Type.t) list) list, - err_t list ) - result - let init () = () let get_init_data () = () let clear () = () diff --git a/GillianCore/engine/symbolic_semantics/SMemory.ml b/GillianCore/engine/symbolic_semantics/SMemory.ml index 0ca184d6..59748e7a 100644 --- a/GillianCore/engine/symbolic_semantics/SMemory.ml +++ b/GillianCore/engine/symbolic_semantics/SMemory.ml @@ -4,10 +4,10 @@ module type S = sig type init_data (** Type of GIL values *) - type vt = SVal.M.t + type vt := SVal.M.t (** Type of GIL substitutions *) - type st = SVal.SESubst.t + type st := SVal.SESubst.t type err_t [@@deriving yojson, show] @@ -49,17 +49,17 @@ module type S = sig gamma:Type_env.t -> st -> t -> - (t * Formula.Set.t * (string * Type.t) list) list + (t * Expr.Set.t * (string * Type.t) list) list val clean_up : ?keep:Expr.Set.t -> t -> Expr.Set.t * Expr.Set.t val lvars : t -> Containers.SS.t val alocs : t -> Containers.SS.t - val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t list - val mem_constraints : t -> Formula.t list + val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t + val mem_constraints : t -> Expr.t list val get_recovery_tactic : t -> err_t -> vt Recovery_tactic.t val pp_err : Format.formatter -> err_t -> unit - val get_failing_constraint : err_t -> Formula.t - val get_fixes : err_t -> Asrt.t list list + val get_failing_constraint : err_t -> Expr.t + val get_fixes : err_t -> Asrt.t list val can_fix : err_t -> bool val sure_is_nonempty : t -> bool @@ -84,8 +84,6 @@ end module Dummy : S with type init_data = unit = struct type init_data = unit - type vt = SVal.M.t - type st = SVal.SESubst.t type err_t = unit [@@deriving yojson, show] type t = unit [@@deriving yojson] diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index 9b6b0526..79784f31 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -252,7 +252,7 @@ module Make (SMemory : SMemory.S) : | LstSub (e1, e2, e3) -> LstSub (f e1, f e2, f e3) (* Exists. We can just evaluate pvars because they cannot be quantified *) | Exists (bt, e) -> Exists (bt, f e) - | EForall (bt, e) -> EForall (bt, f e) + | ForAll (bt, e) -> ForAll (bt, f e) | Lit _ | LVar _ | ALoc _ -> expr in (* Perform reduction *) @@ -277,14 +277,15 @@ module Make (SMemory : SMemory.S) : | Lit (Bool false) -> [ state ] | _ -> (* let t = time() in *) + let red = + Expr.as_boolean_expr @@ Reduction.reduce_lexpr ~pfs ~gamma v + in let v_asrt = - match - Formula.lift_logic_expr (Reduction.reduce_lexpr ~pfs ~gamma v) - with + match red with | Some (v_asrt, _) -> v_asrt - | _ -> False + | _ -> Lit (Bool false) in - if v_asrt = False then [] + if v_asrt = Lit (Bool false) then [] else ( PFS.extend pfs v_asrt; [ state ]) @@ -296,16 +297,10 @@ module Make (SMemory : SMemory.S) : ?(production = false) ?(time = "") (state : t) - (ps : Formula.t list) : t option = + (ps : Expr.t list) : t option = let { pfs; gamma; _ } = state in try - let ps = - List.map - (Reduction.reduce_formula - ~time:("SState: assume_a: " ^ time) - ~pfs ~gamma) - ps - in + let ps = List.map (Reduction.reduce_lexpr ~pfs ~gamma) ps in let result = if production @@ -319,14 +314,14 @@ module Make (SMemory : SMemory.S) : Some state) else ( Logging.verbose (fun m -> - m "assume_a: Couldn't assume %a" (Fmt.Dump.list Formula.pp) ps); + m "assume_a: Couldn't assume %a" (Fmt.Dump.list Expr.pp) ps); None) in result with Reduction.ReductionException (e, msg) -> Logging.verbose (fun m -> m "assume_a: Couldn't assume due to an error reducing %a - %s\nps: %a" - Expr.pp e msg (Fmt.Dump.list Formula.pp) ps); + Expr.pp e msg (Fmt.Dump.list Expr.pp) ps); None let assume_t ({ gamma; _ } as state : t) (v : vt) (t : Type.t) : t option = @@ -343,9 +338,9 @@ module Make (SMemory : SMemory.S) : else if v = Lit (Bool false) then false else let v_asrt = - match Formula.lift_logic_expr v with + match Expr.as_boolean_expr v with | Some (v_asrt, _) -> v_asrt - | _ -> False + | _ -> Lit (Bool false) in let relevant_info = (Expr.pvars v, Expr.lvars v, Expr.locs v) in let result = @@ -356,10 +351,10 @@ module Make (SMemory : SMemory.S) : L.(verbose (fun m -> m "SState: sat_check done: %b" result)); result - let sat_check_f ({ pfs; gamma; _ } : t) (fs : Formula.t list) : st option = + let sat_check_f ({ pfs; gamma; _ } : t) (fs : Expr.t list) : st option = FOSolver.check_satisfiability_with_model (fs @ PFS.to_list pfs) gamma - let assert_a ({ pfs; gamma; _ } : t) (ps : Formula.t list) : bool = + let assert_a ({ pfs; gamma; _ } : t) (ps : Expr.t list) : bool = FOSolver.check_entailment SS.empty pfs ps gamma let equals ({ pfs; gamma; _ } : t) (le1 : vt) (le2 : vt) : bool = @@ -432,7 +427,7 @@ module Make (SMemory : SMemory.S) : match memories with | [] -> failwith "Impossible: memory substitution returned []" | [ (mem, lpfs, lgamma) ] -> - let () = Formula.Set.iter (PFS.extend pfs) lpfs in + let () = Expr.Set.iter (PFS.extend pfs) lpfs in let () = List.iter (fun (t, v) -> Type_env.update gamma t v) lgamma in @@ -444,7 +439,7 @@ module Make (SMemory : SMemory.S) : (fun (mem, lpfs, lgamma) -> let bpfs = PFS.copy pfs in let bgamma = Type_env.copy gamma in - let () = Formula.Set.iter (PFS.extend bpfs) lpfs in + let () = Expr.Set.iter (PFS.extend bpfs) lpfs in let () = List.iter (fun (t, v) -> Type_env.update bgamma t v) lgamma in @@ -507,7 +502,7 @@ module Make (SMemory : SMemory.S) : |> SS.union (Type_env.lvars gamma) |> SS.union spec_vars - let to_assertions ?(to_keep : SS.t option) (state : t) : Asrt.t list = + let to_assertions ?(to_keep : SS.t option) (state : t) : Asrt.t = let { heap; store; pfs; gamma; _ } = state in let store' = Option.fold @@ -551,22 +546,15 @@ module Make (SMemory : SMemory.S) : (_ : (string * (string * vt) list) option) = raise (Failure "ERROR: run_spec called for non-abstract execution") - let unfolding_vals (_ : t) (fs : Formula.t list) : vt list = - let lvars = - SS.of_list - (List.concat (List.map (fun f -> SS.elements (Formula.lvars f)) fs)) - in - let alocs = - SS.of_list - (List.concat (List.map (fun f -> SS.elements (Formula.alocs f)) fs)) + let unfolding_vals (_ : t) (fs : Expr.t list) : vt list = + let map to_str to_expr = + List.map to_str fs + |> List.fold_left SS.union SS.empty + |> SS.elements |> List.map to_expr in - let clocs = - SS.of_list - (List.concat (List.map (fun f -> SS.elements (Formula.clocs f)) fs)) - in - let lvars = List.map (fun x -> Expr.LVar x) (SS.elements lvars) in - let alocs = List.map (fun x -> Expr.ALoc x) (SS.elements alocs) in - let clocs = List.map (fun x -> Expr.Lit (Loc x)) (SS.elements clocs) in + let lvars = map Expr.lvars (fun x -> Expr.LVar x) in + let alocs = map Expr.alocs (fun x -> Expr.ALoc x) in + let clocs = map Expr.clocs (fun x -> Expr.Lit (Loc x)) in clocs @ alocs @ lvars let substitution_in_place ?(subst_all = false) (subst : st) (state : t) : @@ -581,7 +569,7 @@ module Make (SMemory : SMemory.S) : match SMemory.substitution_in_place ~pfs ~gamma subst heap with | [] -> failwith "IMPOSSIBLE: SMemory always returns at least one memory" | [ (mem, lpfs, lgamma) ] -> - let () = Formula.Set.iter (PFS.extend pfs) lpfs in + let () = Expr.Set.iter (PFS.extend pfs) lpfs in let () = List.iter (fun (t, v) -> Type_env.update gamma t v) lgamma in [ { heap = mem; store; pfs; gamma; spec_vars } ] | multi_mems -> @@ -589,7 +577,7 @@ module Make (SMemory : SMemory.S) : (fun (mem, lpfs, lgamma) -> let bpfs = PFS.copy pfs in let bgamma = Type_env.copy gamma in - let () = Formula.Set.iter (PFS.extend bpfs) lpfs in + let () = Expr.Set.iter (PFS.extend bpfs) lpfs in let () = List.iter (fun (t, v) -> Type_env.update bgamma t v) lgamma in @@ -672,7 +660,7 @@ module Make (SMemory : SMemory.S) : | None -> ALoc (ALoc.alloc ())) | None -> ALoc (ALoc.alloc ()) - let mem_constraints ({ heap; _ } : t) : Formula.t list = + let mem_constraints ({ heap; _ } : t) : Expr.t list = SMemory.mem_constraints heap let get_recovery_tactic (state : t) (errs : err_t list) : vt Recovery_tactic.t @@ -684,9 +672,9 @@ module Make (SMemory : SMemory.S) : if Recovery_tactic.is_none memory_tactic then memory_tactic else PFS.fold_left - (fun (acc : vt Recovery_tactic.t) pf -> - match pf with - | Eq ((ALoc _ as loc), LVar x) | Eq (LVar x, (ALoc _ as loc)) -> + (fun (acc : vt Recovery_tactic.t) -> function + | BinOp ((ALoc _ as loc), Equal, LVar x) + | BinOp (LVar x, Equal, (ALoc _ as loc)) -> if Names.is_spec_var_name x then let try_fold = Option.map @@ -709,23 +697,21 @@ module Make (SMemory : SMemory.S) : let pp_err = StateErr.pp_err SMemory.pp_err SVal.M.pp let can_fix = StateErr.can_fix SMemory.can_fix - let get_failing_constraint (err : err_t) : Formula.t = + let get_failing_constraint (err : err_t) : Expr.t = StateErr.get_failing_constraint err SMemory.get_failing_constraint (* get_fixes returns a list of possible fixes. Each "fix" is actually a list of assertions, each of which have to be applied to the same state *) - let get_fixes (err : err_t) : Asrt.t list list = - let pp_fixes fmt fixes = - Fmt.pf fmt "[[ %a ]]" (Fmt.list ~sep:(Fmt.any ", ") Asrt.pp) fixes - in - let one_step_fixes : Asrt.t list list = + let get_fixes (err : err_t) : Asrt.t list = + let pp_fix fmt fix = Fmt.pf fmt "[[ %a ]]" Asrt.pp fix in + let one_step_fixes : Asrt.t list = match err with | EMem err -> SMemory.get_fixes err | EPure f -> let result = [ [ Asrt.Pure f ] ] in L.verbose (fun m -> m "@[Memory: Fixes found:@\n%a@]" - (Fmt.list ~sep:(Fmt.any "@\n") pp_fixes) + (Fmt.list ~sep:(Fmt.any "@\n") pp_fix) result); result | EAsrt (_, _, fixes) -> @@ -741,7 +727,7 @@ module Make (SMemory : SMemory.S) : in L.verbose (fun m -> m "@[Memory: Fixes found:@\n%a@]" - (Fmt.list ~sep:(Fmt.any "@\n") pp_fixes) + (Fmt.list ~sep:(Fmt.any "@\n") pp_fix) result); result | _ -> raise (Failure "DEATH: get_fixes: error cannot be fixed.") @@ -749,7 +735,7 @@ module Make (SMemory : SMemory.S) : L.tmi (fun m -> m "All fixes before normalisation: %a" - Fmt.Dump.(list @@ list @@ Asrt.pp) + Fmt.Dump.(list Asrt.pp) one_step_fixes); List.map (fun fixes -> diff --git a/GillianCore/engine/symbolic_semantics/SStore.ml b/GillianCore/engine/symbolic_semantics/SStore.ml index 0351c7aa..5c56ddce 100644 --- a/GillianCore/engine/symbolic_semantics/SStore.ml +++ b/GillianCore/engine/symbolic_semantics/SStore.ml @@ -32,9 +32,10 @@ let clocs (x : t) : SS.t = fold x (fun _ le ac -> SS.union ac (Expr.clocs le)) SS.empty (** conversts a symbolic store to a list of assertions *) -let assertions (x : t) : Formula.t list = +let assertions (x : t) : Expr.t list = fold x - (fun x le (assertions : Formula.t list) -> Eq (PVar x, le) :: assertions) + (fun x le (assertions : Expr.t list) -> + Expr.BinOp (PVar x, Equal, le) :: assertions) [] let is_well_formed (_ : t) : bool = true diff --git a/GillianCore/engine/symbolic_semantics/SStore.mli b/GillianCore/engine/symbolic_semantics/SStore.mli index 01c1392e..089b75c4 100644 --- a/GillianCore/engine/symbolic_semantics/SStore.mli +++ b/GillianCore/engine/symbolic_semantics/SStore.mli @@ -24,7 +24,7 @@ val vars : t -> Var.Set.t val lvars : t -> Var.Set.t val clocs : t -> Var.Set.t val alocs : t -> Var.Set.t -val assertions : t -> Formula.t list +val assertions : t -> Expr.t list val substitution_in_place : ?subst_all:bool -> SVal.SESubst.t -> t -> unit val is_well_formed : t -> bool val bindings : t -> (Var.t * vt) list diff --git a/GillianCore/gil_parser/GIL_Lexer.mll b/GillianCore/gil_parser/GIL_Lexer.mll index ea58bf0b..1b3937de 100644 --- a/GillianCore/gil_parser/GIL_Lexer.mll +++ b/GillianCore/gil_parser/GIL_Lexer.mll @@ -28,7 +28,9 @@ "null", GIL_Parser.NULL; "empty", GIL_Parser.EMPTY; "true", GIL_Parser.TRUE; + "True", GIL_Parser.TRUE; "false", GIL_Parser.FALSE; + "False", GIL_Parser.FALSE; "nan", GIL_Parser.NAN; "inf", GIL_Parser.INFINITY; "nil", GIL_Parser.LSTNIL; @@ -87,8 +89,6 @@ "none", GIL_Parser.LNONE; (* Logic assertions *) - "True", GIL_Parser.LTRUE; - "False", GIL_Parser.LFALSE; "emp", GIL_Parser.LEMP; "types", GIL_Parser.LTYPES; "forall", GIL_Parser.LFORALL; @@ -181,11 +181,14 @@ rule read = parse (* Binary operators *) | "==>" { GIL_Parser.LIMPLIES } + | "==" | "=" { GIL_Parser.EQ } | "-*" { GIL_Parser.WAND } + | "i<#" | "i<" { GIL_Parser.ILT } | "i>" { GIL_Parser.IGT } + | "i<=#" | "i<=" { GIL_Parser.ILE } | "i>=" { GIL_Parser.IGE } | "i+" { GIL_Parser.IPLUS } @@ -194,8 +197,10 @@ rule read = parse | "i/" { GIL_Parser.IDIV } | "i%" { GIL_Parser.IMOD } + | "<#" | "<" { GIL_Parser.FLT } | ">" { GIL_Parser.FGT } + | "<=#" | "<=" { GIL_Parser.FLE } | ">=" { GIL_Parser.FGE } | "+" { GIL_Parser.FPLUS } @@ -204,6 +209,7 @@ rule read = parse | "/" { GIL_Parser.FDIV } | "%" { GIL_Parser.FMOD } + | "s<#" | "s<" { GIL_Parser.SLT } | "&" { GIL_Parser.BITWISEAND } | "|" { GIL_Parser.BITWISEOR } @@ -223,10 +229,10 @@ rule read = parse | "-u-" { GIL_Parser.SETUNION } | "-i-" { GIL_Parser.SETINTER } | "-d-" { GIL_Parser.SETDIFF } + | "--e--" | "-e-" { GIL_Parser.SETMEM } + | "--s--" | "-s-" { GIL_Parser.SETSUB } - | "--e--" { GIL_Parser.LSETMEM } - | "--s--" { GIL_Parser.LSETSUB } | "-{" { GIL_Parser.SETOPEN } | "}-" { GIL_Parser.SETCLOSE } (* Unary operators *) @@ -248,12 +254,6 @@ rule read = parse | "/\\" { GIL_Parser.LAND } | "\\/" { GIL_Parser.LOR } | "!" { GIL_Parser.LNOT } - | "==" { GIL_Parser.LEQUAL } - | "i<#" { GIL_Parser.ILLESSTHAN } - | "i<=#" { GIL_Parser.ILLESSTHANEQUAL } - | "<#" { GIL_Parser.FLLESSTHAN } - | "<=#" { GIL_Parser.FLLESSTHANEQUAL } - | "s<#" { GIL_Parser.LSLESSTHAN } | "is-int" { GIL_Parser.ISINT } (* Separating conjunction uses the same symbol as product, token TIMES *) (* Logic commands *) @@ -340,4 +340,4 @@ and read_init_data buf = { end -} \ No newline at end of file +} diff --git a/GillianCore/gil_parser/GIL_Parser.mly b/GillianCore/gil_parser/GIL_Parser.mly index 81ab250f..a59c1572 100644 --- a/GillianCore/gil_parser/GIL_Parser.mly +++ b/GillianCore/gil_parser/GIL_Parser.mly @@ -48,6 +48,8 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" (* Binary operators *) %token EQ %token WAND +%token LAND +%token LOR %token FLT %token FGT @@ -129,7 +131,7 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %token ASSERT %token SEPASSERT %token INVARIANT -%token CONSUME +%token CONSUME %token PRODUCE %token ASSUME_TYPE %token LSTNTH @@ -159,18 +161,8 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" (* Logic assertions *) %token OASSERT %token CASSERT -%token LAND -%token LOR %token LIMPLIES %token LNOT -%token LTRUE -%token LFALSE -%token LEQUAL -%token ILLESSTHAN -%token ILLESSTHANEQUAL -%token FLLESSTHAN -%token FLLESSTHANEQUAL -%token LSLESSTHAN %token ISINT %token LEMP (*%token LEXISTS *) @@ -235,8 +227,6 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %token SETDIFF %token SETMEM %token SETSUB -%token LSETMEM -%token LSETSUB %token SETOPEN %token SETCLOSE (* EOF *) @@ -245,21 +235,14 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" (***** Precedence of operators *****) (* The later an operator is listed, the higher precedence it is given. *) (* Logic operators have lower precedence *) -%nonassoc DOT -%left LIMPLIES -%left LOR -%left LAND -%left separating_conjunction -%left magic_wand -%right LNOT -%right ISINT -%nonassoc LEQUAL ILLESSTHAN ILLESSTHANEQUAL FLLESSTHAN FLLESSTHANEQUAL LSLESSTHAN -%nonassoc SETMEM SETSUB LSETMEM LSETSUB (* Program operators have higher precedence.*) (* Based on JavaScript: https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Operators/Operator_Precedence *) -%left OR -%left AND +%nonassoc DOT +%left separating_conjunction +%left LIMPLIES +%left OR, LOR +%left AND, LAND %nonassoc EQ %nonassoc FLT FLE FGT FGE ILT ILE IGT IGE SLT %left LEFTSHIFT SIGNEDRIGHTSHIFT UNSIGNEDRIGHTSHIFT LEFTSHIFTL SIGNEDRIGHTSHIFTL UNSIGNEDRIGHTSHIFTL @@ -267,18 +250,14 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %left FPLUS FMINUS IPLUS IMINUS %left FTIMES FDIV FMOD ITIMES IDIV IMOD M_POW %left M_ATAN2 STRCAT SETDIFF - -%nonassoc binop_prec -%nonassoc unop_prec +%nonassoc SETMEM SETSUB (***** Types and entry points *****) %type lit_target %type type_target %type constant_target %type unop_target -%type binop_target %type nop_target -%type pure_assertion_target %type <(Annot.t, string) Prog.t * Yojson.Safe.t> gmain_target %type top_level_expr_target @@ -369,7 +348,7 @@ pred_head_target: (********* Expressions *********) (*******************************) -expr_target: +atomic_expr_target: (* literal *) | lit=lit_target { Expr.Lit lit } (* Logic variable *) @@ -381,26 +360,6 @@ expr_target: (* Program variable (including the special variable "ret") *) | pvar = program_variable_target { pvar } -(* e binop e *) - | e1=expr_target; bop=binop_target; e2=expr_target - { Expr.BinOp (e1, bop, e2) } %prec binop_prec - | e1=expr_target; FGT; e2=expr_target - { Expr.BinOp (e2, FLessThan, e1) } - | e1=expr_target; FGE; e2=expr_target - { Expr.BinOp (e2, FLessThanEqual, e1) } - | e1=expr_target; IGT; e2=expr_target - { Expr.BinOp (e2, ILessThan, e1) } - | e1=expr_target; IGE; e2=expr_target - { Expr.BinOp (e2, ILessThanEqual, e1) } -(* unop e *) - | uop=unop_target; e=expr_target - { Expr.UnOp (uop, e) } %prec unop_prec -(* - e *) -(* Unary negation has the same precedence as logical not, not as binary negation. *) - | IMINUS; e=expr_target - { Expr.UnOp (IUnaryMinus, e) } %prec unop_prec - | FMINUS; e=expr_target - { Expr.UnOp (FUnaryMinus, e) } %prec unop_prec (* {{ e, ..., e }} *) | LSTOPEN; exprlist = separated_nonempty_list(COMMA, expr_target); LSTCLOSE { Expr.EList exprlist } @@ -436,7 +395,139 @@ expr_target: | EXISTS; vars = separated_nonempty_list(COMMA, lvar_type_target); DOT; e = expr_target { Expr.Exists (vars, e) } | LFORALL; vars = separated_nonempty_list(COMMA, lvar_type_target); DOT; e = expr_target - { Expr.EForall (vars, e) } + { Expr.ForAll (vars, e) } +; + +unary_expr: + | atomic_expr_target { $1 } +(* unop e *) + | uop=unop_target; e=unary_expr + { Expr.UnOp (uop, e) } +(* - e *) + | IMINUS; e=unary_expr + { Expr.UnOp (IUnaryMinus, e) } + | FMINUS; e=unary_expr + { Expr.UnOp (FUnaryMinus, e) } + +set_op_expr: + | unary_expr { $1 } + | e1 = set_op_expr; SETMEM; e2 = unary_expr + { Expr.BinOp (e1, SetMem, e2) } + | e1 = set_op_expr; SETSUB; e2 = unary_expr + { Expr.BinOp (e1, SetSub, e2) } + +unary_op_expr: + | set_op_expr { $1 } + | e1 = unary_op_expr; M_ATAN2; e2 = set_op_expr + { Expr.BinOp (e1, M_atan2, e2) } + | e1 = unary_op_expr; STRCAT; e2 = set_op_expr + { Expr.BinOp (e1, StrCat, e2) } + | e1 = unary_op_expr; SETDIFF; e2 = set_op_expr + { Expr.BinOp (e1, SetDiff, e2) } + +muldiv_expr: + | unary_op_expr { $1 } + | e1 = muldiv_expr; FTIMES; e2 = unary_op_expr + { Expr.BinOp (e1, FTimes, e2) } + | e1 = muldiv_expr; FDIV; e2 = unary_op_expr + { Expr.BinOp (e1, FDiv, e2) } + | e1 = muldiv_expr; FMOD; e2 = unary_op_expr + { Expr.BinOp (e1, FMod, e2) } + | e1 = muldiv_expr; ITIMES; e2 = unary_op_expr + { Expr.BinOp (e1, ITimes, e2) } + | e1 = muldiv_expr; IDIV; e2 = unary_op_expr + { Expr.BinOp (e1, IDiv, e2) } + | e1 = muldiv_expr; IMOD; e2 = unary_op_expr + { Expr.BinOp (e1, IMod, e2) } + | e1 = muldiv_expr; M_POW; e2 = unary_op_expr + { Expr.BinOp (e1, M_pow, e2) } + +addsub_expr: + | muldiv_expr { $1 } + | e1 = addsub_expr; FPLUS; e2 = muldiv_expr + { Expr.BinOp (e1, FPlus, e2) } + | e1 = addsub_expr; FMINUS; e2 = muldiv_expr + { Expr.BinOp (e1, FMinus, e2) } + | e1 = addsub_expr; IPLUS; e2 = muldiv_expr + { Expr.BinOp (e1, IPlus, e2) } + | e1 = addsub_expr; IMINUS; e2 = muldiv_expr + { Expr.BinOp (e1, IMinus, e2) } + +binary_op_expr: + | addsub_expr { $1 } + | e1 = binary_op_expr; BITWISEOR; e2 = addsub_expr + { Expr.BinOp (e1, BitwiseOr, e2) } + | e1 = binary_op_expr; BITWISEXOR; e2 = addsub_expr + { Expr.BinOp (e1, BitwiseXor, e2) } + | e1 = binary_op_expr; BITWISEAND; e2 = addsub_expr + { Expr.BinOp (e1, BitwiseAnd, e2) } + | e1 = binary_op_expr; BITWISEXORL; e2 = addsub_expr + { Expr.BinOp (e1, BitwiseXorL, e2) } + | e1 = binary_op_expr; BITWISEORL; e2 = addsub_expr + { Expr.BinOp (e1, BitwiseOrL, e2) } + | e1 = binary_op_expr; BITWISEANDL; e2 = addsub_expr + { Expr.BinOp (e1, BitwiseAndL, e2) } + +shift_expr: + | binary_op_expr { $1 } + | e1 = shift_expr; LEFTSHIFT; e2 = binary_op_expr + { Expr.BinOp (e1, LeftShift, e2) } + | e1 = shift_expr; SIGNEDRIGHTSHIFT; e2 = binary_op_expr + { Expr.BinOp (e1, SignedRightShift, e2) } + | e1 = shift_expr; UNSIGNEDRIGHTSHIFT; e2 = binary_op_expr + { Expr.BinOp (e1, UnsignedRightShift, e2) } + | e1 = shift_expr; LEFTSHIFTL; e2 = binary_op_expr + { Expr.BinOp (e1, LeftShiftL, e2) } + | e1 = shift_expr; SIGNEDRIGHTSHIFTL; e2 = binary_op_expr + { Expr.BinOp (e1, SignedRightShiftL, e2) } + | e1 = shift_expr; UNSIGNEDRIGHTSHIFTL; e2 = binary_op_expr + { Expr.BinOp (e1, UnsignedRightShiftL, e2) } + +comparison_expr: + | shift_expr { $1 } + | e1 = comparison_expr; ILT; e2 = shift_expr + { Expr.BinOp (e1, ILessThan, e2) } + | e1 = comparison_expr; ILE; e2 = shift_expr + { Expr.BinOp (e1, ILessThanEqual, e2) } + | e1 = comparison_expr; IGT; e2 = shift_expr + { Expr.BinOp (e2, ILessThan, e1) } + | e1 = comparison_expr; IGE; e2 = shift_expr + { Expr.BinOp (e2, ILessThanEqual, e1) } + | e1 = comparison_expr; FLT; e2 = shift_expr + { Expr.BinOp (e1, FLessThan, e2) } + | e1 = comparison_expr; FLE; e2 = shift_expr + { Expr.BinOp (e1, FLessThanEqual, e2) } + | e1 = comparison_expr; FGT; e2 = shift_expr + { Expr.BinOp (e2, FLessThan, e1) } + | e1 = comparison_expr; FGE; e2 = shift_expr + { Expr.BinOp (e2, FLessThanEqual, e1) } + | e1 = comparison_expr; SLT; e2 = shift_expr + { Expr.BinOp (e1, StrLess, e2) } + +eq_expr: + | comparison_expr { $1 } + | e1 = eq_expr; EQ; e2 = comparison_expr + { Expr.BinOp (e1, Equal, e2) } + +and_expr: + | eq_expr { $1 } + | e1 = and_expr; AND; e2 = eq_expr + | e1 = and_expr; LAND; e2 = eq_expr + { Expr.BinOp (e1, And, e2) } + +or_expr: + | and_expr { $1 } + | e1 = or_expr; OR; e2 = and_expr + | e1 = or_expr; LOR; e2 = and_expr + { Expr.BinOp (e1, Or, e2) } + +implication_expr: + | or_expr { $1 } + | e1 = implication_expr; LIMPLIES; e2 = or_expr + { Expr.BinOp (e1, Impl, e2) } + +expr_target: + implication_expr { $1 } ; top_level_expr_target: @@ -696,33 +787,36 @@ predicate_call: { (name, params) } g_assertion_target: +(* (pure) /\ (pure) *) + | LBRACE; e1 = expr_target; RBRACE; LAND; LBRACE; e2 = expr_target; RBRACE + { [ Asrt.Pure (BinOp (e1, And, e2)) ] } +(* (pure) \/ (pure) *) + | LBRACE; e1 = expr_target; RBRACE; LOR; LBRACE; e2 = expr_target; RBRACE + { [ Asrt.Pure (BinOp (e1, Or, e2)) ] } (* P * Q *) (* The precedence of the separating conjunction is not the same as the arithmetic product *) | left_ass=g_assertion_target; FTIMES; right_ass=g_assertion_target - { Asrt.Star (left_ass, right_ass) } %prec separating_conjunction + { left_ass @ right_ass } %prec separating_conjunction | lhs = predicate_call; WAND; rhs = predicate_call - { Asrt.Wand {lhs; rhs } } %prec magic_wand -(* (es; es) *) + { [ Asrt.Wand {lhs; rhs } ] } +(* (es; es) *) | FLT; v=VAR; FGT; LBRACE; es1=separated_list(COMMA, expr_target); SCOLON; es2=separated_list(COMMA, expr_target); RBRACE - { Asrt.GA (v, es1, es2) } + { [ Asrt.CorePred (v, es1, es2) ] } (* emp *) | LEMP; - { Asrt.Emp } + { [ Asrt.Emp ] } (* x(e1, ..., en) *) | pcall = predicate_call - { + { let (name, params) = pcall in - Asrt.Pred (name, params) + [ Asrt.Pred (name, params) ] } (* types (type_pairs) *) | LTYPES; LBRACE; type_pairs = separated_list(COMMA, type_env_pair_target); RBRACE - { Asrt.Types type_pairs } -(* (P) *) - | LBRACE; g_assertion_target; RBRACE - { $2 } -(* pure *) - | pure_assertion_target - { Asrt.Pure $1 } + { [ Asrt.Types type_pairs ] } +(* (pure) *) + | LBRACE; expr_target; RBRACE + { [ Asrt.Pure $2 ] } ; g_macro_target: @@ -752,7 +846,7 @@ g_logic_cmd_target: (* unfold* x(e1, ..., en) [ def with #x := le1 and ... ] *) | RECUNFOLD; name = proc_name; LBRACE; les=separated_list(COMMA, expr_target); RBRACE; unfold_info = option(unfold_info_target) { LCmd.SL (Unfold (name, les, unfold_info, true)) } - + | PACKAGE; LBRACE; lhs = predicate_call; WAND; rhs = predicate_call; RBRACE; { LCmd.SL (Package { lhs; rhs })} @@ -765,10 +859,10 @@ g_logic_cmd_target: (* invariant (a) [existentials: x, y, z] *) | INVARIANT; LBRACE; a = g_assertion_target; RBRACE; binders = option(binders_target) { LCmd.SL (Invariant (a, Option.value ~default:[ ] binders)) } - + | CONSUME; LBRACE; a = g_assertion_target; RBRACE; binders = option(binders_target) { LCmd.SL (Consume (a, Option.value ~default:[ ] binders)) } - + | PRODUCE; LBRACE; a = g_assertion_target; RBRACE; { LCmd.SL (Produce a) } @@ -801,11 +895,11 @@ g_logic_cmd_target: { let (name, params) = macro in LCmd.Macro (name, params) } (* assert (a) *) - | ASSERT; LBRACE; a = pure_assertion_target; RBRACE + | ASSERT; LBRACE; a = expr_target; RBRACE { LCmd.Assert a } (* assume (a) *) - | ASSUME; LBRACE; a = pure_assertion_target; RBRACE + | ASSUME; LBRACE; a = expr_target; RBRACE { LCmd.Assume a } (* assume_type (x, t) *) @@ -818,7 +912,7 @@ g_logic_cmd_target: { LCmd.FreshSVar (v) } (* branch (fo) *) - | BRANCH; LBRACE; fo = pure_assertion_target; RBRACE + | BRANCH; LBRACE; fo = expr_target; RBRACE { LCmd.Branch fo } ; @@ -827,7 +921,7 @@ g_pred_def_target: { defs } g_pred_facts_target: - FACTS; COLON; facts = separated_nonempty_list(AND, pure_assertion_target); SCOLON + FACTS; COLON; facts = expr_target; SCOLON { facts } g_pred_cost_target: @@ -861,7 +955,12 @@ g_pred_target: preds_with_no_paths := SS.add pred_name !preds_with_no_paths in let pred_normalised = !Config.previously_normalised in - let pred_facts = Option.value ~default:[] pred_facts in + let rec split_ands = function + | Expr.BinOp (e1, And, e2) -> (split_ands e1) @ (split_ands e2) + | e -> [e] + in + let pred_facts = Option.fold ~none:[] ~some:split_ands pred_facts in + Pred. { pred_name; @@ -1008,61 +1107,6 @@ existentials_target: { xs } ; -pure_assertion_target: -(* P /\ Q *) - | left_ass=pure_assertion_target; LAND; right_ass=pure_assertion_target - { Formula.And (left_ass, right_ass) } -(* A ==> B *) - | left_ass = pure_assertion_target; LIMPLIES; right_ass=pure_assertion_target - { Formula.Impl (left_ass, right_ass) } -(* P \/ Q *) - | left_ass=pure_assertion_target; LOR; right_ass=pure_assertion_target - { Formula.Or (left_ass, right_ass) } -(* ! Q *) - | LNOT; ass=pure_assertion_target - { Formula.Not (ass) } -(* true *) - | LTRUE - { Formula.True } -(* false *) - | LFALSE - { Formula.False } -(* E == E *) - | left_expr=expr_target; LEQUAL; right_expr=expr_target - { Formula.Eq (left_expr, right_expr) } -(* E i<# E *) - | left_expr=expr_target; ILLESSTHAN; right_expr=expr_target - { Formula.ILess (left_expr, right_expr) } -(* E <# E *) - | left_expr=expr_target; FLLESSTHAN; right_expr=expr_target - { Formula.FLess (left_expr, right_expr) } -(* E i<=# E *) - | left_expr=expr_target; ILLESSTHANEQUAL; right_expr=expr_target - { Formula.ILessEq (left_expr, right_expr) } -(* E <=# E *) - | left_expr=expr_target; FLLESSTHANEQUAL; right_expr=expr_target - { Formula.FLessEq (left_expr, right_expr) } -(* E s<# E *) - | left_expr=expr_target; LSLESSTHAN; right_expr=expr_target - { Formula.StrLess (left_expr, right_expr) } -(* E --e-- E *) - | left_expr=expr_target; LSETMEM; right_expr=expr_target - { Formula.SetMem (left_expr, right_expr) } -(* E --s-- E *) - | left_expr=expr_target; LSETSUB; right_expr=expr_target - { Formula.SetSub (left_expr, right_expr) } -(* forall X, Y, Z . P *) - | LFORALL; vars = separated_nonempty_list(COMMA, lvar_type_target); DOT; ass = pure_assertion_target - { Formula.ForAll (vars, ass) } -(* is-int E *) - | ISINT; expr=expr_target - { Formula.IsInt (expr) } -(* (P) *) - | LBRACE; f=pure_assertion_target; RBRACE - { f } -; - - lvar_type_target: | lvar = just_logic_variable_target; COLON; the_type = type_target @@ -1121,49 +1165,10 @@ nop_target: | LSTCAT { NOp.LstCat } ; -binop_target: - | EQ { BinOp.Equal } - | ILT { BinOp.ILessThan } - | ILE { BinOp.ILessThanEqual } - | IPLUS { BinOp.IPlus } - | IMINUS { BinOp.IMinus } - | ITIMES { BinOp.ITimes } - | IDIV { BinOp.IDiv } - | IMOD { BinOp.IMod } - | FLT { BinOp.FLessThan } - | FLE { BinOp.FLessThanEqual } - | FPLUS { BinOp.FPlus } - | FMINUS { BinOp.FMinus } - | FTIMES { BinOp.FTimes } - | FDIV { BinOp.FDiv } - | FMOD { BinOp.FMod } - | SLT { BinOp.SLessThan } - | AND { BinOp.BAnd } - | OR { BinOp.BOr } - | LIMPLIES { BinOp.BImpl } - | BITWISEAND { BinOp.BitwiseAnd } - | BITWISEOR { BinOp.BitwiseOr} - | BITWISEXOR { BinOp.BitwiseXor } - | LEFTSHIFT { BinOp.LeftShift } - | SIGNEDRIGHTSHIFT { BinOp.SignedRightShift } - | UNSIGNEDRIGHTSHIFT { BinOp.UnsignedRightShift } - | BITWISEANDL { BinOp.BitwiseAndL } - | BITWISEORL { BinOp.BitwiseOrL } - | BITWISEXORL { BinOp.BitwiseXorL } - | LEFTSHIFTL { BinOp.LeftShiftL } - | SIGNEDRIGHTSHIFTL { BinOp.SignedRightShiftL } - | UNSIGNEDRIGHTSHIFTL { BinOp.UnsignedRightShiftL } - | M_ATAN2 { BinOp.M_atan2 } - | M_POW { BinOp.M_pow } - | STRCAT { BinOp.StrCat } - | SETDIFF { BinOp.SetDiff } - | SETMEM { BinOp.BSetMem } - | SETSUB { BinOp.BSetSub } -; - unop_target: (* Unary minus defined in (l)expr_target *) - | NOT { UnOp.UNot } + | LNOT + | NOT { UnOp.Not } | BITWISENOT { UnOp.BitwiseNot } | M_ISNAN { UnOp.M_isNaN } | M_ABS { UnOp.M_abs } @@ -1193,8 +1198,9 @@ unop_target: | LSTREV { UnOp.LstRev } | STRLEN { UnOp.StrLen } | SETTOLIST { UnOp.SetToList } - | INTTONUM { UnOp.IntToNum } - | NUMTOINT { UnOp.NumToInt } + | INTTONUM { UnOp.IntToNum } + | NUMTOINT { UnOp.NumToInt } + | ISINT { UnOp.IsInt } ; constant_target: diff --git a/GillianCore/monadic/FOSolver.ml b/GillianCore/monadic/FOSolver.ml index 9e8c10c1..97a8e621 100644 --- a/GillianCore/monadic/FOSolver.ml +++ b/GillianCore/monadic/FOSolver.ml @@ -2,15 +2,15 @@ module FOSolver = Engine.FOSolver module PFS = Engine.PFS module Type_env = Engine.Type_env module Reduction = Engine.Reduction -module Formula = Gil_syntax.Formula +module Expr = Gil_syntax.Expr module Typing = Engine.Typing (** FIXME: optimization? *) let build_full_pfs (pc : Pc.t) = - if Formula.Set.is_empty pc.learned then pc.pfs + if Expr.Set.is_empty pc.learned then pc.pfs else let copied = PFS.copy pc.pfs in - Formula.Set.iter (PFS.extend copied) pc.learned; + Expr.Set.iter (PFS.extend copied) pc.learned; copied let build_full_gamma (pc : Pc.t) = @@ -22,7 +22,7 @@ let build_full_gamma (pc : Pc.t) = let sat ~(pc : Pc.t) formula = Logging.tmi (fun m -> - m "Monadic about to check sat of this new formula:@[%a@]" Formula.pp + m "Monadic about to check sat of this new formula:@[%a@]" Expr.pp formula); let pfs, gamma = (build_full_pfs pc, build_full_gamma pc) in @@ -33,11 +33,10 @@ let check_entailment ~(pc : Pc.t) formula = let pfs, gamma = (build_full_pfs pc, build_full_gamma pc) in try let f = - Engine.Reduction.reduce_formula ~matching:pc.matching ~gamma ~pfs formula + Engine.Reduction.reduce_lexpr ~matching:pc.matching ~gamma ~pfs formula in match f with - | True -> true - | False -> false + | Lit (Bool b) -> b | _ -> FOSolver.check_entailment ~matching:pc.matching Utils.Containers.SS.empty pfs [ f ] gamma @@ -46,7 +45,7 @@ let check_entailment ~(pc : Pc.t) formula = m "check_entailment: couldn't check due to an error reducing %a - %s\n\ Formula:%a" - Gil_syntax.Expr.pp e msg Formula.pp formula); + Gil_syntax.Expr.pp e msg Expr.pp formula); false let of_comp_fun comp ~(pc : Pc.t) e1 e2 = @@ -64,10 +63,6 @@ let reduce_expr ~pc expr = Reduction.reduce_lexpr ~matching:pc.Pc.matching ~pfs:(build_full_pfs pc) ~gamma:(build_full_gamma pc) expr -let reduce_formula ~pc formula = - Reduction.reduce_formula ~matching:pc.Pc.matching ~pfs:(build_full_pfs pc) - ~gamma:(build_full_gamma pc) formula - let resolve_type ~(pc : Pc.t) expr = (* TODO: I don't know what that how parameter means. I'm copying what Reduction does. diff --git a/GillianCore/monadic/MonadicSMemory.ml b/GillianCore/monadic/MonadicSMemory.ml index c53d1376..df4fdb96 100644 --- a/GillianCore/monadic/MonadicSMemory.ml +++ b/GillianCore/monadic/MonadicSMemory.ml @@ -42,12 +42,12 @@ module type S = sig val clean_up : ?keep:Expr.Set.t -> t -> Expr.Set.t * Expr.Set.t val lvars : t -> Containers.SS.t val alocs : t -> Containers.SS.t - val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t list - val mem_constraints : t -> Formula.t list + val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t + val mem_constraints : t -> Expr.t list val get_recovery_tactic : t -> err_t -> vt Recovery_tactic.t val pp_err : Format.formatter -> err_t -> unit - val get_failing_constraint : err_t -> Formula.t - val get_fixes : err_t -> Asrt.t list list + val get_failing_constraint : err_t -> Expr.t + val get_fixes : err_t -> Asrt.t list val can_fix : err_t -> bool val pp_by_need : Containers.SS.t -> Format.formatter -> t -> unit val get_print_info : Containers.SS.t -> t -> Containers.SS.t * Containers.SS.t @@ -67,7 +67,7 @@ module Lift (MSM : S) : include MSM let assertions ?to_keep t = - List.map Engine.Reduction.reduce_assertion (assertions ?to_keep t) + Engine.Reduction.reduce_assertion (assertions ?to_keep t) let execute_action action_name mem gpc params = let open Syntaxes.List in @@ -94,7 +94,7 @@ module Lift (MSM : S) : Gbranch.{ pc = gpc; value } let substitution_in_place ~pfs ~gamma subst mem : - (t * Formula.Set.t * (string * Type.t) list) list = + (t * Expr.Set.t * (string * Type.t) list) list = let process = substitution_in_place subst mem in let curr_pc = Pc.make ~matching:false ~pfs ~gamma () in match Delayed.resolve ~curr_pc process with diff --git a/GillianCore/monadic/branch.mli b/GillianCore/monadic/branch.mli index 8c3d20b3..11b106b5 100644 --- a/GillianCore/monadic/branch.mli +++ b/GillianCore/monadic/branch.mli @@ -3,6 +3,6 @@ type 'a t = { pc : Pc.t; value : 'a } val make : pc:Pc.t -> value:'a -> 'a t val value : 'a t -> 'a val pc : 'a t -> Pc.t -val learned : 'a t -> Gil_syntax.Formula.Set.t +val learned : 'a t -> Gil_syntax.Expr.Set.t val learned_types : 'a t -> (string * Gil_syntax.Type.t) list val pp : 'a Fmt.t -> 'a t Fmt.t diff --git a/GillianCore/monadic/delayed.ml b/GillianCore/monadic/delayed.ml index 2f7c929a..deae9e9a 100644 --- a/GillianCore/monadic/delayed.ml +++ b/GillianCore/monadic/delayed.ml @@ -1,14 +1,13 @@ -module Formula = Gil_syntax.Formula module Expr = Gil_syntax.Expr module Type = Gil_syntax.Type -exception NonExhaustiveEntailment of Formula.t list +exception NonExhaustiveEntailment of Expr.t list let () = Printexc.register_printer (function | NonExhaustiveEntailment fs -> let s = - Fmt.str "NonExhaustiveEntailment(%a)" (Fmt.Dump.list Formula.pp) fs + Fmt.str "NonExhaustiveEntailment(%a)" (Fmt.Dump.list Expr.pp) fs in Some s | _ -> None) @@ -34,13 +33,13 @@ let branches (x : 'a t list) : 'a t = fun ~curr_pc -> List.concat_map (fun (b : 'a t) -> b ~curr_pc) x let branch_on - (guard : Formula.t) + (guard : Expr.t) ~(then_ : unit -> 'a t) ~(else_ : unit -> 'a t) ~curr_pc = match guard with - | True -> then_ () ~curr_pc - | False -> else_ () ~curr_pc + | Lit (Bool true) -> then_ () ~curr_pc + | Lit (Bool false) -> else_ () ~curr_pc | guard -> ( try let guard_sat = FOSolver.sat ~pc:curr_pc guard in @@ -48,7 +47,7 @@ let branch_on else_ () ~curr_pc else let then_branches = then_ () ~curr_pc:(Pc.extend curr_pc [ guard ]) in - let not_guard = Formula.Infix.fnot guard in + let not_guard = Expr.Infix.not guard in if FOSolver.sat ~pc:curr_pc not_guard then let else_branches = else_ () ~curr_pc:(Pc.extend curr_pc [ not_guard ]) @@ -56,44 +55,36 @@ let branch_on then_branches @ else_branches else then_branches with Smt.SMT_unknown -> - Fmt.pr "TIMED OUT ON: %a" Formula.pp guard; + Fmt.pr "TIMED OUT ON: %a" Expr.pp guard; vanish () ~curr_pc) let if_sure - (guard : Formula.t) + (guard : Expr.t) ~(then_ : unit -> 'a t) ~(else_ : unit -> 'a t) ~curr_pc = match guard with - | True -> then_ () ~curr_pc - | False -> else_ () ~curr_pc + | Lit (Bool true) -> then_ () ~curr_pc + | Lit (Bool false) -> else_ () ~curr_pc | guard -> if FOSolver.check_entailment ~pc:curr_pc guard then let extended_pc = Pc.extend curr_pc [ guard ] in then_ () ~curr_pc:extended_pc else else_ () ~curr_pc -let branch_entailment (branches : (Formula.t * (unit -> 'a t)) list) ~curr_pc = - let rec loop l = - match l with +let branch_entailment (branches : (Expr.t * (unit -> 'a t)) list) ~curr_pc = + let rec loop = function | [] -> raise (NonExhaustiveEntailment (List.map fst branches)) - | (guard, thunk) :: r -> ( - match guard with - | Formula.True -> thunk () ~curr_pc - | False -> loop r - | _ -> - if FOSolver.check_entailment ~pc:curr_pc guard then - thunk () ~curr_pc - else loop r) + | (Expr.Lit (Bool true), thunk) :: _ -> thunk () ~curr_pc + | (Expr.Lit (Bool false), _) :: r -> loop r + | (guard, thunk) :: r -> + if FOSolver.check_entailment ~pc:curr_pc guard then thunk () ~curr_pc + else loop r in loop branches let map x f ~curr_pc = - List.map - (fun b -> - let open Branch in - { b with value = f b.value }) - (x ~curr_pc) + List.map (fun b -> Branch.{ b with value = f b.value }) (x ~curr_pc) let delayed_eval f x ~curr_pc = [ Branch.make ~pc:curr_pc ~value:(f ~pc:curr_pc x) ] @@ -102,7 +93,6 @@ let delayed_eval2 f x y ~curr_pc = [ Branch.make ~pc:curr_pc ~value:(f ~pc:curr_pc x y) ] let reduce = delayed_eval FOSolver.reduce_expr -let reduce_formula = delayed_eval FOSolver.reduce_formula let resolve_loc = delayed_eval FOSolver.resolve_loc_name let entails = diff --git a/GillianCore/monadic/delayed.mli b/GillianCore/monadic/delayed.mli index 014660ce..dc0413bf 100644 --- a/GillianCore/monadic/delayed.mli +++ b/GillianCore/monadic/delayed.mli @@ -5,24 +5,21 @@ type 'a t val resolve : curr_pc:Pc.t -> 'a t -> 'a Branch.t list val return : - ?learned:Formula.t list -> ?learned_types:(string * Type.t) list -> 'a -> 'a t + ?learned:Expr.t list -> ?learned_types:(string * Type.t) list -> 'a -> 'a t val resolve_loc : Expr.t -> string option t val reduce : Expr.t -> Expr.t t -val reduce_formula : Formula.t -> Formula.t t -val entails : Formula.t list -> Formula.t -> bool t -val check_sat : Formula.t -> bool t +val entails : Expr.t list -> Expr.t -> bool t +val check_sat : Expr.t -> bool t val bind : 'a t -> ('a -> 'b t) -> 'b t val map : 'a t -> ('a -> 'b) -> 'b t val branches : 'a t list -> 'a t val all : 'a t list -> 'a list t val vanish : unit -> 'a t -val if_sure : Formula.t -> then_:(unit -> 'a t) -> else_:(unit -> 'a t) -> 'a t -val branch_entailment : (Formula.t * (unit -> 'a t)) list -> 'a t +val if_sure : Expr.t -> then_:(unit -> 'a t) -> else_:(unit -> 'a t) -> 'a t +val branch_entailment : (Expr.t * (unit -> 'a t)) list -> 'a t val leak_pc_copy : unit -> Engine.Gpc.t t - -val branch_on : - Formula.t -> then_:(unit -> 'a t) -> else_:(unit -> 'a t) -> 'a t +val branch_on : Expr.t -> then_:(unit -> 'a t) -> else_:(unit -> 'a t) -> 'a t module Syntax : sig val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t diff --git a/GillianCore/monadic/pc.ml b/GillianCore/monadic/pc.ml index 449ad0a8..d4172947 100644 --- a/GillianCore/monadic/pc.ml +++ b/GillianCore/monadic/pc.ml @@ -6,7 +6,7 @@ module FOSolver = Engine.FOSolver type t = { pfs : Pure_context.t; gamma : Type_env.t; - learned : Formula.Set.t; + learned : Expr.Set.t; learned_types : (string * Type.t) list; matching : bool; } @@ -21,7 +21,7 @@ let copy { pfs; gamma; learned; learned_types; matching } = } let make ~pfs ~gamma ~matching ?(learned = []) ?(learned_types = []) () = - { pfs; gamma; learned = Formula.Set.of_list learned; learned_types; matching } + { pfs; gamma; learned = Expr.Set.of_list learned; learned_types; matching } let init ?(matching = false) () = make ~pfs:(Pure_context.init ()) ~gamma:(Type_env.init ()) ~matching () @@ -36,12 +36,12 @@ let pfs_to_pfs_and_gamma pfs = in let rec aux = function | [] -> ([], []) - | Formula.Eq (UnOp (TypeOf, e), Lit (Type t)) :: r - | Eq (Lit (Type t), UnOp (TypeOf, e)) :: r -> ( + | Expr.BinOp (UnOp (TypeOf, e), Equal, Lit (Type t)) :: r + | BinOp (Lit (Type t), Equal, UnOp (TypeOf, e)) :: r -> ( let other_pfs, other_gamma = aux r in match expr_type_binding_to_gamma (e, t) with | None -> - ( Formula.Eq (Lit (Type t), UnOp (TypeOf, e)) :: other_pfs, + ( Expr.BinOp (Lit (Type t), Equal, UnOp (TypeOf, e)) :: other_pfs, other_gamma ) | Some gamma -> (other_pfs, gamma :: other_gamma)) | f :: r -> @@ -51,22 +51,28 @@ let pfs_to_pfs_and_gamma pfs = aux pfs let extend pc fs = - let fs = List.concat_map Formula.split_conjunct_formulae fs in + let rec split_conjunct : Expr.t -> Expr.t list = function + | BinOp (f1, And, f2) -> split_conjunct f1 @ split_conjunct f2 + | UnOp (Not, BinOp (f1, Or, f2)) -> + split_conjunct (BinOp (UnOp (Not, f1), And, UnOp (Not, f2))) + | f -> [ f ] + in + let fs = List.concat_map split_conjunct fs in let pfs, gamma = (pc.pfs, pc.gamma) in let fs = List.filter_map (fun f -> match - Engine.Reduction.reduce_formula ~matching:pc.matching ~pfs ~gamma f + Engine.Reduction.reduce_lexpr ~matching:pc.matching ~pfs ~gamma f with - | Formula.True -> None + | Expr.Lit (Bool true) -> None | f -> Some f) fs in let new_pfs, new_gamma = pfs_to_pfs_and_gamma fs in { pc with - learned = Formula.Set.add_seq (List.to_seq new_pfs) pc.learned; + learned = Expr.Set.add_seq (List.to_seq new_pfs) pc.learned; learned_types = new_gamma @ pc.learned_types; } @@ -74,10 +80,9 @@ let extend_types pc types = { pc with learned_types = types @ pc.learned_types } let equal pca pcb = pca.pfs = pcb.pfs && pca.gamma = pcb.gamma - && Formula.Set.equal pca.learned pcb.learned + && Expr.Set.equal pca.learned pcb.learned && List.for_all2 - (fun (n1, t1) (n2, t2) -> - String.equal n1 n2 && String.equal (Type.str t1) (Type.str t2)) + (fun (n1, t1) (n2, t2) -> String.equal n1 n2 && Type.equal t1 t2) pca.learned_types pcb.learned_types let pp = @@ -87,11 +92,11 @@ let pp = Fmt.field "pfs" (fun x -> x.pfs) (fun fmt pfs -> - (Fmt.Dump.list Formula.pp) fmt (Pure_context.to_list pfs)); + (Fmt.Dump.list Expr.pp) fmt (Pure_context.to_list pfs)); Fmt.field "gamma" (fun x -> x.gamma) Type_env.pp; Fmt.field "learned" - (fun x -> Formula.Set.to_seq x.learned) - (Fmt.Dump.seq Formula.pp); + (fun x -> Expr.Set.to_seq x.learned) + (Fmt.Dump.seq Expr.pp); Fmt.field "learned_types" (fun x -> x.learned_types) (Fmt.Dump.list @@ -99,8 +104,7 @@ let pp = ]) let diff pca pcb = - ( Formula.Set.diff pca.learned pcb.learned, - Formula.Set.diff pcb.learned pca.learned ) + (Expr.Set.diff pca.learned pcb.learned, Expr.Set.diff pcb.learned pca.learned) let of_gpc (gpc : Engine.Gpc.t) = let Engine.Gpc.{ pfs; gamma; matching } = gpc in @@ -110,6 +114,6 @@ let to_gpc (pc : t) = let { pfs; gamma; matching; learned; learned_types } = pc in let pfs = Pure_context.copy pfs in let gamma = Type_env.copy gamma in - Formula.Set.iter (Pure_context.extend pfs) learned; + Expr.Set.iter (Pure_context.extend pfs) learned; List.iter (fun (x, y) -> Type_env.update gamma x y) learned_types; Engine.Gpc.{ pfs; gamma; matching } diff --git a/GillianCore/smt/smt.ml b/GillianCore/smt/smt.ml index 1e0666c9..eb38bbd2 100644 --- a/GillianCore/smt/smt.ml +++ b/GillianCore/smt/smt.ml @@ -37,10 +37,10 @@ type typenv = (string, Type.t) Hashtbl.t let pp_typenv = Fmt.(Dump.hashtbl string (Fmt.of_to_string Type.str)) -let encoding_cache : (Formula.Set.t, sexp list) Hashtbl.t = +let encoding_cache : (Expr.Set.t, sexp list) Hashtbl.t = Hashtbl.create Config.big_tbl_size -let sat_cache : (Formula.Set.t, sexp option) Hashtbl.t = +let sat_cache : (Expr.Set.t, sexp option) Hashtbl.t = Hashtbl.create Config.big_tbl_size let ( <| ) constr e = app constr [ e ] @@ -564,14 +564,14 @@ let encode_binop (op : BinOp.t) (p1 : Encoding.t) (p2 : Encoding.t) : Encoding.t | FLessThan -> num_lt (get_num p1) (get_num p2) >- BooleanType | FLessThanEqual -> num_leq (get_num p1) (get_num p2) >- BooleanType | Equal -> encode_equality p1 p2 - | BOr -> bool_or (get_bool p1) (get_bool p2) >- BooleanType - | BImpl -> bool_implies (get_bool p1) (get_bool p2) >- BooleanType - | BAnd -> bool_and (get_bool p1) (get_bool p2) >- BooleanType - | BSetMem -> + | Or -> bool_or (get_bool p1) (get_bool p2) >- BooleanType + | Impl -> bool_implies (get_bool p1) (get_bool p2) >- BooleanType + | And -> bool_and (get_bool p1) (get_bool p2) >- BooleanType + | SetMem -> (* p2 has to be already wrapped *) set_member Z3 (simple_wrap p1) (get_set p2) >- BooleanType | SetDiff -> set_difference Z3 (get_set p1) (get_set p2) >- SetType - | BSetSub -> set_subset Z3 (get_set p1) (get_set p2) >- BooleanType + | SetSub -> set_subset Z3 (get_set p1) (get_set p2) >- BooleanType | LstNth -> seq_nth (get_list p1) (get_int p2) |> simply_wrapped | LstRepeat -> let x = simple_wrap p1 in @@ -583,7 +583,7 @@ let encode_binop (op : BinOp.t) (p1 : Encoding.t) (p2 : Encoding.t) : Encoding.t let res = Axiomatised_operations.snth $$ [ str'; index' ] in res >- StringType | FMod - | SLessThan + | StrLess | BitwiseAnd | BitwiseOr | BitwiseXor @@ -627,7 +627,7 @@ let encode_unop ~llen_lvars ~e (op : UnOp.t) le = | ToStringOp -> Axiomatised_operations.num2str <| get_num le >- StringType | ToNumberOp -> Axiomatised_operations.str2num <| get_string le >- NumberType | ToIntOp -> Axiomatised_operations.num2int <| get_num le >- NumberType - | UNot -> bool_not (get_bool le) >- BooleanType + | Not -> bool_not (get_bool le) >- BooleanType | Cdr -> let list = get_list le in seq_extract list (int_k 1) (seq_len list) >- ListType @@ -637,6 +637,7 @@ let encode_unop ~llen_lvars ~e (op : UnOp.t) le = | LstRev -> Axiomatised_operations.lrev <| get_list le >- ListType | NumToInt -> get_num le |> real_to_int >- IntType | IntToNum -> get_int le |> int_to_real >- NumberType + | IsInt -> num_divisible (get_num le) 1 >- BooleanType | BitwiseNot | M_isNaN | M_abs @@ -769,87 +770,28 @@ let rec encode_logical_expression | Exists (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression ~mk_quant:exists ~gamma ~llen_lvars ~list_elem_vars bt e - | EForall (bt, e) -> + | ForAll (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression ~mk_quant:forall ~gamma ~llen_lvars ~list_elem_vars bt e -and encode_assertion - ~(gamma : typenv) - ~(llen_lvars : SS.t) - ~(list_elem_vars : SS.t) - (a : Formula.t) : Encoding.t = - let f = encode_assertion ~gamma ~llen_lvars ~list_elem_vars in - let fe = encode_logical_expression ~gamma ~llen_lvars ~list_elem_vars in - let open Encoding in - match a with - | Not a -> - let>- a = f a in - get_bool a |> bool_not >- BooleanType - | Eq (le1, le2) -> encode_equality (fe le1) (fe le2) - | FLess (le1, le2) -> - let>- le1 = fe le1 in - let>- le2 = fe le2 in - num_lt (get_num le1) (get_num le2) >- BooleanType - | FLessEq (le1, le2) -> - let>- le1 = fe le1 in - let>- le2 = fe le2 in - num_leq (get_num le1) (get_num le2) >- BooleanType - | ILess (le1, le2) -> - let>- le1 = fe le1 in - let>- le2 = fe le2 in - num_lt (get_int le1) (get_int le2) >- BooleanType - | ILessEq (le1, le2) -> - let>- le1 = fe le1 in - let>- le2 = fe le2 in - num_leq (get_int le1) (get_int le2) >- BooleanType - | Impl (a1, a2) -> - let>- a1 = f a1 in - let>- a2 = f a2 in - bool_implies (get_bool a1) (get_bool a2) >- BooleanType - | StrLess (_, _) -> failwith "SMT encoding does not support STRLESS" - | True -> bool_k true >- BooleanType - | False -> bool_k false >- BooleanType - | Or (a1, a2) -> - let>- a1 = f a1 in - let>- a2 = f a2 in - bool_or (get_bool a1) (get_bool a2) >- BooleanType - | And (a1, a2) -> - let>- a1 = f a1 in - let>- a2 = f a2 in - bool_and (get_bool a1) (get_bool a2) >- BooleanType - | SetMem (le1, le2) -> - let>- le1 = fe le1 in - let>- le2 = fe le2 in - set_member Z3 (simple_wrap le1) (get_set le2) >- BooleanType - | SetSub (le1, le2) -> - let>- le1 = fe le1 in - let>- le2 = fe le2 in - set_subset Z3 (get_set le1) (get_set le2) >- BooleanType - | ForAll (bt, a) -> - encode_quantified_expr ~encode_expr:encode_assertion ~mk_quant:forall - ~gamma ~llen_lvars ~list_elem_vars bt a - | IsInt e -> - let>- e = fe e in - num_divisible (get_num e) 1 >- BooleanType - let encode_assertion_top_level ~(gamma : typenv) ~(llen_lvars : SS.t) ~(list_elem_vars : SS.t) - (a : Formula.t) : Encoding.t = + (a : Expr.t) : Encoding.t = try - encode_assertion ~gamma ~llen_lvars ~list_elem_vars - (Formula.push_in_negations a) + encode_logical_expression ~gamma ~llen_lvars ~list_elem_vars + (Expr.push_in_negations a) with e -> let s = Printexc.to_string e in let msg = - Fmt.str "Failed to encode %a in gamma %a with error %s\n" Formula.pp a + Fmt.str "Failed to encode %a in gamma %a with error %s\n" Expr.pp a pp_typenv gamma s in let () = L.print_to_all msg in raise e -let lvars_only_in_llen (fs : Formula.Set.t) : SS.t = +let lvars_only_in_llen (fs : Expr.Set.t) : SS.t = let inspector = object inherit [_] Visitors.iter as super @@ -864,10 +806,10 @@ let lvars_only_in_llen (fs : Formula.Set.t) : SS.t = | _ -> super#visit_expr () e end in - fs |> Formula.Set.iter (inspector#visit_formula ()); + fs |> Expr.Set.iter (inspector#visit_expr ()); inspector#get_diff -let lvars_as_list_elements (assertions : Formula.Set.t) : SS.t = +let lvars_as_list_elements (assertions : Expr.Set.t) : SS.t = let collector = object (self) inherit [_] Visitors.reduce @@ -877,7 +819,7 @@ let lvars_as_list_elements (assertions : Formula.Set.t) : SS.t = (* Quantified variables need to be excluded *) let univ_quant = List.to_seq binders |> Seq.map fst in let exclude = Containers.SS.add_seq univ_quant exclude in - self#visit_formula (exclude, is_in_list) f + self#visit_expr (exclude, is_in_list) f method! visit_Exists (exclude, is_in_list) binders e = let exist_quants = List.to_seq binders |> Seq.map fst in @@ -906,19 +848,19 @@ let lvars_as_list_elements (assertions : Formula.Set.t) : SS.t = method! visit_'annot _ () = self#zero end in - Formula.Set.fold + Expr.Set.fold (fun f acc -> - let new_lvars = collector#visit_formula (SS.empty, false) f in + let new_lvars = collector#visit_expr (SS.empty, false) f in SS.union new_lvars acc) assertions SS.empty -let encode_assertions (fs : Formula.Set.t) (gamma : typenv) : sexp list = +let encode_assertions (fs : Expr.Set.t) (gamma : typenv) : sexp list = let open Encoding in let- () = Hashtbl.find_opt encoding_cache fs in let llen_lvars = lvars_only_in_llen fs in let list_elem_vars = lvars_as_list_elements fs in let encoded = - Formula.Set.elements fs + Expr.Set.elements fs |> List.map (encode_assertion_top_level ~gamma ~llen_lvars ~list_elem_vars) in let consts = @@ -969,7 +911,7 @@ module Dump = struct Fmt.pf (Format.formatter_of_out_channel c) "GIL query:\nFS: %a\nGAMMA: %a\nEncoded as SMT Query:\n%a@?" - (Fmt.iter ~sep:Fmt.comma Formula.Set.iter Formula.pp) + (Fmt.iter ~sep:Fmt.comma Expr.Set.iter Expr.pp) fs pp_typenv gamma (Fmt.list ~sep:(Fmt.any "\n") Sexplib.Sexp.pp_hum) cmds) @@ -981,11 +923,11 @@ let reset_solver () = let () = cmd (push 1) in () -let exec_sat' (fs : Formula.Set.t) (gamma : typenv) : sexp option = +let exec_sat' (fs : Expr.Set.t) (gamma : typenv) : sexp option = let () = L.verbose (fun m -> m "@[About to check SAT of:@\n%a@]@\nwith gamma:@\n@[%a@]\n" - (Fmt.iter ~sep:(Fmt.any "@\n") Formula.Set.iter Formula.pp) + (Fmt.iter ~sep:(Fmt.any "@\n") Expr.Set.iter Expr.pp) fs pp_typenv gamma) in let () = reset_solver () in @@ -1017,7 +959,7 @@ let exec_sat' (fs : Formula.Set.t) (gamma : typenv) : sexp option = Solver:\n\ %a\n\ @?" - (Fmt.iter ~sep:(Fmt.any ", ") Formula.Set.iter Formula.pp) + (Fmt.iter ~sep:(Fmt.any ", ") Expr.Set.iter Expr.pp) fs pp_typenv gamma (Fmt.list ~sep:(Fmt.any "\n\n") Sexplib.Sexp.pp_hum) encoded_assertions @@ -1029,14 +971,19 @@ let exec_sat' (fs : Formula.Set.t) (gamma : typenv) : sexp option = in ret -let exec_sat (fs : Formula.Set.t) (gamma : typenv) : sexp option = +let exec_sat (fs : Expr.Set.t) (gamma : typenv) : sexp option = try exec_sat' fs gamma with UnexpectedSolverResponse _ as e -> - let msg = Fmt.str "SMT failure!\n%s\n" (Printexc.to_string e ^ "\n") in + let msg = + Fmt.str "SMT failure!@\n%s@\nExpressions: @\n%a" + (Printexc.to_string e ^ "\n") + Fmt.(list ~sep:(Fmt.any "@\n") Expr.pp) + (Expr.Set.elements fs) + in let () = L.print_to_all msg in exit 1 -let check_sat (fs : Formula.Set.t) (gamma : typenv) : sexp option = +let check_sat (fs : Expr.Set.t) (gamma : typenv) : sexp option = match Hashtbl.find_opt sat_cache fs with | Some result -> let () = @@ -1049,13 +996,13 @@ let check_sat (fs : Formula.Set.t) (gamma : typenv) : sexp option = let ret = exec_sat fs gamma in let () = L.verbose (fun m -> - let f = Formula.conjunct (Formula.Set.elements fs) in - m "Adding to cache : @[%a@]" Formula.pp f) + let f = Expr.conjunct (Expr.Set.elements fs) in + m "Adding to cache : @[%a@]" Expr.pp f) in let () = Hashtbl.replace sat_cache fs ret in ret -let is_sat (fs : Formula.Set.t) (gamma : typenv) : bool = +let is_sat (fs : Expr.Set.t) (gamma : typenv) : bool = check_sat fs gamma |> Option.is_some let lift_model @@ -1122,5 +1069,5 @@ let lift_model let () = let decls = List.rev !init_decls in - let () = decls |> List.iter (fun decl -> cmd decl) in + let () = decls |> List.iter cmd in cmd (push 1) diff --git a/GillianCore/smt/smt.mli b/GillianCore/smt/smt.mli index e36aa397..18cebade 100644 --- a/GillianCore/smt/smt.mli +++ b/GillianCore/smt/smt.mli @@ -2,13 +2,11 @@ open Gil_syntax exception SMT_unknown -val exec_sat : - Formula.Set.t -> (string, Type.t) Hashtbl.t -> Sexplib.Sexp.t option - -val is_sat : Formula.Set.t -> (string, Type.t) Hashtbl.t -> bool +val exec_sat : Expr.Set.t -> (string, Type.t) Hashtbl.t -> Sexplib.Sexp.t option +val is_sat : Expr.Set.t -> (string, Type.t) Hashtbl.t -> bool val check_sat : - Formula.Set.t -> (string, Type.t) Hashtbl.t -> Sexplib.Sexp.t option + Expr.Set.t -> (string, Type.t) Hashtbl.t -> Sexplib.Sexp.t option val lift_model : Sexplib.Sexp.t -> diff --git a/ppx_sat/runtime/ppx_sat_runtime.ml b/ppx_sat/runtime/ppx_sat_runtime.ml index 52c40f87..2e8d2090 100644 --- a/ppx_sat/runtime/ppx_sat_runtime.ml +++ b/ppx_sat/runtime/ppx_sat_runtime.ml @@ -7,4 +7,4 @@ let if_sure_then_else guard ~then_branch ~else_branch = Delayed.if_sure guard ~then_:then_branch ~else_:else_branch let branch_entailment = Delayed.branch_entailment -let true_formula = Gil_syntax.Formula.True +let true_formula = Gil_syntax.Expr.true_ diff --git a/ppx_sat/runtime/ppx_sat_runtime.mli b/ppx_sat/runtime/ppx_sat_runtime.mli index 8163b05e..3b0eaaea 100644 --- a/ppx_sat/runtime/ppx_sat_runtime.mli +++ b/ppx_sat/runtime/ppx_sat_runtime.mli @@ -2,10 +2,10 @@ open Monadic.Delayed open Gil_syntax val if_then_else : - Formula.t -> then_branch:(unit -> 'a t) -> else_branch:(unit -> 'a t) -> 'a t + Expr.t -> then_branch:(unit -> 'a t) -> else_branch:(unit -> 'a t) -> 'a t val if_sure_then_else : - Formula.t -> then_branch:(unit -> 'a t) -> else_branch:(unit -> 'a t) -> 'a t + Expr.t -> then_branch:(unit -> 'a t) -> else_branch:(unit -> 'a t) -> 'a t -val branch_entailment : (Formula.t * (unit -> 'a t)) list -> 'a t -val true_formula : Gil_syntax.Formula.t +val branch_entailment : (Expr.t * (unit -> 'a t)) list -> 'a t +val true_formula : Expr.t diff --git a/ppx_sat/test/out.expected b/ppx_sat/test/out.expected index b77944da..d72d5ea5 100644 --- a/ppx_sat/test/out.expected +++ b/ppx_sat/test/out.expected @@ -1,13 +1,13 @@ [{pc: {pfs: [(! (x == 1i))]; gamma: (x: Int); - learned: [(1i i<=# x); (2i i<=# x)]; + learned: [(1i i<= x); (2i i<= x)]; learned_types: []}; value: 12}, {pc: {pfs: [(! (x == 1i))]; gamma: (x: Int); - learned: [(x i<# 1i); (x i<=# 0i)]; + learned: [(x i< 1i); (x i<= 0i)]; learned_types: []}; value: -1}] diff --git a/ppx_sat/test/test.ml b/ppx_sat/test/test.ml index d1ff49f3..3fa9381d 100644 --- a/ppx_sat/test/test.ml +++ b/ppx_sat/test/test.ml @@ -1,13 +1,16 @@ open Gillian open Gil_syntax open Monadic.Delayed -open Formula.Infix + +let add = ( + ) + +open Expr.Infix open Monadic.Delayed.Syntax let zero = Expr.int 0 let one = Expr.int 1 let two = Expr.int 2 -let int_pat n x = x #== (Expr.int n) +let int_pat n x = x == Expr.int n let zero_pat = int_pat 0 let one_pat = int_pat 1 let two_pat = int_pat 2 @@ -22,21 +25,21 @@ module type S = sig end module Test_if_sat = struct - let computation t = if%sat t #>= one then return 10 else return 0 + let computation t = if%sat t >= one then return 10 else return 0 let process x = let* z = computation x in let* y = - if%sat x #<= zero then return (-1) + if%sat x <= zero then return (-1) else - if%sat x #<= one then return 0 - else if%sat x #>= two then return 2 else return 1 + if%sat x <= one then return 0 + else if%sat x >= two then return 2 else return 1 in - return (z + y) + return (add z y) let starting_pc x = Monadic.Pc.make - ~pfs:(Engine.PFS.of_list [ Formula.Not x #== one ]) + ~pfs:(Engine.PFS.of_list [ not (x == one) ]) ~gamma:(Engine.Type_env.init ()) ~matching:false () let results = @@ -60,7 +63,7 @@ module Test_match_ent = struct let pc_with_two x = Monadic.Pc.make - ~pfs:(Engine.PFS.of_list [ x #== two ]) + ~pfs:(Engine.PFS.of_list [ x == two ]) ~gamma:(Engine.Type_env.init ()) ~matching:false () let results_no_info = diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index b7cc2a06..cb04c256 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -40,8 +40,8 @@ let compile_binop b = | TIMES -> BinOp.ITimes | DIV -> BinOp.IDiv | MOD -> BinOp.IMod - | AND -> BinOp.BAnd - | OR -> BinOp.BOr + | AND -> BinOp.And + | OR -> BinOp.Or | LSTNTH -> BinOp.LstNth (* operators that do not exist in gil are compiled separately *) | _ -> @@ -51,7 +51,7 @@ let compile_binop b = let compile_unop u = WUnOp.( match u with - | NOT -> UnOp.UNot + | NOT -> UnOp.Not | LEN -> UnOp.LstLen | HEAD -> UnOp.Car | TAIL -> UnOp.Cdr @@ -150,7 +150,7 @@ let rec compile_expr ?(fname = "main") ?(is_loop_prefix = false) expr : compiles a WLExpr into an output expression and a list of Global Assertions. the string list contains the name of the variables that are generated. They are existentials. *) let rec compile_lexpr ?(fname = "main") (lexpr : WLExpr.t) : - string list * Asrt.t list * Expr.t = + string list * Asrt.t * Expr.t = let gen_str = Generators.gen_str fname in let compile_lexpr = compile_lexpr ~fname in let expr_pname_of_binop b = @@ -183,7 +183,7 @@ let rec compile_lexpr ?(fname = "main") (lexpr : WLExpr.t) : let gvars1, asrtl1, comp_expr1 = compile_lexpr e1 in let gvars2, asrtl2, comp_expr2 = compile_lexpr e2 in let expr = - Expr.UnOp (UnOp.UNot, Expr.BinOp (comp_expr1, BinOp.Equal, comp_expr2)) + Expr.UnOp (UnOp.Not, Expr.BinOp (comp_expr1, BinOp.Equal, comp_expr2)) in (gvars1 @ gvars2, asrtl1 @ asrtl2, expr) | LBinOp (e1, b, e2) when is_internal_pred b -> @@ -237,57 +237,53 @@ let rec compile_lexpr ?(fname = "main") (lexpr : WLExpr.t) : (List.concat gvars, List.concat asrtsl, Expr.ESet comp_exprs)) (* TODO: compile_lformula should return also the list of created existentials *) -let rec compile_lformula ?(fname = "main") formula : Asrt.t list * Formula.t = +let rec compile_lformula ?(fname = "main") formula : Asrt.t * Expr.t = let gen_str = Generators.gen_str fname in let compile_lformula = compile_lformula ~fname in let compile_lexpr = compile_lexpr ~fname in WLFormula.( match get formula with - | LTrue -> ([], Formula.True) - | LFalse -> ([], Formula.False) + | LTrue -> ([], Expr.true_) + | LFalse -> ([], Expr.false_) | LNot lf -> let a1, c1 = compile_lformula lf in - (a1, Formula.Not c1) + (a1, UnOp (Not, c1)) | LAnd (lf1, lf2) -> let a1, c1 = compile_lformula lf1 in let a2, c2 = compile_lformula lf2 in - (a1 @ a2, Formula.And (c1, c2)) + (a1 @ a2, BinOp (c1, And, c2)) | LOr (lf1, lf2) -> let a1, c1 = compile_lformula lf1 in let a2, c2 = compile_lformula lf2 in - (a1 @ a2, Formula.Or (c1, c2)) + (a1 @ a2, BinOp (c1, Or, c2)) | LEq (le1, le2) -> let _, a1, c1 = compile_lexpr le1 in let _, a2, c2 = compile_lexpr le2 in - (a1 @ a2, Formula.Eq (c1, c2)) + (a1 @ a2, BinOp (c1, Equal, c2)) | LLess (le1, le2) -> let _, a1, c1 = compile_lexpr le1 in let _, a2, c2 = compile_lexpr le2 in let expr_l_var_out = Expr.LVar (gen_str sgvar) in let pred = Asrt.Pred (internal_pred_lt, [ c1; c2; expr_l_var_out ]) in - ( a1 @ a2 @ [ pred ], - Formula.Eq (expr_l_var_out, Expr.Lit (Literal.Bool true)) ) + (a1 @ a2 @ [ pred ], BinOp (expr_l_var_out, Equal, Expr.true_)) | LGreater (le1, le2) -> let _, a1, c1 = compile_lexpr le1 in let _, a2, c2 = compile_lexpr le2 in let expr_l_var_out = Expr.LVar (gen_str sgvar) in let pred = Asrt.Pred (internal_pred_gt, [ c1; c2; expr_l_var_out ]) in - ( a1 @ a2 @ [ pred ], - Formula.Eq (expr_l_var_out, Expr.Lit (Literal.Bool true)) ) + (a1 @ a2 @ [ pred ], BinOp (expr_l_var_out, Equal, Expr.true_)) | LLessEq (le1, le2) -> let _, a1, c1 = compile_lexpr le1 in let _, a2, c2 = compile_lexpr le2 in let expr_l_var_out = Expr.LVar (gen_str sgvar) in let pred = Asrt.Pred (internal_pred_leq, [ c1; c2; expr_l_var_out ]) in - ( a1 @ a2 @ [ pred ], - Formula.Eq (expr_l_var_out, Expr.Lit (Literal.Bool true)) ) + (a1 @ a2 @ [ pred ], BinOp (expr_l_var_out, Equal, Expr.true_)) | LGreaterEq (le1, le2) -> let _, a1, c1 = compile_lexpr le1 in let _, a2, c2 = compile_lexpr le2 in let expr_l_var_out = Expr.LVar (gen_str sgvar) in let pred = Asrt.Pred (internal_pred_geq, [ c1; c2; expr_l_var_out ]) in - ( a1 @ a2 @ [ pred ], - Formula.Eq (expr_l_var_out, Expr.Lit (Literal.Bool true)) )) + (a1 @ a2 @ [ pred ], BinOp (expr_l_var_out, Equal, Expr.true_))) (* compile_lassert returns the compiled assertion + the list of generated existentials *) let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = @@ -295,7 +291,6 @@ let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = let gen_str = Generators.gen_str fname in let compile_lexpr = compile_lexpr ~fname in let compile_lformula = compile_lformula ~fname in - let concat_star = List.fold_left (fun a1 a2 -> Asrt.Star (a1, a2)) in let gil_add e k = (* builds GIL expression that is e + k *) let k_e = Expr.int k in @@ -341,7 +336,7 @@ let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = | Lit (Int _) -> [] | _ -> [ (expr_offset, Type.IntType) ]) :: Asrt.Pure - (Formula.Eq (e1, Expr.EList [ Expr.LVar loc; expr_offset ])) + (BinOp (e1, Equal, Expr.EList [ Expr.LVar loc; expr_offset ])) :: la1, (loc, offset), expr_offset ) @@ -362,9 +357,8 @@ let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = | [ le ] -> let exs2, la2, e2 = compile_lexpr le in ( exs1 @ exs2, - concat_star - (Asrt.GA (cell, [ eloc; eoffs ], [ e2 ])) - (bound @ la1 @ la2) ) + Asrt.CorePred (cell, [ eloc; eoffs ], [ e2 ]) :: (bound @ la1 @ la2) + ) | le :: r -> let exs2, la2, e2 = compile_lexpr le in let exs3, la3 = @@ -373,47 +367,42 @@ let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = le1 r ~curr:(curr + 1) in ( exs1 @ exs2 @ exs3, - concat_star - (Asrt.GA (cell, [ eloc; eoffs ], [ e2 ])) - (bound @ (la3 :: (la1 @ la2))) ) + Asrt.CorePred (cell, [ eloc; eoffs ], [ e2 ]) + :: (bound @ la1 @ la2 @ la3) ) in WLAssert.( match get asser with - | LEmp -> ([], Asrt.Emp) + | LEmp -> ([], []) | LStar (la1, la2) -> let exs1, cla1 = compile_lassert la1 in let exs2, cla2 = compile_lassert la2 in - (exs1 @ exs2, Asrt.Star (cla1, cla2)) + (exs1 @ exs2, cla1 @ cla2) | LPointsTo (le1, lle) -> compile_pointsto ~block:false le1 lle | LBlockPointsTo (le1, lle) -> compile_pointsto ~block:true le1 lle | LPred (pr, lel) -> let exsl, all, el = list_split_3 (List.map compile_lexpr lel) in let exs = List.concat exsl in let al = List.concat all in - (exs, concat_star (Asrt.Pred (pr, el)) al) + (exs, Asrt.Pred (pr, el) :: al) | LWand { lhs = lname, largs; rhs = rname, rargs } -> let exs1, al1, el1 = list_split_3 (List.map compile_lexpr largs) in let exs2, al2, el2 = list_split_3 (List.map compile_lexpr rargs) in let exs = List.concat (exs1 @ exs2) in let al = List.concat (al1 @ al2) in - ( exs, - concat_star (Asrt.Wand { lhs = (lname, el1); rhs = (rname, el2) }) al - ) + (exs, Asrt.Wand { lhs = (lname, el1); rhs = (rname, el2) } :: al) | LPure lf -> let al, f = compile_lformula lf in - ([], concat_star (Asrt.Pure f) al)) + ([], Asrt.Pure f :: al)) let rec compile_lcmd ?(fname = "main") lcmd = let compile_lassert = compile_lassert ~fname in let compile_lcmd = compile_lcmd ~fname in let compile_lexpr = compile_lexpr ~fname in - let concat_star = List.fold_left (fun a1 a2 -> Asrt.Star (a1, a2)) in let build_assert existentials lasrts = match lasrts with | [] -> None - | a :: r -> - let to_assert = concat_star a r in - let cmd = LCmd.SL (SLCmd.SepAssert (to_assert, existentials)) in + | _ -> + let cmd = LCmd.SL (SLCmd.SepAssert (lasrts, existentials)) in (* assert (assertions) {existentials: gvars} *) Some cmd in @@ -898,10 +887,7 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in let cmdle, comp_e = compile_expr e in - let cmd = - let formula = Formula.Eq (comp_e, Expr.bool true) in - Cmd.Logic (LCmd.Assert formula) - in + let cmd = Cmd.Logic (Assert (BinOp (comp_e, Equal, Expr.true_))) in let comp_rest, new_functions = compile_list rest in (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_functions) | { snode = Assume e; sid; sloc } :: rest -> @@ -909,10 +895,7 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in let cmdle, comp_e = compile_expr e in - let cmd = - let formula = Formula.Eq (comp_e, Expr.bool true) in - Cmd.Logic (LCmd.Assume formula) - in + let cmd = Cmd.Logic (Assume (BinOp (comp_e, Equal, Expr.true_))) in let comp_rest, new_functions = compile_list rest in (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_functions) | { snode = AssumeType (e, t); sid; sloc } :: rest -> @@ -921,7 +904,7 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in let cmdle, comp_e = compile_expr e in - let cmd = Cmd.Logic (LCmd.AssumeType (comp_e, typ)) in + let cmd = Cmd.Logic (AssumeType (comp_e, typ)) in let comp_rest, new_functions = compile_list rest in (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_functions) @@ -1172,10 +1155,10 @@ let compile ~filepath WProg.{ context; predicates; lemmas } = (fun name proc -> let pre = List.map - (fun var -> Asrt.Pure (Eq (Expr.PVar var, Expr.LVar ("#" ^ var)))) + (fun var -> Asrt.Pure (BinOp (PVar var, Equal, LVar ("#" ^ var)))) proc.Proc.proc_params - |> Asrt.star in + let bispec = BiSpec. { diff --git a/wisl/lib/semantics/constr.ml b/wisl/lib/semantics/constr.ml index 76eb85db..317da920 100644 --- a/wisl/lib/semantics/constr.ml +++ b/wisl/lib/semantics/constr.ml @@ -3,13 +3,13 @@ open Gil_syntax let cell ~loc ~offset ~value = let cell = str_ga Cell in - Asrt.GA (cell, [ loc; offset ], [ value ]) + Asrt.CorePred (cell, [ loc; offset ], [ value ]) let bound ~loc ~bound = let bound_ga = str_ga Bound in let bound = Expr.int bound in - Asrt.GA (bound_ga, [ loc ], [ bound ]) + Asrt.CorePred (bound_ga, [ loc ], [ bound ]) let freed ~loc = let freed = str_ga Freed in - Asrt.GA (freed, [ loc ], []) + Asrt.CorePred (freed, [ loc ], []) diff --git a/wisl/lib/semantics/wislSHeap.ml b/wisl/lib/semantics/wislSHeap.ml index d8df4aff..5801c0e8 100644 --- a/wisl/lib/semantics/wislSHeap.ml +++ b/wisl/lib/semantics/wislSHeap.ml @@ -146,8 +146,8 @@ let get_cell ~pfs ~gamma heap loc ofs = | None -> false | Some n -> let n = Expr.int n in - let open Formula.Infix in - Solver.sat ~matching:false ~pfs ~gamma n #<= ofs + let open Expr.Infix in + Solver.sat ~matching:false ~pfs ~gamma (n <= ofs) in if maybe_out_of_bound then Error (OutOfBounds (bound, loc, ofs)) else @@ -176,8 +176,8 @@ let set_cell ~pfs ~gamma heap loc_name ofs v = | None -> false | Some n -> let n = Expr.int n in - let open Formula.Infix in - Solver.sat ~matching:false ~pfs ~gamma n #<= ofs + let open Expr.Infix in + Solver.sat ~matching:false ~pfs ~gamma (n <= ofs) in if maybe_out_of_bound then Error (UseAfterFree loc_name) else @@ -265,7 +265,7 @@ let merge_loc (heap : t) new_loc old_loc : unit = Hashtbl.remove heap old_loc) let substitution_in_place subst heap : - (t * Formula.Set.t * (string * Type.t) list) list = + (t * Expr.Set.t * (string * Type.t) list) list = (* First we replace in the offset and values using fvl *) let () = Hashtbl.iter @@ -297,7 +297,7 @@ let substitution_in_place subst heap : ((WPrettyUtils.to_str Expr.pp) new_loc))) in merge_loc heap new_loc_str aloc); - [ (heap, Formula.Set.empty, []) ] + [ (heap, Expr.Set.empty, []) ] let assertions heap = Hashtbl.fold (fun loc block acc -> Block.assertions ~loc block @ acc) heap [] diff --git a/wisl/lib/semantics/wislSHeap.mli b/wisl/lib/semantics/wislSHeap.mli index e8f919f9..b24a341b 100644 --- a/wisl/lib/semantics/wislSHeap.mli +++ b/wisl/lib/semantics/wislSHeap.mli @@ -52,11 +52,11 @@ val substitution_in_place : Gillian.Symbolic.Subst.t -> t -> (t - * Gillian.Gil_syntax.Formula.Set.t + * Gillian.Gil_syntax.Expr.Set.t * (string * Gillian.Gil_syntax.Type.t) list) list -val assertions : t -> Gillian.Gil_syntax.Asrt.t list +val assertions : t -> Gillian.Gil_syntax.Asrt.t val add_debugger_variables : store:(string * Gillian.Gil_syntax.Expr.t) list -> diff --git a/wisl/lib/semantics/wislSMemory.ml b/wisl/lib/semantics/wislSMemory.ml index 512a198e..4e39e94c 100644 --- a/wisl/lib/semantics/wislSMemory.ml +++ b/wisl/lib/semantics/wislSMemory.ml @@ -8,15 +8,9 @@ module SS = Gillian.Utils.Containers.SS type init_data = unit type vt = Values.t -type st = Subst.t type err_t = WislSHeap.err [@@deriving yojson, show] type t = WislSHeap.t [@@deriving yojson] -type action_ret = - ( (t * vt list * Formula.t list * (string * Type.t) list) list, - err_t list ) - result - let init () = WislSHeap.init () let get_init_data _ = () let clear _ = WislSHeap.init () @@ -45,7 +39,7 @@ let set_cell heap pfs gamma (loc : vt) (offset : vt) (value : vt) = else (loc_name, []) | None -> let al = ALoc.alloc () in - (al, [ Formula.Eq (Expr.ALoc al, loc) ]) + (al, [ Expr.BinOp (Expr.ALoc al, Equal, loc) ]) in match WislSHeap.set_cell ~pfs ~gamma heap loc_name offset value with | Error e -> Error [ e ] @@ -83,7 +77,7 @@ let set_bound heap pfs gamma (loc : vt) (bound : int) = else (loc_name, []) | None -> let al = ALoc.alloc () in - (al, [ Formula.Eq (Expr.ALoc al, loc) ]) + (al, [ Expr.BinOp (ALoc al, Equal, loc) ]) in match WislSHeap.set_bound heap loc_name bound with | Error e -> Error [ e ] @@ -120,7 +114,7 @@ let set_freed heap pfs gamma (loc : vt) = else (loc_name, []) | None -> let al = ALoc.alloc () in - (al, [ Formula.Eq (Expr.ALoc al, loc) ]) + (al, [ Expr.BinOp (ALoc al, Equal, loc) ]) in let () = WislSHeap.set_freed heap loc_name in Ok [ (heap, [], new_pfs, []) ] @@ -311,17 +305,17 @@ let get_fixes (err : err_t) = let value = Expr.LVar new_var in let loc = Expr.loc_from_loc_name loc in let ga = WislLActions.str_ga WislLActions.Cell in - [ [ Asrt.GA (ga, [ loc; ofs ], [ value ]) ] ] + [ [ Asrt.CorePred (ga, [ loc; ofs ], [ value ]) ] ] | InvalidLocation loc -> let new_loc = ALoc.alloc () in let new_expr = Expr.ALoc new_loc in - [ [ Asrt.Pure (Eq (new_expr, loc)) ] ] + [ [ Asrt.Pure (BinOp (new_expr, Equal, loc)) ] ] | _ -> [] let can_fix = function | WislSHeap.InvalidLocation _ | MissingResource _ -> true | _ -> false -let get_failing_constraint _ = Formula.True +let get_failing_constraint _ = Expr.true_ let add_debugger_variables = WislSHeap.add_debugger_variables let sure_is_nonempty t = not (WislSHeap.is_empty t) diff --git a/wisl/runtime/wisl_pointer_arith.gil b/wisl/runtime/wisl_pointer_arith.gil index cde86da2..a96b48f6 100644 --- a/wisl/runtime/wisl_pointer_arith.gil +++ b/wisl/runtime/wisl_pointer_arith.gil @@ -109,12 +109,12 @@ proc i__gt (el, er) { pred i__pred_add (+el, +er, out): types(el: List, er: Int) * (el == {{ #loc, #offset }}) * (out == {{ #loc, #offset i+ er }}), types(er: List, el: Int) * (er == {{ #loc, #offset}}) * (out == {{ #loc, #offset i+ el }}), - types(er: Int, el: Int) * (out == er i+ el); + types(er: Int, el: Int) * (out == (er i+ el)); (* i__pred_minus(x, y, z) is true if executing i__minus(x, y) would return z *) pred i__pred_minus (+el, +er, out): types(el: List, er: Int) * (el == {{ #loc, #offset }}) * (out == {{ #loc, #offset i- er }}), - types(er: Int, el: Int) * (out == el i- er); + types(er: Int, el: Int) * (out == (el i- er)); (* i__pred_lt(x, y, z) is true if executing i__lt(x, y) would return z *) pred i__pred_lt (+el, +er, out): @@ -135,4 +135,3 @@ pred i__pred_leq (+el, +er, out): pred i__pred_geq (+el, +er, out): types(el: List, er: List) * (el == {{ #locl, #offsetl }}) * (er == {{ #locr, #offsetr }}) * (#locr == #locl) * (out == (not (#offsetl i< #offsetr))), types(el: Int, er: Int) * (out == (not (el i< er))); -