From 6285f15fea8fbd1139f086abfcf0d9da3cc147ee Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Mon, 7 Apr 2025 13:16:24 +0100 Subject: [PATCH 01/37] Implemented parsing of custom datatype definitions. --- wisl/examples/SLL_adt.wisl | 120 +++++++++++++++++++++++++ wisl/lib/ParserAndCompiler/WLexer.mll | 2 + wisl/lib/ParserAndCompiler/WParser.mly | 112 +++++++++++++++-------- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 7 +- wisl/lib/syntax/WConstructor.ml | 1 + wisl/lib/syntax/WConstructor.mli | 1 + wisl/lib/syntax/WDatatype.ml | 1 + wisl/lib/syntax/WDatatype.mli | 1 + wisl/lib/syntax/WProg.ml | 1 + wisl/lib/syntax/WProg.mli | 1 + wisl/lib/syntax/WType.ml | 2 + wisl/lib/syntax/WType.mli | 11 ++- 12 files changed, 218 insertions(+), 42 deletions(-) create mode 100644 wisl/examples/SLL_adt.wisl create mode 100644 wisl/lib/syntax/WConstructor.ml create mode 100644 wisl/lib/syntax/WConstructor.mli create mode 100644 wisl/lib/syntax/WDatatype.ml create mode 100644 wisl/lib/syntax/WDatatype.mli diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl new file mode 100644 index 00000000..52a4c5b0 --- /dev/null +++ b/wisl/examples/SLL_adt.wisl @@ -0,0 +1,120 @@ +// Define a list ADT for use in specification language +datatype MyList { + Nil; + Cons(Any, MyList) +} + + +// +// Standard over-approximating SLL predicate with contents +// +predicate SLL(+x, vs) { + // Empty SLL + (x == null) * (vs == Nil); + // One SLL node and the rest + (x -b> #v, #next) * SLL(#next, #vs) * + (vs == Cons(#v, #vs)) +} + +// +// Pure predicate for list membership +// +predicate list_member(+vs, +v, r : Bool){ + (vs == Nil) * (r == false); + (vs == Cons(v, #rest)) * (r == true) * list_member(#rest, v, #mem); + (vs == Cons(#v, #rest)) * (! (#v == v)) * list_member(#rest, v, r) +} + +// 00. Allocating an SLL node with the given value +{ v == #v } +function SLL_allocate_node(v){ + t := new(2); + [t] := v; + return t +} +{ SLL(ret, Cons(#v, Nil) } + + +// +// RECURSIVE SLL MANIPULATION +// + +// 01. Prepending a given value to a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #vs) } +function SLL_prepend(x, k){ + z := SLL_allocate_node(k); + [z + 1] := x; + return z +} +{ SLL(ret, Cons(#k, #vs)) } + +// 05. Copying a given SLL +{ (x == #x) * SLL(#x, #vs) } +function SLL_copy(x){ + y := null; + if (not (x = null)) { + k := [x]; + y := SLL_allocate_node(k); + t := [x + 1]; + z := SLL_copy(t); + [y + 1] := z + } else { + skip + }; + return y +} +{ SLL(#x, #vs) * SLL(ret, #vs) } + +// 08. Checking if a given value is in a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #r) } +function SLL_member(x, k){ + found := false; + if (x = null){ + skip + } else { + v := [x]; + if (v = k){ + found := true + } else { + t := [x + 1]; + found := SLL_member(t, k) + } + }; + return found +} +{ SLL(#x, #vs) * list_member(#vs, #k, #r) * (ret == #r) } + +// 09. Removing a given value from a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #mem) } +function SLL_remove(x, k) { + if (x = null) { + skip + } else { + v := [x]; + next := [x + 1]; + if (v = k){ + free(x); + x := SLL_remove(next, k) + } else { + z := SLL_remove(next, k); + [x + 1] := z + } + }; + [[ fold list_member(Nil, #k, false) ]]; + return x +} +{ SLL(ret, #nvs) * list_member(#nvs, #k, false) } + +// 10. Freeing a given SLL +{ (x == #x) * SLL(#x, #vs) } +function SLL_free(x){ + if (x = null) { + skip + } else { + t := [x + 1]; + z := SLL_free(t); + free(x) + }; + return null +} +{ (ret == null) } diff --git a/wisl/lib/ParserAndCompiler/WLexer.mll b/wisl/lib/ParserAndCompiler/WLexer.mll index 4c870d39..c6dafa00 100644 --- a/wisl/lib/ParserAndCompiler/WLexer.mll +++ b/wisl/lib/ParserAndCompiler/WLexer.mll @@ -37,6 +37,7 @@ rule read = | "dispose"{ DELETE (curr lexbuf) } | "function" { FUNCTION (curr lexbuf) } | "predicate" { PREDICATE (curr lexbuf) } + | "datatype" { DATATYPE (curr lexbuf) } | "invariant" { INVARIANT (curr lexbuf) } | "return" { RETURN (curr lexbuf) } | "fold" { FOLD (curr lexbuf) } @@ -59,6 +60,7 @@ rule read = | "Int" { TINT (curr lexbuf) } | "Bool" { TBOOL (curr lexbuf) } | "String" { TSTRING (curr lexbuf) } + | "Any" { TANY (curr lexbuf) } (* strings and comments *) | '"' { let () = l_start_string := curr lexbuf in read_string (Buffer.create 17) lexbuf } diff --git a/wisl/lib/ParserAndCompiler/WParser.mly b/wisl/lib/ParserAndCompiler/WParser.mly index 6f7b0df6..47c8336c 100644 --- a/wisl/lib/ParserAndCompiler/WParser.mly +++ b/wisl/lib/ParserAndCompiler/WParser.mly @@ -2,7 +2,7 @@ (* key words *) %token TRUE FALSE NULL WHILE IF ELSE SKIP FRESH NEW DELETE -%token FUNCTION RETURN PREDICATE LEMMA +%token FUNCTION RETURN PREDICATE LEMMA DATATYPE %token INVARIANT PACKAGE FOLD UNFOLD NOUNFOLD APPLY ASSERT ASSUME ASSUME_TYPE EXIST FORALL %token STATEMENT WITH VARIANT PROOF @@ -29,6 +29,7 @@ %token TINT %token TBOOL %token TSTRING +%token TANY (* names *) %token IDENTIFIER @@ -95,51 +96,57 @@ %start prog %start assert_only -%type definitions -%type fct_with_specs -%type fct -%type predicate -%type lemma -%type var_list -%type statement_list_and_return -%type statement_list -%type expression -%type expr_list -%type logic_command -%type logic_assertion -%type value_with_loc -%type unop_with_loc -%type binop -%type variant_def -%type with_variant_def -%type proof_def -%type <(string * WType.t option) * bool> pred_param_ins -%type bindings_with_loc -%type logic_pure_formula -%type logic_expression -%type logic_binop -%type logic_value_with_loc +%type definitions +%type fct_with_specs +%type fct +%type predicate +%type lemma +%type datatype +%type var_list +%type statement_list_and_return +%type statement_list +%type expression +%type expr_list +%type logic_command +%type logic_assertion +%type value_with_loc +%type unop_with_loc +%type binop +%type variant_def +%type with_variant_def +%type proof_def +%type <(string * WType.t option) * bool> pred_param_ins +%type bindings_with_loc +%type logic_pure_formula +%type logic_expression +%type logic_binop +%type logic_value_with_loc +%type constructor +%type constructor_fields %% prog: - | fcp = definitions; EOF { - let (fc, preds, lemmas) = fcp in - WProg.{ lemmas = lemmas; predicates = preds; context = fc } } + | defs = definitions; EOF { + let (fc, preds, lemmas, datatypes) = defs in + WProg.{ lemmas = lemmas; predicates = preds; context = fc; datatypes = datatypes } } assert_only: | la = logic_assertion; EOF { la } definitions: - | (* empty *) { ([], [], []) } - | fpdcl = definitions; p = predicate - { let (fs, ps,ls) = fpdcl in - (fs, p::ps, ls) } - | fpdcl = definitions; l = lemma - { let (fs, ps, ls) = fpdcl in - (fs, ps, l::ls) } - | fpdcl = definitions; f = fct_with_specs - { let (fs, ps, ls) = fpdcl in - (f::fs, ps, ls) } + | (* empty *) { ([], [], [], []) } + | defs = definitions; p = predicate + { let (fs, ps, ls, ds) = defs in + (fs, p::ps, ls, ds) } + | defs = definitions; l = lemma + { let (fs, ps, ls, ds) = defs in + (fs, ps, l::ls, ds) } + | defs = definitions; f = fct_with_specs + { let (fs, ps, ls, ds) = defs in + (f::fs, ps, ls, ds) } + | defs = definitions; d = datatype + { let (fs, ps, ls, ds) = defs in + (fs, ps, ls, d::ds) } fct_with_specs: | lstart = LCBRACE; pre = logic_assertion; RCBRACE; variant = option(with_variant_def); f = fct; LCBRACE; @@ -195,6 +202,8 @@ type_target: | TINT { WType.WInt } | TBOOL { WType.WBool } | TSTRING { WType.WString } + | TANY { WType.WAny } + | datatype = IDENTIFIER { let (_, datatype) = datatype in WType.WDatatype datatype } statement: | loc = SKIP { WStmt.make WStmt.Skip loc } @@ -388,7 +397,7 @@ predicate: (* ins looks like [Some 0, Some 2] *) let ins = List.map Option.get ins in (* ins looks like [0, 2] *) - let pred_ins = if (List.length ins) > 0 then ins else (List.mapi (fun i _ -> i) pred_params) in + let pred_ins = if (List.length ins) > 0 then ins else (List.mapi (fun i _ -> i) pred_params) in (* if ins is empty then everything is an in *) let pred_nounfold = (pred_nounfold <> None) in let pred_loc = CodeLoc.merge lstart lend in @@ -640,3 +649,28 @@ logic_value_with_loc: { let (_, vl) = List.split lvl in let loc = CodeLoc.merge lstart lend in (loc, WVal.VList vl) } */ + + +(* ADT definitions *) + +datatype: + | lstart = DATATYPE; name = IDENTIFIER; LCBRACE; + constructors = separated_nonempty_list(SEMICOLON, constructor); + lend = RCBRACE; + { + let (_, name) = name in + let loc = CodeLoc.merge lstart lend in + WDatatype.{ + name; + constructors; + loc; + } + } + +constructor: + | name = IDENTIFIER; fields = option(constructor_fields) + { let (_, name) = name in WConstructor.{name; fields = Option.value ~default:[] fields} } + +constructor_fields: + | LBRACE; args = separated_list(COMMA, type_target); RBRACE + { args } diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index 1f06357b..6a6847ff 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -27,7 +27,9 @@ let compile_type t = | WPtr -> Some Type.ObjectType | WInt -> Some Type.IntType | WSet -> Some Type.SetType - | WAny -> None) + | WAny -> None + | WDatatype _ -> None) +(*TODO ??*) let compile_binop b = WBinOp.( @@ -1144,7 +1146,8 @@ let compile_lemma lemma_existentials; } -let compile ~filepath WProg.{ context; predicates; lemmas } = +let compile ~filepath WProg.{ context; predicates; lemmas; _ } = + (* TODO: Compile user defined datatypes *) (* stuff useful to build hashtables *) let make_hashtbl get_name deflist = let hashtbl = Hashtbl.create (List.length deflist) in diff --git a/wisl/lib/syntax/WConstructor.ml b/wisl/lib/syntax/WConstructor.ml new file mode 100644 index 00000000..4fd56e3d --- /dev/null +++ b/wisl/lib/syntax/WConstructor.ml @@ -0,0 +1 @@ +type t = { name : string; fields : WType.t list } diff --git a/wisl/lib/syntax/WConstructor.mli b/wisl/lib/syntax/WConstructor.mli new file mode 100644 index 00000000..4fd56e3d --- /dev/null +++ b/wisl/lib/syntax/WConstructor.mli @@ -0,0 +1 @@ +type t = { name : string; fields : WType.t list } diff --git a/wisl/lib/syntax/WDatatype.ml b/wisl/lib/syntax/WDatatype.ml new file mode 100644 index 00000000..0658a663 --- /dev/null +++ b/wisl/lib/syntax/WDatatype.ml @@ -0,0 +1 @@ +type t = { name : string; constructors : WConstructor.t list; loc : CodeLoc.t } diff --git a/wisl/lib/syntax/WDatatype.mli b/wisl/lib/syntax/WDatatype.mli new file mode 100644 index 00000000..0658a663 --- /dev/null +++ b/wisl/lib/syntax/WDatatype.mli @@ -0,0 +1 @@ +type t = { name : string; constructors : WConstructor.t list; loc : CodeLoc.t } diff --git a/wisl/lib/syntax/WProg.ml b/wisl/lib/syntax/WProg.ml index 461e5d53..0efef49c 100644 --- a/wisl/lib/syntax/WProg.ml +++ b/wisl/lib/syntax/WProg.ml @@ -4,6 +4,7 @@ type t = { context : WFun.t list; predicates : WPred.t list; lemmas : WLemma.t list; + datatypes : WDatatype.t list; } let get_context p = p.context diff --git a/wisl/lib/syntax/WProg.mli b/wisl/lib/syntax/WProg.mli index 941489a0..e11b16f0 100644 --- a/wisl/lib/syntax/WProg.mli +++ b/wisl/lib/syntax/WProg.mli @@ -2,6 +2,7 @@ type t = { context : WFun.t list; predicates : WPred.t list; lemmas : WLemma.t list; + datatypes : WDatatype.t list; } val get_context : t -> WFun.t list diff --git a/wisl/lib/syntax/WType.ml b/wisl/lib/syntax/WType.ml index 2817f6be..05f1d669 100644 --- a/wisl/lib/syntax/WType.ml +++ b/wisl/lib/syntax/WType.ml @@ -8,6 +8,7 @@ type t = | WInt | WAny | WSet + | WDatatype of string (** Are types t1 and t2 compatible *) let compatible t1 t2 = @@ -36,6 +37,7 @@ let pp fmt t = | WInt -> s "Int" | WAny -> s "Any" | WSet -> s "Set" + | WDatatype t -> s t let to_gil = function | WList -> Gil_syntax.Type.ListType diff --git a/wisl/lib/syntax/WType.mli b/wisl/lib/syntax/WType.mli index 6f66fc14..75704d1d 100644 --- a/wisl/lib/syntax/WType.mli +++ b/wisl/lib/syntax/WType.mli @@ -1,4 +1,13 @@ -type t = WList | WNull | WBool | WString | WPtr | WInt | WAny | WSet +type t = + | WList + | WNull + | WBool + | WString + | WPtr + | WInt + | WAny + | WSet + | WDatatype of string val compatible : t -> t -> bool val strongest : t -> t -> t From 1c184ba53d5060777966c94430a16bdf87b0371e Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Tue, 8 Apr 2025 13:56:27 +0100 Subject: [PATCH 02/37] Added parsing for ADT constructors within LExpr --- wisl/examples/temp.wisl | 27 ++++++++++++++++++++++++++ wisl/lib/ParserAndCompiler/WParser.mly | 5 +++++ wisl/lib/ParserAndCompiler/wisl2Gil.ml | 5 ++++- wisl/lib/syntax/WLExpr.ml | 7 +++++++ wisl/lib/syntax/WLExpr.mli | 1 + wisl/lib/syntax/WType.ml | 3 +++ 6 files changed, 47 insertions(+), 1 deletion(-) create mode 100644 wisl/examples/temp.wisl diff --git a/wisl/examples/temp.wisl b/wisl/examples/temp.wisl new file mode 100644 index 00000000..8a8bebdd --- /dev/null +++ b/wisl/examples/temp.wisl @@ -0,0 +1,27 @@ + +// Define a list ADT for use in specification language +datatype MyList { + Nil; + Cons(Any, MyList) +} + + +// +// Standard over-approximating SLL predicate with contents +// +predicate SLL(+x, vs) { + // Empty SLL + (x == null) * (vs == Nil); + // One SLL node and the rest + (x -b> #v, #next) * SLL(#next, #vs) * + (vs == Cons(#v, #vs)) +} + +// +// Pure predicate for list membership +// +predicate list_member(+vs, +v, r : Bool){ + (vs == Nil) * (r == false); + (vs == Cons(v, #rest)) * (r == true) * list_member(#rest, v, #mem); + (vs == Cons(#v, #rest)) * (! (#v == v)) * list_member(#rest, v, r) +} diff --git a/wisl/lib/ParserAndCompiler/WParser.mly b/wisl/lib/ParserAndCompiler/WParser.mly index 47c8336c..47981c77 100644 --- a/wisl/lib/ParserAndCompiler/WParser.mly +++ b/wisl/lib/ParserAndCompiler/WParser.mly @@ -632,6 +632,11 @@ logic_expression: { let loc = CodeLoc.merge lstart lend in let bare_lexpr = WLExpr.LESet l in WLExpr.make bare_lexpr loc } + | lname = IDENTIFIER; LBRACE; l = separated_list(COMMA, logic_expression); lend = RBRACE + { let (lstart, name) = lname in + let loc = CodeLoc.merge lstart lend in + let bare_lexpr = WLExpr.LConstructor (name, l) in + WLExpr.make bare_lexpr loc } (* We also have lists in the logic *) diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index 6a6847ff..8c89068b 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -236,7 +236,10 @@ let rec compile_lexpr ?(fname = "main") (lexpr : WLExpr.t) : let gvars, asrtsl, comp_exprs = list_split_3 (List.map compile_lexpr l) in - (List.concat gvars, List.concat asrtsl, Expr.ESet comp_exprs)) + (List.concat gvars, List.concat asrtsl, Expr.ESet comp_exprs) + | LConstructor _ -> + (* TODO *) + failwith "TODO") (* TODO: compile_lformula should return also the list of created existentials *) let rec compile_lformula ?(fname = "main") formula : Asrt.t * Expr.t = diff --git a/wisl/lib/syntax/WLExpr.ml b/wisl/lib/syntax/WLExpr.ml index db26f314..1892fe77 100644 --- a/wisl/lib/syntax/WLExpr.ml +++ b/wisl/lib/syntax/WLExpr.ml @@ -9,6 +9,8 @@ type tt = | LLSub of t * t * t | LEList of t list | LESet of t list + (* TODO: Double check handling of LConstructor in functions that manipulate WLExpr *) + | LConstructor of string * t list and t = { wleid : int; wleloc : CodeLoc.t; wlenode : tt } @@ -71,6 +73,10 @@ let rec pp fmt lexpr = | LESet lel -> WPrettyUtils.pp_list ~pre:(format_of_string "@[-{") ~suf:(format_of_string "}-@]") pp fmt lel + | LConstructor (name, lel) -> + Format.fprintf fmt "@[%s" name; + WPrettyUtils.pp_list ~pre:(format_of_string "(") + ~suf:(format_of_string ")@]") ~empty:(format_of_string "@]") pp fmt lel let str = Format.asprintf "%a" pp @@ -87,5 +93,6 @@ let rec substitution (subst : (string, tt) Hashtbl.t) (e : t) : t = | LLSub (e1, e2, e3) -> LLSub (f e1, f e2, f e3) | LEList le -> LEList (List.map f le) | LESet le -> LESet (List.map f le) + | LConstructor (name, le) -> LConstructor (name, List.map f le) in { wleid; wleloc; wlenode } diff --git a/wisl/lib/syntax/WLExpr.mli b/wisl/lib/syntax/WLExpr.mli index dcd6cd82..e4541d2c 100644 --- a/wisl/lib/syntax/WLExpr.mli +++ b/wisl/lib/syntax/WLExpr.mli @@ -7,6 +7,7 @@ type tt = | LLSub of t * t * t | LEList of t list | LESet of t list + | LConstructor of string * t list and t diff --git a/wisl/lib/syntax/WType.ml b/wisl/lib/syntax/WType.ml index 05f1d669..27d16631 100644 --- a/wisl/lib/syntax/WType.ml +++ b/wisl/lib/syntax/WType.ml @@ -135,6 +135,9 @@ let rec infer_logic_expr knownp lexpr = TypeMap.add bare_lexpr WList (List.fold_left infer_logic_expr knownp lel) | LESet lel -> TypeMap.add bare_lexpr WSet (List.fold_left infer_logic_expr knownp lel) + | LConstructor (_, lel) -> + (*TODO ??*) + TypeMap.add bare_lexpr WSet (List.fold_left infer_logic_expr knownp lel) (** Single step of inference for that gets a TypeMap from a single assertion *) let rec infer_single_assert_step asser known = From 8ba6a5e827f7b5d53201600f51a061b3bb16a340 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Tue, 8 Apr 2025 14:10:08 +0100 Subject: [PATCH 03/37] Completed parsing in WISL for user def datatypes --- wisl/examples/SLL_adt.wisl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl index 52a4c5b0..269acefc 100644 --- a/wisl/examples/SLL_adt.wisl +++ b/wisl/examples/SLL_adt.wisl @@ -32,7 +32,7 @@ function SLL_allocate_node(v){ [t] := v; return t } -{ SLL(ret, Cons(#v, Nil) } +{ SLL(ret, Cons(#v, Nil)) } // From 0657df08dc1f85bc57d0131861b36e9e649dc6d0 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Wed, 9 Apr 2025 15:04:41 +0100 Subject: [PATCH 04/37] Refactored WDatatype and WConstructor --- wisl/lib/ParserAndCompiler/WParser.mly | 37 +++++++++++++++++--------- wisl/lib/syntax/WConstructor.ml | 7 ++++- wisl/lib/syntax/WConstructor.mli | 7 ++++- wisl/lib/syntax/WDatatype.ml | 7 ++++- wisl/lib/syntax/WDatatype.mli | 7 ++++- 5 files changed, 49 insertions(+), 16 deletions(-) diff --git a/wisl/lib/ParserAndCompiler/WParser.mly b/wisl/lib/ParserAndCompiler/WParser.mly index 47981c77..2bc4c51e 100644 --- a/wisl/lib/ParserAndCompiler/WParser.mly +++ b/wisl/lib/ParserAndCompiler/WParser.mly @@ -122,7 +122,7 @@ %type logic_binop %type logic_value_with_loc %type constructor -%type constructor_fields +%type constructor_fields %% prog: @@ -659,23 +659,36 @@ logic_value_with_loc: (* ADT definitions *) datatype: - | lstart = DATATYPE; name = IDENTIFIER; LCBRACE; - constructors = separated_nonempty_list(SEMICOLON, constructor); + | lstart = DATATYPE; ldname = IDENTIFIER; LCBRACE; + datatype_constructors = separated_nonempty_list(SEMICOLON, constructor); lend = RCBRACE; { - let (_, name) = name in - let loc = CodeLoc.merge lstart lend in + let (_, datatype_name) = ldname in + let datatype_loc = CodeLoc.merge lstart lend in + let datatype_id = Generators.gen_id () in WDatatype.{ - name; - constructors; - loc; + datatype_name; + datatype_constructors; + datatype_loc; + datatype_id; } } constructor: - | name = IDENTIFIER; fields = option(constructor_fields) - { let (_, name) = name in WConstructor.{name; fields = Option.value ~default:[] fields} } + | lcname = IDENTIFIER; fields_lend = option(constructor_fields) + { + let (lstart, constructor_name) = lcname in + let (constructor_fields, lend) = Option.value ~default:([], lstart) fields_lend in + let constructor_loc = CodeLoc.merge lstart lend in + let constructor_id = Generators.gen_id () in + WConstructor.{ + constructor_name; + constructor_fields; + constructor_loc; + constructor_id; + } + } constructor_fields: - | LBRACE; args = separated_list(COMMA, type_target); RBRACE - { args } + | LBRACE; args = separated_list(COMMA, type_target); lend = RBRACE + { (args, lend) } diff --git a/wisl/lib/syntax/WConstructor.ml b/wisl/lib/syntax/WConstructor.ml index 4fd56e3d..15920e2d 100644 --- a/wisl/lib/syntax/WConstructor.ml +++ b/wisl/lib/syntax/WConstructor.ml @@ -1 +1,6 @@ -type t = { name : string; fields : WType.t list } +type t = { + constructor_name : string; + constructor_fields : WType.t list; + constructor_loc: CodeLoc.t; + constructor_id: int; +} diff --git a/wisl/lib/syntax/WConstructor.mli b/wisl/lib/syntax/WConstructor.mli index 4fd56e3d..15920e2d 100644 --- a/wisl/lib/syntax/WConstructor.mli +++ b/wisl/lib/syntax/WConstructor.mli @@ -1 +1,6 @@ -type t = { name : string; fields : WType.t list } +type t = { + constructor_name : string; + constructor_fields : WType.t list; + constructor_loc: CodeLoc.t; + constructor_id: int; +} diff --git a/wisl/lib/syntax/WDatatype.ml b/wisl/lib/syntax/WDatatype.ml index 0658a663..ca19cffc 100644 --- a/wisl/lib/syntax/WDatatype.ml +++ b/wisl/lib/syntax/WDatatype.ml @@ -1 +1,6 @@ -type t = { name : string; constructors : WConstructor.t list; loc : CodeLoc.t } +type t = { + datatype_name : string; + datatype_constructors : WConstructor.t list; + datatype_loc : CodeLoc.t; + datatype_id: int; +} diff --git a/wisl/lib/syntax/WDatatype.mli b/wisl/lib/syntax/WDatatype.mli index 0658a663..ca19cffc 100644 --- a/wisl/lib/syntax/WDatatype.mli +++ b/wisl/lib/syntax/WDatatype.mli @@ -1 +1,6 @@ -type t = { name : string; constructors : WConstructor.t list; loc : CodeLoc.t } +type t = { + datatype_name : string; + datatype_constructors : WConstructor.t list; + datatype_loc : CodeLoc.t; + datatype_id: int; +} From a9c1585a4f067fc67544f42e14acc70841d54047 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Wed, 9 Apr 2025 15:05:50 +0100 Subject: [PATCH 05/37] Fixed code style in WDatatype and WConstructor --- wisl/lib/syntax/WConstructor.ml | 4 ++-- wisl/lib/syntax/WConstructor.mli | 4 ++-- wisl/lib/syntax/WDatatype.ml | 2 +- wisl/lib/syntax/WDatatype.mli | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/wisl/lib/syntax/WConstructor.ml b/wisl/lib/syntax/WConstructor.ml index 15920e2d..7a40783c 100644 --- a/wisl/lib/syntax/WConstructor.ml +++ b/wisl/lib/syntax/WConstructor.ml @@ -1,6 +1,6 @@ type t = { constructor_name : string; constructor_fields : WType.t list; - constructor_loc: CodeLoc.t; - constructor_id: int; + constructor_loc : CodeLoc.t; + constructor_id : int; } diff --git a/wisl/lib/syntax/WConstructor.mli b/wisl/lib/syntax/WConstructor.mli index 15920e2d..7a40783c 100644 --- a/wisl/lib/syntax/WConstructor.mli +++ b/wisl/lib/syntax/WConstructor.mli @@ -1,6 +1,6 @@ type t = { constructor_name : string; constructor_fields : WType.t list; - constructor_loc: CodeLoc.t; - constructor_id: int; + constructor_loc : CodeLoc.t; + constructor_id : int; } diff --git a/wisl/lib/syntax/WDatatype.ml b/wisl/lib/syntax/WDatatype.ml index ca19cffc..6a454459 100644 --- a/wisl/lib/syntax/WDatatype.ml +++ b/wisl/lib/syntax/WDatatype.ml @@ -2,5 +2,5 @@ type t = { datatype_name : string; datatype_constructors : WConstructor.t list; datatype_loc : CodeLoc.t; - datatype_id: int; + datatype_id : int; } diff --git a/wisl/lib/syntax/WDatatype.mli b/wisl/lib/syntax/WDatatype.mli index ca19cffc..6a454459 100644 --- a/wisl/lib/syntax/WDatatype.mli +++ b/wisl/lib/syntax/WDatatype.mli @@ -2,5 +2,5 @@ type t = { datatype_name : string; datatype_constructors : WConstructor.t list; datatype_loc : CodeLoc.t; - datatype_id: int; + datatype_id : int; } From 5e2ca9f0e741023a1375b558022697aa6158b702 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Wed, 9 Apr 2025 18:17:53 +0100 Subject: [PATCH 06/37] Added datatypes to GIL program AST --- Gillian-C/lib/gilgen.ml | 2 ++ Gillian-JS/lib/Compiler/JSIL2GIL.ml | 5 +++- GillianCore/GIL_Syntax/Constructor.ml | 7 +++++ GillianCore/GIL_Syntax/Datatype.ml | 6 ++++ GillianCore/GIL_Syntax/Gil_syntax.ml | 2 ++ GillianCore/GIL_Syntax/Gil_syntax.mli | 39 ++++++++++++++++++++++++++ GillianCore/GIL_Syntax/Prog.ml | 9 ++++++ GillianCore/GIL_Syntax/TypeDef__.ml | 15 ++++++++++ GillianCore/gil_parser/gil_parsing.ml | 3 +- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 3 +- 10 files changed, 88 insertions(+), 3 deletions(-) create mode 100644 GillianCore/GIL_Syntax/Constructor.ml create mode 100644 GillianCore/GIL_Syntax/Datatype.ml diff --git a/Gillian-C/lib/gilgen.ml b/Gillian-C/lib/gilgen.ml index 0fd2c4cd..fac37759 100644 --- a/Gillian-C/lib/gilgen.ml +++ b/Gillian-C/lib/gilgen.ml @@ -1061,6 +1061,8 @@ let trans_program imports = []; lemmas = Hashtbl.create 1; preds = Hashtbl.create 1; + datatypes = Hashtbl.create 1; + constructors = Hashtbl.create 1; only_specs = Hashtbl.create 1; macros = Hashtbl.create 1; bi_specs = make_hashtbl (fun p -> p.BiSpec.bispec_name) bi_specs; diff --git a/Gillian-JS/lib/Compiler/JSIL2GIL.ml b/Gillian-JS/lib/Compiler/JSIL2GIL.ml index 6e06a4b7..dcdadeb7 100644 --- a/Gillian-JS/lib/Compiler/JSIL2GIL.ml +++ b/Gillian-JS/lib/Compiler/JSIL2GIL.ml @@ -502,6 +502,9 @@ let jsil2core_prog (prog : EProg.t) : ('a, string) GProg.t = ~procs:new_procs ~macros:(translate_tbl prog.macros jsil2gil_macro) ~bi_specs:(translate_tbl prog.bi_specs jsil2gil_bispec) - ~proc_names:prog.proc_names ~predecessors:(Hashtbl.create 1) () + ~proc_names:prog.proc_names ~predecessors:(Hashtbl.create 1) + ~datatypes:(Hashtbl.create 1) + ~constructors:(Hashtbl.create 1) (* TODO *) + () in result diff --git a/GillianCore/GIL_Syntax/Constructor.ml b/GillianCore/GIL_Syntax/Constructor.ml new file mode 100644 index 00000000..9b390e76 --- /dev/null +++ b/GillianCore/GIL_Syntax/Constructor.ml @@ -0,0 +1,7 @@ +type t = TypeDef__.constructor = { + constructor_name : string; + constructor_source_path : string option; + constructor_loc : Location.t option; + constructor_num_fields : int; + constructor_fields : Type.t list; +} diff --git a/GillianCore/GIL_Syntax/Datatype.ml b/GillianCore/GIL_Syntax/Datatype.ml new file mode 100644 index 00000000..c7c0cdb8 --- /dev/null +++ b/GillianCore/GIL_Syntax/Datatype.ml @@ -0,0 +1,6 @@ +type t = TypeDef__.datatype = { + datatype_name : string; + datatype_source_path : string option; + datatype_loc : Location.t option; + datatype_constructors : Constructor.t list; +} diff --git a/GillianCore/GIL_Syntax/Gil_syntax.ml b/GillianCore/GIL_Syntax/Gil_syntax.ml index ad6d2375..8a181d34 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.ml +++ b/GillianCore/GIL_Syntax/Gil_syntax.ml @@ -6,6 +6,8 @@ module BiSpec = BiSpec module Branch_case = Branch_case module Cmd = Cmd module Constant = Constant +module Constructor = Constructor +module Datatype = Datatype module Expr = Expr module Flag = Flag module LCmd = LCmd diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index e1829a0b..e15b83d4 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -722,6 +722,25 @@ module Lemma : sig val add_param_bindings : t -> t end +module Datatype : sig + type t = { + datatype_name : string; + datatype_source_path : string option; + datatype_loc : Location.t option; + datatype_constructors : Constructor.t list; + } +end + +module Constructor : sig + type t = { + constructor_name : string; + constructor_source_path : string option; + constructor_loc : Location.t option; + constructor_num_fields : int; + constructor_fields : Type.t list; + } +end + (** @canonical Gillian.Gil_syntax.Macro *) module Macro : sig (** GIL Macros *) @@ -951,6 +970,8 @@ module Prog : sig (** List of imported GIL files, and whether each has to be verified *) lemmas : (string, Lemma.t) Hashtbl.t; (** Lemmas *) preds : (string, Pred.t) Hashtbl.t; (** Predicates *) + datatypes : (string, Datatype.t) Hashtbl.t; + constructors : (string, Constructor.t) Hashtbl.t; only_specs : (string, Spec.t) Hashtbl.t; (** Specs without function definitions *) procs : (string, ('annot, 'label) Proc.t) Hashtbl.t; (** Proceudes *) @@ -966,6 +987,8 @@ module Prog : sig imports:(string * bool) list -> lemmas:(string, Lemma.t) Hashtbl.t -> preds:(string, Pred.t) Hashtbl.t -> + datatypes:(string, Datatype.t) Hashtbl.t -> + constructors:(string, Constructor.t) Hashtbl.t -> only_specs:(string, Spec.t) Hashtbl.t -> procs:(string, ('annot, 'label) Proc.t) Hashtbl.t -> macros:(string, Macro.t) Hashtbl.t -> @@ -981,6 +1004,8 @@ module Prog : sig imports:(string * bool) list -> lemmas:(string, Lemma.t) Hashtbl.t -> preds:(string, Pred.t) Hashtbl.t -> + datatypes:(string, Datatype.t) Hashtbl.t -> + constructors:(string, Constructor.t) Hashtbl.t -> only_specs:(string, Spec.t) Hashtbl.t -> macros:(string, Macro.t) Hashtbl.t -> bi_specs:(string, BiSpec.t) Hashtbl.t -> @@ -994,6 +1019,8 @@ module Prog : sig predecessors:(string * int * int * int) list -> lemmas:(string, Lemma.t) Hashtbl.t -> preds:(string, Pred.t) Hashtbl.t -> + datatypes:(string, Datatype.t) Hashtbl.t -> + constructors:(string, Constructor.t) Hashtbl.t -> only_specs:(string, Spec.t) Hashtbl.t -> macros:(string, Macro.t) Hashtbl.t -> bi_specs:(string, BiSpec.t) Hashtbl.t -> @@ -1344,6 +1371,8 @@ module Visitors : sig ; visit_position : 'c -> Location.position -> Location.position ; visit_location : 'c -> Location.t -> Location.t ; visit_constant : 'c -> Constant.t -> Constant.t + ; visit_constructor : 'c -> Constructor.t -> Constructor.t + ; visit_datatype : 'c -> Datatype.t -> Datatype.t ; visit_expr : 'c -> Expr.t -> Expr.t ; visit_flag : 'c -> Flag.t -> Flag.t ; visit_lcmd : 'c -> LCmd.t -> LCmd.t @@ -1611,6 +1640,8 @@ module Visitors : sig method visit_position : 'c -> Location.position -> Location.position method visit_location : 'c -> Location.t -> Location.t method visit_constant : 'c -> Constant.t -> Constant.t + method visit_constructor : 'c -> Constructor.t -> Constructor.t + method visit_datatype : 'c -> Datatype.t -> Datatype.t method visit_expr : 'c -> Expr.t -> Expr.t method visit_flag : 'c -> Flag.t -> Flag.t method private visit_float : 'env. 'env -> float -> float @@ -1862,6 +1893,8 @@ module Visitors : sig ; visit_position : 'c -> Location.position -> 'f ; visit_location : 'c -> Location.t -> 'f ; visit_constant : 'c -> Constant.t -> 'f + ; visit_constructor : 'c -> Constructor.t -> 'f + ; visit_datatype : 'c -> Datatype.t -> 'f ; visit_expr : 'c -> Expr.t -> 'f ; visit_flag : 'c -> Flag.t -> 'f ; visit_lcmd : 'c -> LCmd.t -> 'f @@ -2085,6 +2118,8 @@ module Visitors : sig method visit_position : 'c -> Location.position -> 'f method visit_location : 'c -> Location.t -> 'f method visit_constant : 'c -> Constant.t -> 'f + method visit_constructor : 'c -> Constructor.t -> 'f + method visit_datatype : 'c -> Datatype.t -> 'f method visit_expr : 'c -> Expr.t -> 'f method visit_flag : 'c -> Flag.t -> 'f method visit_lcmd : 'c -> LCmd.t -> 'f @@ -2306,6 +2341,8 @@ module Visitors : sig ; visit_position : 'c -> Location.position -> unit ; visit_location : 'c -> Location.t -> unit ; visit_constant : 'c -> Constant.t -> unit + ; visit_constructor : 'c -> Constructor.t -> unit + ; visit_datatype : 'c -> Datatype.t -> unit ; visit_expr : 'c -> Expr.t -> unit ; visit_flag : 'c -> Flag.t -> unit ; visit_lcmd : 'c -> LCmd.t -> unit @@ -2542,6 +2579,8 @@ module Visitors : sig method visit_position : 'c -> Location.position -> unit method visit_location : 'c -> Location.t -> unit method visit_constant : 'c -> Constant.t -> unit + method visit_constructor : 'c -> Constructor.t -> unit + method visit_datatype : 'c -> Datatype.t -> unit method visit_expr : 'c -> Expr.t -> unit method visit_flag : 'c -> Flag.t -> unit method private visit_float : 'env. 'env -> float -> unit diff --git a/GillianCore/GIL_Syntax/Prog.ml b/GillianCore/GIL_Syntax/Prog.ml index f0bd3b94..c9adc51a 100644 --- a/GillianCore/GIL_Syntax/Prog.ml +++ b/GillianCore/GIL_Syntax/Prog.ml @@ -7,6 +7,8 @@ type ('annot, 'label) t = { (* Lemmas *) preds : (string, Pred.t) Hashtbl.t; (* Predicates = Name : String --> Definition *) + datatypes : (string, Datatype.t) Hashtbl.t; + constructors : (string, Constructor.t) Hashtbl.t; only_specs : (string, Spec.t) Hashtbl.t; (* Specs = Name : String --> Spec *) procs : (string, ('annot, 'label) Proc.t) Hashtbl.t; @@ -23,6 +25,8 @@ let make ~imports ~lemmas ~preds + ~datatypes + ~constructors ~only_specs ~procs ~macros @@ -34,6 +38,8 @@ let make imports; lemmas; preds; + datatypes; + constructors; only_specs; procs; macros; @@ -66,6 +72,9 @@ let create () = make_labeled ~imports:[] ~lemmas:(Hashtbl.create medium_tbl_size) ~preds:(Hashtbl.create big_tbl_size) + ~datatypes:(Hashtbl.create small_tbl_size) + ~constructors:(Hashtbl.create small_tbl_size) + (* TODO: What table size to use for datatypes / constructors? *) ~only_specs:(Hashtbl.create medium_tbl_size) ~procs:(Hashtbl.create big_tbl_size) ~macros:(Hashtbl.create small_tbl_size) diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index 7f45bcfb..0388e2a9 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -239,6 +239,21 @@ and lemma = { lemma_existentials : string list; } +and datatype = { + datatype_name : string; + datatype_source_path : string option; + datatype_loc : location option; + datatype_constructors : constructor list; +} + +and constructor = { + constructor_name : string; + constructor_source_path : string option; + constructor_loc : location option; + constructor_num_fields : int; + constructor_fields : typ list; +} + and single_spec = { ss_pre : assertion * location option; ss_posts : (assertion * location option) list; diff --git a/GillianCore/gil_parser/gil_parsing.ml b/GillianCore/gil_parser/gil_parsing.ml index 781b1868..e1a079f8 100644 --- a/GillianCore/gil_parser/gil_parsing.ml +++ b/GillianCore/gil_parser/gil_parsing.ml @@ -294,7 +294,8 @@ module Make (Annot : Annot.S) = struct in Prog.make_indexed ~lemmas:ext_program.lemmas ~preds:ext_program.preds ~only_specs:ext_program.only_specs ~procs ~predecessors - ~macros:ext_program.macros ~bi_specs:ext_program.bi_specs () + ~macros:ext_program.macros ~bi_specs:ext_program.bi_specs (* TODO *) + ~datatypes:(Hashtbl.create 1) ~constructors:(Hashtbl.create 1) () let parse_literal lexbuf = parse GIL_Parser.lit_target lexbuf let parse_expression lexbuf = parse GIL_Parser.top_level_expr_target lexbuf diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index 8c89068b..a5e3f04b 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -1201,4 +1201,5 @@ let compile ~filepath WProg.{ context; predicates; lemmas; _ } = ~imports:(List.map (fun imp -> (imp, false)) WislConstants.internal_imports) ~lemmas:gil_lemmas ~preds:gil_preds ~procs:gil_procs ~proc_names ~bi_specs ~only_specs:(Hashtbl.create 1) ~macros:(Hashtbl.create 1) - ~predecessors:(Hashtbl.create 1) () + ~predecessors:(Hashtbl.create 1) () (* TODO *) + ~datatypes:(Hashtbl.create 1) ~constructors:(Hashtbl.create 1) From 0a32a1d3e8f4b14bfead7b75291f178961d3bc70 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Wed, 9 Apr 2025 20:07:32 +0100 Subject: [PATCH 07/37] Added datatype constructors to GIL expressions --- GillianCore/GIL_Syntax/Expr.ml | 4 ++++ GillianCore/GIL_Syntax/Gil_syntax.mli | 7 +++++++ GillianCore/GIL_Syntax/TypeDef__.ml | 1 + GillianCore/engine/Abstraction/MP.ml | 3 +++ GillianCore/engine/Abstraction/Normaliser.ml | 4 +++- GillianCore/engine/FOLogic/Reduction.ml | 2 ++ GillianCore/engine/FOLogic/typing.ml | 2 ++ GillianCore/engine/concrete_semantics/CExprEval.ml | 5 +++-- GillianCore/engine/symbolic_semantics/SState.ml | 1 + GillianCore/smt/smt.ml | 1 + 10 files changed, 27 insertions(+), 3 deletions(-) diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index 650e2b70..f9fc4b48 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -16,6 +16,7 @@ type t = TypeDef__.expr = (** Existential quantification. *) | ForAll of (string * Type.t option) list * t (** Universal quantification. *) + | Constructor of string * t list (** Datatype constructor *) [@@deriving eq, ord] let to_yojson = TypeDef__.expr_to_yojson @@ -377,6 +378,7 @@ let rec map_opt match map_e e with | Some e' -> Some (ForAll (bt, e')) | _ -> None) + | Constructor (n, les) -> aux les (fun les -> Constructor (n, les)) in Option.map f_after mapped_expr @@ -414,6 +416,7 @@ let rec pp fmt e = Fmt.pf fmt "(forall %a . %a)" (Fmt.list ~sep:Fmt.comma pp_var_with_type) bt pp e + | Constructor (n, ll) -> Fmt.pf fmt "%s(%a)" n (Fmt.list ~sep:Fmt.comma pp) ll let rec full_pp fmt e = match e with @@ -476,6 +479,7 @@ let rec is_concrete (le : t) : bool = | BinOp (e1, _, e2) -> loop [ e1; e2 ] | LstSub (e1, e2, e3) -> loop [ e1; e2; e3 ] | NOp (_, les) | EList les | ESet les -> loop les + | Constructor (_, _) -> false (* TODO: ?? *) let is_concrete_zero_i : t -> bool = function | Lit (Int z) -> Z.equal Z.zero z diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index e15b83d4..15901d53 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -250,6 +250,7 @@ module Expr : sig | Exists of (string * Type.t option) list * t (** Existential quantification. *) | ForAll of (string * Type.t option) list * t + | Constructor of string * t list [@@deriving yojson] (** {2: Helpers for building expressions} @@ -1177,6 +1178,7 @@ module Visitors : sig ; visit_Car : 'c -> UnOp.t -> UnOp.t ; visit_Cdr : 'c -> UnOp.t -> UnOp.t ; visit_Constant : 'c -> Literal.t -> Constant.t -> Literal.t + ; visit_Constructor : 'c -> Expr.t -> string -> Expr.t list -> Expr.t ; visit_ECall : 'c -> 'f Cmd.t -> @@ -1436,6 +1438,7 @@ module Visitors : sig method visit_Car : 'c -> UnOp.t -> UnOp.t method visit_Cdr : 'c -> UnOp.t -> UnOp.t method visit_Constant : 'c -> Literal.t -> Constant.t -> Literal.t + method visit_Constructor : 'c -> Expr.t -> string -> Expr.t list -> Expr.t method visit_ECall : 'c -> 'f Cmd.t -> string -> Expr.t -> Expr.t list -> 'f option -> 'f Cmd.t @@ -1730,6 +1733,7 @@ module Visitors : sig ; visit_Car : 'c -> 'f ; visit_Cdr : 'c -> 'f ; visit_Constant : 'c -> Constant.t -> 'f + ; visit_Constructor : 'c -> string -> Expr.t list -> 'f ; visit_IDiv : 'c -> 'f ; visit_FDiv : 'c -> 'f ; visit_ECall : @@ -1953,6 +1957,7 @@ module Visitors : sig method visit_Car : 'c -> 'f method visit_Cdr : 'c -> 'f method visit_Constant : 'c -> Constant.t -> 'f + method visit_Constructor : 'c -> string -> Expr.t list -> 'f method visit_IDiv : 'c -> 'f method visit_FDiv : 'c -> 'f @@ -2178,6 +2183,7 @@ module Visitors : sig ; visit_Car : 'c -> unit ; visit_Cdr : 'c -> unit ; visit_Constant : 'c -> Constant.t -> unit + ; visit_Constructor : 'c -> string -> Expr.t list -> unit ; visit_ECall : 'c -> string -> Expr.t -> Expr.t list -> 'f option -> unit ; visit_EList : 'c -> Expr.t list -> unit @@ -2400,6 +2406,7 @@ module Visitors : sig method visit_Car : 'c -> unit method visit_Cdr : 'c -> unit method visit_Constant : 'c -> Constant.t -> unit + method visit_Constructor : 'c -> string -> Expr.t list -> unit method visit_ECall : 'c -> string -> Expr.t -> Expr.t list -> 'f option -> unit diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index 0388e2a9..fd75ac47 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -152,6 +152,7 @@ and expr = | ESet of expr list | Exists of (string * typ option) list * expr | ForAll of (string * typ option) list * expr + | Constructor of string * expr list and assertion_atom = | Emp diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index 8d594c43..c4b0b590 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -153,6 +153,7 @@ let rec missing_expr (kb : KB.t) (e : Expr.t) : KB.t list = KB.add_seq (List.to_seq bt |> Seq.map (fun (x, _) -> Expr.LVar x)) kb in f' kb' e + | Constructor _ -> failwith "TODO" (* TODO *) (** [is_known kb e] returns true if the expression [e] is known under knowledge base [kb], and false otherwise *) @@ -170,6 +171,7 @@ let rec learn_expr (e : Expr.t) : outs = let f = learn_expr kb in match e with + | Constructor _ -> failwith "TODO" (* TODO *) (* Literals, abstract locations, sublists, and sets are never invertible *) | Lit _ | LstSub _ | ESet _ -> [] (* Nothing is learned if the top-level expr is a program or a logical variable *) @@ -441,6 +443,7 @@ let rec simple_ins_formula (kb : KB.t) (pf : Expr.t) : KB.t list = let ins = List.map (fun ins -> KB.diff ins binders) ins_pf in List.map minimise_matchables ins | Lit _ | PVar _ | LVar _ | ALoc _ | LstSub _ | NOp _ | EList _ | ESet _ -> [] + | Constructor _ -> failwith "TODO" (* TODO *) (** [ins_outs_formula kb pf] returns a list of possible ins-outs pairs for a given formula [pf] under a given knowledge base [kb] *) diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 7182ef4f..7bda476d 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -101,6 +101,7 @@ module Make (SPState : PState.S) = struct let result : Expr.t = match (le : Expr.t) with + | Constructor _ -> failwith "TODO" (* TODO *) | Lit _ -> le | LVar lvar -> Option.value ~default:(Expr.LVar lvar) (SESubst.get subst le) @@ -176,7 +177,8 @@ module Make (SPState : PState.S) = struct | BinOp (_, _, _) | UnOp (_, _) -> UnOp (TypeOf, nle1) | Exists _ | ForAll _ -> Lit (Type BooleanType) | EList _ | LstSub _ | NOp (LstCat, _) -> Lit (Type ListType) - | NOp (_, _) | ESet _ -> Lit (Type SetType)) + | NOp (_, _) | ESet _ -> Lit (Type SetType) + | Constructor _ -> failwith "TODO" (* TODO *)) | _ -> UnOp (uop, nle1))) | EList le_list -> let n_le_list = List.map f le_list in diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index e1779fc8..5b6354d4 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -64,6 +64,7 @@ let rec normalise_list_expressions (le : Expr.t) : Expr.t = let result = let exn msg = ReductionException (le, msg) in match (le : Expr.t) with + | Constructor _ -> failwith "TODO" (* TODO *) (* Literals **) | Lit (LList lst) -> Expr.from_lit_list (LList lst) (* Literals, variables, alocs *) @@ -880,6 +881,7 @@ and reduce_lexpr_loop let result : Expr.t = match le with + | Constructor _ -> failwith "TODO" (* ------------------------- Base cases ------------------------- *) diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index edb1327e..585ef5bf 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -153,6 +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 + | Constructor _ -> failwith "TODO" (* TODO *) | Exists (bt, le) | ForAll (bt, le) -> if not (tt = BooleanType) then false else @@ -474,6 +475,7 @@ module Type_lexpr = struct let all_typable = typable_list ?target_type:(Some ListType) les in if all_typable then (Some ListType, true) else def_neg | LstSub (le1, le2, le3) -> type_lstsub gamma le1 le2 le3 + | Constructor _ -> failwith "TODO" (* TODO *) in result diff --git a/GillianCore/engine/concrete_semantics/CExprEval.ml b/GillianCore/engine/concrete_semantics/CExprEval.ml index 95b0ce28..054b0adf 100644 --- a/GillianCore/engine/concrete_semantics/CExprEval.ml +++ b/GillianCore/engine/concrete_semantics/CExprEval.ml @@ -330,10 +330,11 @@ 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 _ | ForAll _ -> + | ALoc _ | LVar _ | ESet _ | Exists _ | ForAll _ | Constructor _ -> raise (Exceptions.Impossible - "eval_expr concrete: aloc, lvar, set, exists or for all") + "eval_expr concrete: aloc, lvar, set, exists, for all or \ + constructor") with | TypeError msg -> raise (TypeError (msg ^ Fmt.str " in %a" Expr.pp e)) | EvaluationError msg -> diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index f1bbf84b..e31232a7 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -254,6 +254,7 @@ module Make (SMemory : SMemory.S) : | Exists (bt, e) -> Exists (bt, f e) | ForAll (bt, e) -> ForAll (bt, f e) | Lit _ | LVar _ | ALoc _ -> expr + | Constructor _ -> failwith "TODO" (* TODO *) in (* Perform reduction *) if no_reduce then result diff --git a/GillianCore/smt/smt.ml b/GillianCore/smt/smt.ml index 3d1b5d42..b0a580d9 100644 --- a/GillianCore/smt/smt.ml +++ b/GillianCore/smt/smt.ml @@ -778,6 +778,7 @@ let rec encode_logical_expression | ForAll (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression ~mk_quant:forall ~gamma ~llen_lvars ~list_elem_vars bt e + | Constructor _ -> failwith "TODO" (* TODO *) let encode_assertion_top_level ~(gamma : typenv) From 2d20476a040097e14dfe852f39446972791e04eb Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Wed, 9 Apr 2025 20:27:51 +0100 Subject: [PATCH 08/37] Extended GIL types with datatypes --- GillianCore/GIL_Syntax/Gil_syntax.mli | 8 ++++++++ GillianCore/GIL_Syntax/Type.ml | 2 ++ GillianCore/GIL_Syntax/TypeDef__.ml | 1 + GillianCore/smt/smt.ml | 3 +++ 4 files changed, 14 insertions(+) diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 15901d53..554224fb 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -61,6 +61,7 @@ module Type : sig | ListType (** Type of lists *) | TypeType (** Type of types *) | SetType (** Type of sets *) + | Datatype of string [@@deriving yojson, eq, show] (** Printer *) @@ -1222,6 +1223,7 @@ module Visitors : sig Expr.t list -> Expr.t list -> Asrt.atom + ; visit_Datatype : 'c -> Type.t -> string -> Type.t ; visit_Wand : 'c -> Asrt.atom -> @@ -1479,6 +1481,8 @@ module Visitors : sig method visit_CorePred : 'c -> Asrt.atom -> string -> Expr.t list -> Expr.t list -> Asrt.atom + method visit_Datatype : 'c -> Type.t -> string -> Type.t + method visit_Wand : 'c -> Asrt.atom -> @@ -1756,6 +1760,7 @@ module Visitors : sig 'f ; visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> 'f ; visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> 'f + ; visit_Datatype : 'c -> string -> 'f ; visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> 'f ; visit_GUnfold : 'c -> string -> 'f ; visit_Goto : 'c -> 'g -> 'f @@ -1984,6 +1989,7 @@ module Visitors : sig 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_Datatype : 'c -> string -> '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 @@ -2212,6 +2218,7 @@ module Visitors : sig unit ; visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> unit ; visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> unit + ; visit_Datatype : 'c -> string -> unit ; visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> unit ; visit_GUnfold : 'c -> string -> unit @@ -2439,6 +2446,7 @@ module Visitors : sig 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_Datatype : 'c -> string -> unit method visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> unit diff --git a/GillianCore/GIL_Syntax/Type.ml b/GillianCore/GIL_Syntax/Type.ml index f2d11fd0..18b47a22 100644 --- a/GillianCore/GIL_Syntax/Type.ml +++ b/GillianCore/GIL_Syntax/Type.ml @@ -15,6 +15,7 @@ type t = TypeDef__.typ = | ListType (** Type of lists *) | TypeType (** Type of types *) | SetType (** Type of sets *) + | Datatype of string [@@deriving yojson, eq, ord, show] (** Print *) @@ -32,6 +33,7 @@ let str (x : t) = | ListType -> "List" | TypeType -> "Type" | SetType -> "Set" + | Datatype s -> s module Set = Set.Make (struct type nonrec t = t diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index fd75ac47..fecd32d3 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -29,6 +29,7 @@ and typ = | ListType | TypeType | SetType + | Datatype of string and literal = | Undefined diff --git a/GillianCore/smt/smt.ml b/GillianCore/smt/smt.ml index b0a580d9..3aa08642 100644 --- a/GillianCore/smt/smt.ml +++ b/GillianCore/smt/smt.ml @@ -308,6 +308,7 @@ let encode_type (t : Type.t) = | ListType -> Type_operations.List.construct | TypeType -> Type_operations.Type.construct | SetType -> Type_operations.Set.construct + | Datatype _ -> failwith "TODO" (* TODO *) with _ -> Fmt.failwith "DEATH: encode_type with arg: %a" Type.pp t module Encoding = struct @@ -327,6 +328,7 @@ module Encoding = struct | UndefinedType | NoneType | EmptyType | NullType -> t_gil_literal | SetType -> t_gil_literal_set | TypeType -> t_gil_type + | Datatype _ -> failwith "TODO" type t = { consts : (string * sexp) Hashset.t; [@default Hashset.empty ()] @@ -409,6 +411,7 @@ module Encoding = struct | UndefinedType | NullType | EmptyType | NoneType | SetType -> Fmt.failwith "Cannot simple-wrap value of type %s" (Gil_syntax.Type.str typ) + | Datatype _ -> failwith "TODO" in construct expr | Extended_wrapped -> Ext_lit_operations.Gil_sing_elem.access expr From 9232c71e626a3f70ff4e14d80f7d911cfcb55021 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Sat, 12 Apr 2025 16:37:28 +0100 Subject: [PATCH 09/37] Refactored GIL Type.DatatypeType --- GillianCore/GIL_Syntax/Gil_syntax.mli | 14 +++++++------- GillianCore/GIL_Syntax/Type.ml | 4 ++-- GillianCore/GIL_Syntax/TypeDef__.ml | 2 +- GillianCore/smt/smt.ml | 6 +++--- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 554224fb..2cb5d391 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -61,7 +61,7 @@ module Type : sig | ListType (** Type of lists *) | TypeType (** Type of types *) | SetType (** Type of sets *) - | Datatype of string + | DatatypeType of string [@@deriving yojson, eq, show] (** Printer *) @@ -1223,7 +1223,7 @@ module Visitors : sig Expr.t list -> Expr.t list -> Asrt.atom - ; visit_Datatype : 'c -> Type.t -> string -> Type.t + ; visit_DatatypeType : 'c -> Type.t -> string -> Type.t ; visit_Wand : 'c -> Asrt.atom -> @@ -1481,7 +1481,7 @@ module Visitors : sig method visit_CorePred : 'c -> Asrt.atom -> string -> Expr.t list -> Expr.t list -> Asrt.atom - method visit_Datatype : 'c -> Type.t -> string -> Type.t + method visit_DatatypeType : 'c -> Type.t -> string -> Type.t method visit_Wand : 'c -> @@ -1760,7 +1760,7 @@ module Visitors : sig 'f ; visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> 'f ; visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> 'f - ; visit_Datatype : 'c -> string -> 'f + ; visit_DatatypeType : 'c -> string -> 'f ; visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> 'f ; visit_GUnfold : 'c -> string -> 'f ; visit_Goto : 'c -> 'g -> 'f @@ -1989,7 +1989,7 @@ module Visitors : sig 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_Datatype : 'c -> string -> 'f + method visit_DatatypeType : 'c -> string -> '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 @@ -2218,7 +2218,7 @@ module Visitors : sig unit ; visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> unit ; visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> unit - ; visit_Datatype : 'c -> string -> unit + ; visit_DatatypeType : 'c -> string -> unit ; visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> unit ; visit_GUnfold : 'c -> string -> unit @@ -2446,7 +2446,7 @@ module Visitors : sig 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_Datatype : 'c -> string -> unit + method visit_DatatypeType : 'c -> string -> unit method visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> unit diff --git a/GillianCore/GIL_Syntax/Type.ml b/GillianCore/GIL_Syntax/Type.ml index 18b47a22..3b1b2a04 100644 --- a/GillianCore/GIL_Syntax/Type.ml +++ b/GillianCore/GIL_Syntax/Type.ml @@ -15,7 +15,7 @@ type t = TypeDef__.typ = | ListType (** Type of lists *) | TypeType (** Type of types *) | SetType (** Type of sets *) - | Datatype of string + | DatatypeType of string [@@deriving yojson, eq, ord, show] (** Print *) @@ -33,7 +33,7 @@ let str (x : t) = | ListType -> "List" | TypeType -> "Type" | SetType -> "Set" - | Datatype s -> s + | DatatypeType s -> s module Set = Set.Make (struct type nonrec t = t diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index fecd32d3..6d05ddd5 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -29,7 +29,7 @@ and typ = | ListType | TypeType | SetType - | Datatype of string + | DatatypeType of string and literal = | Undefined diff --git a/GillianCore/smt/smt.ml b/GillianCore/smt/smt.ml index 3aa08642..3aeffc83 100644 --- a/GillianCore/smt/smt.ml +++ b/GillianCore/smt/smt.ml @@ -308,7 +308,7 @@ let encode_type (t : Type.t) = | ListType -> Type_operations.List.construct | TypeType -> Type_operations.Type.construct | SetType -> Type_operations.Set.construct - | Datatype _ -> failwith "TODO" (* TODO *) + | DatatypeType _ -> failwith "TODO" (* TODO *) with _ -> Fmt.failwith "DEATH: encode_type with arg: %a" Type.pp t module Encoding = struct @@ -328,7 +328,7 @@ module Encoding = struct | UndefinedType | NoneType | EmptyType | NullType -> t_gil_literal | SetType -> t_gil_literal_set | TypeType -> t_gil_type - | Datatype _ -> failwith "TODO" + | DatatypeType _ -> failwith "TODO" type t = { consts : (string * sexp) Hashset.t; [@default Hashset.empty ()] @@ -411,7 +411,7 @@ module Encoding = struct | UndefinedType | NullType | EmptyType | NoneType | SetType -> Fmt.failwith "Cannot simple-wrap value of type %s" (Gil_syntax.Type.str typ) - | Datatype _ -> failwith "TODO" + | DatatypeType _ -> failwith "TODO" in construct expr | Extended_wrapped -> Ext_lit_operations.Gil_sing_elem.access expr From e5647f93f632ab39371fbfa69b15655800e39c23 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Tue, 15 Apr 2025 20:51:55 +0100 Subject: [PATCH 10/37] Compilation of wisl datatypes to gil --- GillianCore/GIL_Syntax/Constructor.ml | 2 +- GillianCore/GIL_Syntax/Gil_syntax.mli | 8 ++-- GillianCore/GIL_Syntax/TypeDef__.ml | 2 +- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 60 ++++++++++++++++++++++---- wisl/lib/syntax/WLExpr.ml | 1 + wisl/lib/syntax/WType.ml | 6 +-- 6 files changed, 61 insertions(+), 18 deletions(-) diff --git a/GillianCore/GIL_Syntax/Constructor.ml b/GillianCore/GIL_Syntax/Constructor.ml index 9b390e76..e5505061 100644 --- a/GillianCore/GIL_Syntax/Constructor.ml +++ b/GillianCore/GIL_Syntax/Constructor.ml @@ -3,5 +3,5 @@ type t = TypeDef__.constructor = { constructor_source_path : string option; constructor_loc : Location.t option; constructor_num_fields : int; - constructor_fields : Type.t list; + constructor_fields : Type.t option list; } diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 2cb5d391..4b33442b 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -48,7 +48,7 @@ end module Type : sig (** GIL Types *) - type t = + type t = TypeDef__.typ = | UndefinedType (** Type of Undefined *) | NullType (** Type of Null *) | EmptyType (** Type of Empty *) @@ -725,7 +725,7 @@ module Lemma : sig end module Datatype : sig - type t = { + type t = TypeDef__.datatype = { datatype_name : string; datatype_source_path : string option; datatype_loc : Location.t option; @@ -734,12 +734,12 @@ module Datatype : sig end module Constructor : sig - type t = { + type t = TypeDef__.constructor = { constructor_name : string; constructor_source_path : string option; constructor_loc : Location.t option; constructor_num_fields : int; - constructor_fields : Type.t list; + constructor_fields : Type.t option list; } end diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index 6d05ddd5..14556105 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -253,7 +253,7 @@ and constructor = { constructor_source_path : string option; constructor_loc : location option; constructor_num_fields : int; - constructor_fields : typ list; + constructor_fields : typ option list; } and single_spec = { diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index a5e3f04b..0e61d319 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -27,9 +27,8 @@ let compile_type t = | WPtr -> Some Type.ObjectType | WInt -> Some Type.IntType | WSet -> Some Type.SetType - | WAny -> None - | WDatatype _ -> None) -(*TODO ??*) + | WDatatype n -> Some (Type.DatatypeType n) + | WAny -> None) let compile_binop b = WBinOp.( @@ -237,9 +236,11 @@ let rec compile_lexpr ?(fname = "main") (lexpr : WLExpr.t) : list_split_3 (List.map compile_lexpr l) in (List.concat gvars, List.concat asrtsl, Expr.ESet comp_exprs) - | LConstructor _ -> - (* TODO *) - failwith "TODO") + | LConstructor (n, l) -> + let gvars, asrtsl, comp_exprs = + list_split_3 (List.map compile_lexpr l) + in + (List.concat gvars, List.concat asrtsl, Expr.Constructor (n, comp_exprs))) (* TODO: compile_lformula should return also the list of created existentials *) let rec compile_lformula ?(fname = "main") formula : Asrt.t * Expr.t = @@ -1149,8 +1150,38 @@ let compile_lemma lemma_existentials; } -let compile ~filepath WProg.{ context; predicates; lemmas; _ } = - (* TODO: Compile user defined datatypes *) +let compile_constructor + filepath + WConstructor.{ constructor_name; constructor_fields; constructor_loc; _ } = + let comp_fields = List.map compile_type constructor_fields in + let constructor_loc = Some (CodeLoc.to_location constructor_loc) in + let constructor_num_fields = List.length comp_fields in + Constructor. + { + constructor_name; + constructor_source_path = Some filepath; + constructor_loc; + constructor_num_fields; + constructor_fields = comp_fields; + } + +let compile_datatype + filepath + WDatatype.{ datatype_name; datatype_constructors; datatype_loc; _ } = + let comp_constructors = + List.map (compile_constructor filepath) datatype_constructors + in + let datatype_loc = Some (CodeLoc.to_location datatype_loc) in + ( Datatype. + { + datatype_name; + datatype_source_path = Some filepath; + datatype_loc; + datatype_constructors = comp_constructors; + }, + comp_constructors ) + +let compile ~filepath WProg.{ context; predicates; lemmas; datatypes } = (* stuff useful to build hashtables *) let make_hashtbl get_name deflist = let hashtbl = Hashtbl.create (List.length deflist) in @@ -1162,6 +1193,10 @@ let compile ~filepath WProg.{ context; predicates; lemmas; _ } = let get_proc_name proc = proc.Proc.proc_name in let get_pred_name pred = pred.Pred.pred_name in let get_lemma_name lemma = lemma.Lemma.lemma_name in + let get_datatype_name datatype = datatype.Datatype.datatype_name in + let get_constructor_name constructor = + constructor.Constructor.constructor_name + in (* compile everything *) let comp_context = List.map (compile_function filepath) context in let comp_preds = List.map (compile_pred filepath) predicates in @@ -1170,10 +1205,17 @@ let compile ~filepath WProg.{ context; predicates; lemmas; _ } = (fun lemma -> compile_lemma filepath (preprocess_lemma lemma)) lemmas in + let comp_datatypes, comp_constructors = + List.split (List.map (compile_datatype filepath) datatypes) + in (* build the hashtables *) let gil_procs = make_hashtbl get_proc_name (List.concat comp_context) in let gil_preds = make_hashtbl get_pred_name comp_preds in let gil_lemmas = make_hashtbl get_lemma_name comp_lemmas in + let gil_datatypes = make_hashtbl get_datatype_name comp_datatypes in + let gil_constructors = + make_hashtbl get_constructor_name (List.concat comp_constructors) + in let proc_names = Hashtbl.fold (fun s _ l -> s :: l) gil_procs [] in let bi_specs = Hashtbl.create 1 in if Gillian.Utils.(Exec_mode.is_biabduction_exec !Config.current_exec_mode) @@ -1202,4 +1244,4 @@ let compile ~filepath WProg.{ context; predicates; lemmas; _ } = ~lemmas:gil_lemmas ~preds:gil_preds ~procs:gil_procs ~proc_names ~bi_specs ~only_specs:(Hashtbl.create 1) ~macros:(Hashtbl.create 1) ~predecessors:(Hashtbl.create 1) () (* TODO *) - ~datatypes:(Hashtbl.create 1) ~constructors:(Hashtbl.create 1) + ~datatypes:gil_datatypes ~constructors:gil_constructors diff --git a/wisl/lib/syntax/WLExpr.ml b/wisl/lib/syntax/WLExpr.ml index 1892fe77..7ac0da64 100644 --- a/wisl/lib/syntax/WLExpr.ml +++ b/wisl/lib/syntax/WLExpr.ml @@ -50,6 +50,7 @@ let rec get_by_id id lexpr = | LUnOp (_, lep) -> getter lep | LEList lel -> list_visitor lel | LESet lel -> list_visitor lel + | LConstructor (_, lel) -> list_visitor lel | _ -> `None in let self_or_none = if get_id lexpr = id then `WLExpr lexpr else `None in diff --git a/wisl/lib/syntax/WType.ml b/wisl/lib/syntax/WType.ml index 27d16631..c3b61b51 100644 --- a/wisl/lib/syntax/WType.ml +++ b/wisl/lib/syntax/WType.ml @@ -135,9 +135,9 @@ let rec infer_logic_expr knownp lexpr = TypeMap.add bare_lexpr WList (List.fold_left infer_logic_expr knownp lel) | LESet lel -> TypeMap.add bare_lexpr WSet (List.fold_left infer_logic_expr knownp lel) - | LConstructor (_, lel) -> - (*TODO ??*) - TypeMap.add bare_lexpr WSet (List.fold_left infer_logic_expr knownp lel) + | LConstructor (n, lel) -> + TypeMap.add bare_lexpr (WDatatype n) + (List.fold_left infer_logic_expr knownp lel) (** Single step of inference for that gets a TypeMap from a single assertion *) let rec infer_single_assert_step asser known = From 6b06123523c703e46f7d9663cd4760868a8d53b4 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Fri, 18 Apr 2025 00:19:57 +0100 Subject: [PATCH 11/37] Added type inference of constructors --- GillianCore/GIL_Syntax/Constructor.ml | 2 + GillianCore/GIL_Syntax/Expr.ml | 3 +- GillianCore/GIL_Syntax/Gil_syntax.mli | 2 + GillianCore/GIL_Syntax/TypeDef__.ml | 1 + GillianCore/engine/FOLogic/type_env.ml | 85 ++++++++++++++----- GillianCore/engine/FOLogic/type_env.mli | 9 +- GillianCore/engine/FOLogic/typing.ml | 106 +++++++++++++++++------- GillianCore/engine/FOLogic/typing.mli | 5 +- wisl/lib/ParserAndCompiler/WParser.mly | 24 ++++-- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 10 ++- wisl/lib/syntax/WConstructor.ml | 1 + wisl/lib/syntax/WConstructor.mli | 1 + 12 files changed, 185 insertions(+), 64 deletions(-) diff --git a/GillianCore/GIL_Syntax/Constructor.ml b/GillianCore/GIL_Syntax/Constructor.ml index e5505061..3f34ab7f 100644 --- a/GillianCore/GIL_Syntax/Constructor.ml +++ b/GillianCore/GIL_Syntax/Constructor.ml @@ -4,4 +4,6 @@ type t = TypeDef__.constructor = { constructor_loc : Location.t option; constructor_num_fields : int; constructor_fields : Type.t option list; + constructor_datatype : string; } +[@@deriving yojson] diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index f9fc4b48..34bd24c2 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -479,7 +479,8 @@ let rec is_concrete (le : t) : bool = | BinOp (e1, _, e2) -> loop [ e1; e2 ] | LstSub (e1, e2, e3) -> loop [ e1; e2; e3 ] | NOp (_, les) | EList les | ESet les -> loop les - | Constructor (_, _) -> false (* TODO: ?? *) + | Constructor (_, _) -> false +(* TODO: Pretty sure constructors are not concrete, but double check *) let is_concrete_zero_i : t -> bool = function | Lit (Int z) -> Z.equal Z.zero z diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 4b33442b..88428d4a 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -740,7 +740,9 @@ module Constructor : sig constructor_loc : Location.t option; constructor_num_fields : int; constructor_fields : Type.t option list; + constructor_datatype : string; } + [@@deriving yojson] end (** @canonical Gillian.Gil_syntax.Macro *) diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index 14556105..c7534681 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -254,6 +254,7 @@ and constructor = { constructor_loc : location option; constructor_num_fields : int; constructor_fields : typ option list; + constructor_datatype : string; } and single_spec = { diff --git a/GillianCore/engine/FOLogic/type_env.ml b/GillianCore/engine/FOLogic/type_env.ml index 2cb62659..bed495cc 100644 --- a/GillianCore/engine/FOLogic/type_env.ml +++ b/GillianCore/engine/FOLogic/type_env.ml @@ -4,9 +4,14 @@ open Names open SVal module L = Logging -type t = (string, Type.t) Hashtbl.t [@@deriving yojson] +type constructors_tbl_t = (string, Constructor.t) Hashtbl.t [@@deriving yojson] -let as_hashtbl x = x +type t = { + var_types: (string, Type.t) Hashtbl.t; + constructor_defs: constructors_tbl_t; +} [@@deriving yojson] + +let as_hashtbl x = x.var_types (*************************************) (** Typing Environment Functions **) @@ -14,55 +19,64 @@ let as_hashtbl x = x (*************************************) (* Initialisation *) -let init () : t = Hashtbl.create Config.medium_tbl_size +let init ?(constructor_defs = Hashtbl.create Config.medium_tbl_size) () : t = { + var_types = Hashtbl.create Config.medium_tbl_size; + constructor_defs; +} (* Copy *) -let copy (x : t) : t = Hashtbl.copy x +let copy { + var_types; + constructor_defs; + } : t = { + var_types = Hashtbl.copy var_types; + constructor_defs = Hashtbl.copy constructor_defs; +} (* Type of a variable *) -let get (x : t) (var : string) : Type.t option = Hashtbl.find_opt x var +let get (x : t) (var : string) : Type.t option = Hashtbl.find_opt x.var_types var (* Membership *) -let mem (x : t) (v : string) : bool = Hashtbl.mem x v +let mem (x : t) (v : string) : bool = Hashtbl.mem x.var_types v (* Empty *) -let empty (x : t) : bool = Hashtbl.length x == 0 +let empty (x : t) : bool = Hashtbl.length x.var_types == 0 (* Type of a variable *) let get_unsafe (x : t) (var : string) : Type.t = - match Hashtbl.find_opt x var with + match Hashtbl.find_opt x.var_types var with | Some t -> t | None -> raise (Failure ("Type_env.get_unsafe: variable " ^ var ^ " not found.")) (* Get all matchable elements *) let matchables (x : t) : SS.t = - Hashtbl.fold (fun var _ ac -> SS.add var ac) x SS.empty + Hashtbl.fold (fun var _ ac -> SS.add var ac) x.var_types SS.empty (* Get all variables *) let vars (x : t) : SS.t = - Hashtbl.fold (fun var _ ac -> SS.add var ac) x SS.empty + Hashtbl.fold (fun var _ ac -> SS.add var ac) x.var_types SS.empty (* Get all logical variables *) let lvars (x : t) : SS.t = Hashtbl.fold (fun var _ ac -> if is_lvar_name var then SS.add var ac else ac) - x SS.empty + x.var_types SS.empty (* Get all variables of specific type *) let get_vars_of_type (x : t) (tt : Type.t) : string list = Hashtbl.fold (fun var t ac_vars -> if t = tt then var :: ac_vars else ac_vars) - x [] + x.var_types [] (* Get all var-type pairs as a list *) -let get_var_type_pairs (x : t) : (string * Type.t) Seq.t = Hashtbl.to_seq x +let get_var_type_pairs (x : t) : (string * Type.t) Seq.t = Hashtbl.to_seq x.var_types (* Iteration *) -let iter (x : t) (f : string -> Type.t -> unit) : unit = Hashtbl.iter f x +let iter (x : t) (f : string -> Type.t -> unit) : unit = Hashtbl.iter f x.var_types let fold (x : t) (f : string -> Type.t -> 'a -> 'a) (init : 'a) : 'a = - Hashtbl.fold f x init + Hashtbl.fold f x.var_types init let pp fmt tenv = let pp_pair fmt (v, vt) = Fmt.pf fmt "(%s: %s)" v (Type.str vt) in @@ -81,20 +95,20 @@ let pp_by_need vars fmt tenv = let update (te : t) (x : string) (t : Type.t) : unit = match get te x with - | None -> Hashtbl.replace te x t + | None -> Hashtbl.replace te.var_types x t | Some t' when t' = t -> () | Some t' -> Fmt.failwith "Type_env update: Conflict: %s has type %s but required extension is %s" x (Type.str t') (Type.str t) -let remove (te : t) (x : string) : unit = Hashtbl.remove te x +let remove (te : t) (x : string) : unit = Hashtbl.remove te.var_types x (* Extend gamma with more_gamma *) let extend (x : t) (y : t) : unit = iter y (fun v t -> - match Hashtbl.find_opt x v with - | None -> Hashtbl.replace x v t + match Hashtbl.find_opt x.var_types v with + | None -> Hashtbl.replace x.var_types v t | Some t' -> if t <> t' then raise (Failure "Typing environment cannot be extended.")) @@ -140,7 +154,7 @@ let to_list_expr (x : t) : (Expr.t * Type.t) list = (fun x t (pairs : (Expr.t * Type.t) list) -> if Names.is_lvar_name x then (LVar x, t) :: pairs else (PVar x, t) :: pairs) - x [] + x.var_types [] in le_type_pairs @@ -148,13 +162,13 @@ let to_list (x : t) : (Var.t * Type.t) list = let le_type_pairs = Hashtbl.fold (fun x t (pairs : (Var.t * Type.t) list) -> (x, t) :: pairs) - x [] + x.var_types [] in le_type_pairs let reset (x : t) (reset : (Var.t * Type.t) list) = - Hashtbl.clear x; - List.iter (fun (y, t) -> Hashtbl.replace x y t) reset + Hashtbl.clear x.var_types; + List.iter (fun (y, t) -> Hashtbl.replace x.var_types y t) reset let is_well_formed (_ : t) : bool = true @@ -162,3 +176,28 @@ let filter_with_info relevant_info (x : t) = let pvars, lvars, locs = relevant_info in let relevant = List.fold_left SS.union SS.empty [ pvars; lvars; locs ] in filter x (fun x -> SS.mem x relevant) + + +(*************************************) +(** Typing Environment Functions **) + +(*************************************) + +let get_constructor_type (x : t) (cname : string) : Type.t option = + let constructor = Hashtbl.find_opt x.constructor_defs cname in + Option.map (fun (c : Constructor.t) -> Type.DatatypeType c.constructor_datatype) constructor + +let get_constructor_type_unsafe (x : t) (cname : string) : Type.t = + let constructor = Hashtbl.find_opt x.constructor_defs cname in + match constructor with + | Some c -> Type.DatatypeType c.constructor_datatype + | None -> + raise (Failure ("Type_env.get_constructor_type_unsafe: constructor " ^ cname ^ " not found.")) + +let get_constructor_field_types (x : t) (cname : string) : Type.t option list option = + let constructor = Hashtbl.find_opt x.constructor_defs cname in + Option.map (fun (c : Constructor.t) -> c.constructor_fields) constructor + +let copy_constructors (x : t) : t = + let constructor_defs = Hashtbl.copy x.constructor_defs in + init ~constructor_defs () diff --git a/GillianCore/engine/FOLogic/type_env.mli b/GillianCore/engine/FOLogic/type_env.mli index c2d55c89..a5c54981 100644 --- a/GillianCore/engine/FOLogic/type_env.mli +++ b/GillianCore/engine/FOLogic/type_env.mli @@ -7,6 +7,8 @@ open SVal (** @canonical Gillian.Symbolic.Type_env.t *) type t [@@deriving yojson] +type constructors_tbl_t [@@deriving yojson] + val as_hashtbl : t -> (string, Type.t) Hashtbl.t val copy : t -> t val extend : t -> t -> unit @@ -18,7 +20,7 @@ val get : t -> string -> Type.t option val get_unsafe : t -> string -> Type.t val get_var_type_pairs : t -> (string * Type.t) Seq.t val get_vars_of_type : t -> Type.t -> string list -val init : unit -> t +val init : ?constructor_defs:constructors_tbl_t -> unit -> t val mem : t -> string -> bool val empty : t -> bool val pp : Format.formatter -> t -> unit @@ -38,3 +40,8 @@ val is_well_formed : t -> bool val filter_with_info : Containers.SS.t * Containers.SS.t * Containers.SS.t -> t -> t + +val get_constructor_type : t -> string -> Type.t option +val get_constructor_type_unsafe : t -> string -> Type.t +val get_constructor_field_types : t -> string -> Type.t option list option +val copy_constructors : t -> t diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index 585ef5bf..251d78c8 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -152,8 +152,22 @@ module Infer_types_to_gamma = struct | LstSub (le1, le2, le3) -> 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 - | Constructor _ -> failwith "TODO" (* TODO *) + | BinOp (le1, op, le2) -> + infer_binop flag gamma new_gamma op le1 le2 tt + | Constructor (n, les) -> ( + let field_types = Type_env.get_constructor_field_types gamma n in + let check_field le tt = + match tt with + | Some tt -> f le tt + | None -> true + in + match field_types with + | Some tts -> + if List.length tts <> List.length les then false + else + tt = Type_env.get_constructor_type_unsafe gamma n + && List.for_all2 check_field les tts + | None -> false) | Exists (bt, le) | ForAll (bt, le) -> if not (tt = BooleanType) then false else @@ -170,7 +184,9 @@ module Infer_types_to_gamma = struct Type_env.remove new_gamma_copy x) bt in - let ret = f' gamma_copy new_gamma_copy le BooleanType 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 -> @@ -185,15 +201,19 @@ let reverse_type_lexpr (flag : bool) (gamma : Type_env.t) (e_types : (Expr.t * Type.t) list) : Type_env.t option = - let new_gamma = Type_env.init () in + let new_gamma = Type_env.copy_constructors gamma in let ret = List.fold_left - (fun ac (e, t) -> ac && infer_types_to_gamma flag gamma new_gamma e t) + (fun ac (e, t) -> + ac && infer_types_to_gamma flag gamma new_gamma e t) true e_types in if ret then Some new_gamma else None -let safe_extend_gamma (gamma : Type_env.t) (le : Expr.t) (t : Type.t) : unit = +let safe_extend_gamma + (gamma : Type_env.t) + (le : Expr.t) + (t : Type.t) : unit = let new_gamma = reverse_type_lexpr true gamma [ (le, t) ] in match new_gamma with | Some new_gamma -> Type_env.extend gamma new_gamma @@ -297,25 +317,40 @@ module Type_lexpr = struct | false -> def_neg | true -> (None, true)) - let rec typable_list gamma ?(target_type : Type.t option) les = + let rec typable_list + gamma + ?(target_type : Type.t option) + ?(target_types : Type.t option list option) + les = let f = f gamma in - List.for_all - (fun elem -> - let t, ite = - let t, ite = f elem in - match t with - | Some _ -> (t, ite) - | None -> ( - match target_type with - | None -> (t, ite) - | Some tt -> infer_type gamma elem tt) - in - let correct_type = - let ( = ) = Option.equal Type.equal in - target_type = None || t = target_type - in - correct_type && ite) - les + let n = List.length les in + let target_types = + match target_type with + | Some tt -> List.init n (Fun.const (Some tt)) + | None -> ( + match target_types with + | Some tts -> tts + | None -> List.init n (Fun.const None)) + in + if n == List.length target_types then + List.for_all2 + (fun elem target_type -> + let t, ite = + let t, ite = f elem in + match t with + | Some _ -> (t, ite) + | None -> ( + match target_type with + | None -> (t, ite) + | Some tt -> infer_type gamma elem tt) + in + let correct_type = + let ( = ) = Option.equal Type.equal in + target_type = None || t = target_type + in + correct_type && ite) + les target_types + else false and type_unop gamma le (op : UnOp.t) e = let f = f gamma in @@ -443,14 +478,28 @@ module Type_lexpr = struct bt in let _, ite = f gamma_copy e in - if not ite then def_neg else infer_type gamma le BooleanType + if not ite then def_neg + else infer_type gamma le BooleanType + + and type_constructor gamma n les = + let tts_opt = Type_env.get_constructor_field_types gamma n in + match tts_opt with + | Some tts -> + if + typable_list gamma + ?target_types:(Some tts) les + then def_pos (Type_env.get_constructor_type gamma n) + else def_neg + | None -> def_neg (** This function returns a triple [(t_opt, b, fs)] where - [t_opt] is the type of [le] if we can find one - [b] indicates if the thing is typable - [fs] indicates the constraints that must be satisfied for [le] to be typable *) - and f (gamma : Type_env.t) (le : Expr.t) : Type.t option * bool = + and f + (gamma : Type_env.t) + (le : Expr.t) : Type.t option * bool = let typable_list = typable_list gamma in let result = @@ -465,7 +514,8 @@ module Type_lexpr = struct | EList _ -> def_pos (Some ListType) (* Sets are always typable *) | ESet _ -> def_pos (Some SetType) - | Exists (bt, e) | ForAll (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) -> @@ -475,7 +525,7 @@ module Type_lexpr = struct let all_typable = typable_list ?target_type:(Some ListType) les in if all_typable then (Some ListType, true) else def_neg | LstSub (le1, le2, le3) -> type_lstsub gamma le1 le2 le3 - | Constructor _ -> failwith "TODO" (* TODO *) + | Constructor (n, les) -> type_constructor gamma n les in result diff --git a/GillianCore/engine/FOLogic/typing.mli b/GillianCore/engine/FOLogic/typing.mli index 962ecc0d..e218bf8a 100644 --- a/GillianCore/engine/FOLogic/typing.mli +++ b/GillianCore/engine/FOLogic/typing.mli @@ -6,9 +6,10 @@ - A type if we found a necessary type - A boolean: true if the expression is typable, false if is definitely a type error - A list of corrections missing (not sure about that one ?) *) -val type_lexpr : Type_env.t -> Expr.t -> Type.t option * bool +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_expr : + Type_env.t -> Expr.t -> unit val reverse_type_lexpr : bool -> Type_env.t -> (Expr.t * Type.t) list -> Type_env.t option diff --git a/wisl/lib/ParserAndCompiler/WParser.mly b/wisl/lib/ParserAndCompiler/WParser.mly index 2bc4c51e..0cc081de 100644 --- a/wisl/lib/ParserAndCompiler/WParser.mly +++ b/wisl/lib/ParserAndCompiler/WParser.mly @@ -121,7 +121,7 @@ %type logic_expression %type logic_binop %type logic_value_with_loc -%type constructor +%type constructor %type constructor_fields %% @@ -660,12 +660,24 @@ logic_value_with_loc: datatype: | lstart = DATATYPE; ldname = IDENTIFIER; LCBRACE; - datatype_constructors = separated_nonempty_list(SEMICOLON, constructor); + raw_constructors = separated_nonempty_list(SEMICOLON, constructor); lend = RCBRACE; { let (_, datatype_name) = ldname in let datatype_loc = CodeLoc.merge lstart lend in let datatype_id = Generators.gen_id () in + let datatype_constructors = + List.map + (fun (constructor_name, constructor_fields, constructor_loc, constructor_id) -> + WConstructor.{ + constructor_name; + constructor_fields; + constructor_loc; + constructor_id; + constructor_datatype = datatype_name; + }) + raw_constructors + in WDatatype.{ datatype_name; datatype_constructors; @@ -681,12 +693,8 @@ constructor: let (constructor_fields, lend) = Option.value ~default:([], lstart) fields_lend in let constructor_loc = CodeLoc.merge lstart lend in let constructor_id = Generators.gen_id () in - WConstructor.{ - constructor_name; - constructor_fields; - constructor_loc; - constructor_id; - } + (* Constructor_datatype is added later in the datatype rule *) + (constructor_name, constructor_fields, constructor_loc, constructor_id) } constructor_fields: diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index 0e61d319..73d7afc3 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -1152,7 +1152,14 @@ let compile_lemma let compile_constructor filepath - WConstructor.{ constructor_name; constructor_fields; constructor_loc; _ } = + WConstructor. + { + constructor_name; + constructor_fields; + constructor_loc; + constructor_datatype; + _; + } = let comp_fields = List.map compile_type constructor_fields in let constructor_loc = Some (CodeLoc.to_location constructor_loc) in let constructor_num_fields = List.length comp_fields in @@ -1163,6 +1170,7 @@ let compile_constructor constructor_loc; constructor_num_fields; constructor_fields = comp_fields; + constructor_datatype; } let compile_datatype diff --git a/wisl/lib/syntax/WConstructor.ml b/wisl/lib/syntax/WConstructor.ml index 7a40783c..708ea60e 100644 --- a/wisl/lib/syntax/WConstructor.ml +++ b/wisl/lib/syntax/WConstructor.ml @@ -1,6 +1,7 @@ type t = { constructor_name : string; constructor_fields : WType.t list; + constructor_datatype : string; constructor_loc : CodeLoc.t; constructor_id : int; } diff --git a/wisl/lib/syntax/WConstructor.mli b/wisl/lib/syntax/WConstructor.mli index 7a40783c..708ea60e 100644 --- a/wisl/lib/syntax/WConstructor.mli +++ b/wisl/lib/syntax/WConstructor.mli @@ -1,6 +1,7 @@ type t = { constructor_name : string; constructor_fields : WType.t list; + constructor_datatype : string; constructor_loc : CodeLoc.t; constructor_id : int; } From fdc955441efe65796e59cb85a5e592cc7f46f648 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Fri, 18 Apr 2025 00:22:06 +0100 Subject: [PATCH 12/37] Style fix --- GillianCore/engine/FOLogic/type_env.ml | 47 ++++++++++++++------------ GillianCore/engine/FOLogic/typing.ml | 31 +++++------------ GillianCore/engine/FOLogic/typing.mli | 5 ++- 3 files changed, 37 insertions(+), 46 deletions(-) diff --git a/GillianCore/engine/FOLogic/type_env.ml b/GillianCore/engine/FOLogic/type_env.ml index bed495cc..5a7da369 100644 --- a/GillianCore/engine/FOLogic/type_env.ml +++ b/GillianCore/engine/FOLogic/type_env.ml @@ -7,9 +7,10 @@ module L = Logging type constructors_tbl_t = (string, Constructor.t) Hashtbl.t [@@deriving yojson] type t = { - var_types: (string, Type.t) Hashtbl.t; - constructor_defs: constructors_tbl_t; -} [@@deriving yojson] + var_types : (string, Type.t) Hashtbl.t; + constructor_defs : constructors_tbl_t; +} +[@@deriving yojson] let as_hashtbl x = x.var_types @@ -19,22 +20,19 @@ let as_hashtbl x = x.var_types (*************************************) (* Initialisation *) -let init ?(constructor_defs = Hashtbl.create Config.medium_tbl_size) () : t = { - var_types = Hashtbl.create Config.medium_tbl_size; - constructor_defs; -} +let init ?(constructor_defs = Hashtbl.create Config.medium_tbl_size) () : t = + { var_types = Hashtbl.create Config.medium_tbl_size; constructor_defs } (* Copy *) -let copy { - var_types; - constructor_defs; - } : t = { - var_types = Hashtbl.copy var_types; - constructor_defs = Hashtbl.copy constructor_defs; -} +let copy { var_types; constructor_defs } : t = + { + var_types = Hashtbl.copy var_types; + constructor_defs = Hashtbl.copy constructor_defs; + } (* Type of a variable *) -let get (x : t) (var : string) : Type.t option = Hashtbl.find_opt x.var_types var +let get (x : t) (var : string) : Type.t option = + Hashtbl.find_opt x.var_types var (* Membership *) let mem (x : t) (v : string) : bool = Hashtbl.mem x.var_types v @@ -70,10 +68,12 @@ let get_vars_of_type (x : t) (tt : Type.t) : string list = x.var_types [] (* Get all var-type pairs as a list *) -let get_var_type_pairs (x : t) : (string * Type.t) Seq.t = Hashtbl.to_seq x.var_types +let get_var_type_pairs (x : t) : (string * Type.t) Seq.t = + Hashtbl.to_seq x.var_types (* Iteration *) -let iter (x : t) (f : string -> Type.t -> unit) : unit = Hashtbl.iter f x.var_types +let iter (x : t) (f : string -> Type.t -> unit) : unit = + Hashtbl.iter f x.var_types let fold (x : t) (f : string -> Type.t -> 'a -> 'a) (init : 'a) : 'a = Hashtbl.fold f x.var_types init @@ -177,7 +177,6 @@ let filter_with_info relevant_info (x : t) = let relevant = List.fold_left SS.union SS.empty [ pvars; lvars; locs ] in filter x (fun x -> SS.mem x relevant) - (*************************************) (** Typing Environment Functions **) @@ -185,16 +184,22 @@ let filter_with_info relevant_info (x : t) = let get_constructor_type (x : t) (cname : string) : Type.t option = let constructor = Hashtbl.find_opt x.constructor_defs cname in - Option.map (fun (c : Constructor.t) -> Type.DatatypeType c.constructor_datatype) constructor + Option.map + (fun (c : Constructor.t) -> Type.DatatypeType c.constructor_datatype) + constructor let get_constructor_type_unsafe (x : t) (cname : string) : Type.t = let constructor = Hashtbl.find_opt x.constructor_defs cname in match constructor with | Some c -> Type.DatatypeType c.constructor_datatype | None -> - raise (Failure ("Type_env.get_constructor_type_unsafe: constructor " ^ cname ^ " not found.")) + raise + (Failure + ("Type_env.get_constructor_type_unsafe: constructor " ^ cname + ^ " not found.")) -let get_constructor_field_types (x : t) (cname : string) : Type.t option list option = +let get_constructor_field_types (x : t) (cname : string) : + Type.t option list option = let constructor = Hashtbl.find_opt x.constructor_defs cname in Option.map (fun (c : Constructor.t) -> c.constructor_fields) constructor diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index 251d78c8..df5e1201 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -152,8 +152,7 @@ module Infer_types_to_gamma = struct | LstSub (le1, le2, le3) -> 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 + | BinOp (le1, op, le2) -> infer_binop flag gamma new_gamma op le1 le2 tt | Constructor (n, les) -> ( let field_types = Type_env.get_constructor_field_types gamma n in let check_field le tt = @@ -184,9 +183,7 @@ module Infer_types_to_gamma = struct Type_env.remove new_gamma_copy x) bt in - let ret = - f' gamma_copy new_gamma_copy le BooleanType - 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 -> @@ -204,16 +201,12 @@ let reverse_type_lexpr let new_gamma = Type_env.copy_constructors gamma in let ret = List.fold_left - (fun ac (e, t) -> - ac && infer_types_to_gamma flag gamma new_gamma e t) + (fun ac (e, t) -> ac && infer_types_to_gamma flag gamma new_gamma e t) true e_types in if ret then Some new_gamma else None -let safe_extend_gamma - (gamma : Type_env.t) - (le : Expr.t) - (t : Type.t) : unit = +let safe_extend_gamma (gamma : Type_env.t) (le : Expr.t) (t : Type.t) : unit = let new_gamma = reverse_type_lexpr true gamma [ (le, t) ] in match new_gamma with | Some new_gamma -> Type_env.extend gamma new_gamma @@ -478,17 +471,14 @@ module Type_lexpr = struct bt in let _, ite = f gamma_copy e in - if not ite then def_neg - else infer_type gamma le BooleanType + if not ite then def_neg else infer_type gamma le BooleanType and type_constructor gamma n les = let tts_opt = Type_env.get_constructor_field_types gamma n in match tts_opt with | Some tts -> - if - typable_list gamma - ?target_types:(Some tts) les - then def_pos (Type_env.get_constructor_type gamma n) + if typable_list gamma ?target_types:(Some tts) les then + def_pos (Type_env.get_constructor_type gamma n) else def_neg | None -> def_neg @@ -497,9 +487,7 @@ module Type_lexpr = struct - [b] indicates if the thing is typable - [fs] indicates the constraints that must be satisfied for [le] to be typable *) - and f - (gamma : Type_env.t) - (le : Expr.t) : Type.t option * bool = + and f (gamma : Type_env.t) (le : Expr.t) : Type.t option * bool = let typable_list = typable_list gamma in let result = @@ -514,8 +502,7 @@ module Type_lexpr = struct | EList _ -> def_pos (Some ListType) (* Sets are always typable *) | ESet _ -> def_pos (Some SetType) - | Exists (bt, e) | ForAll (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) -> diff --git a/GillianCore/engine/FOLogic/typing.mli b/GillianCore/engine/FOLogic/typing.mli index e218bf8a..962ecc0d 100644 --- a/GillianCore/engine/FOLogic/typing.mli +++ b/GillianCore/engine/FOLogic/typing.mli @@ -6,10 +6,9 @@ - A type if we found a necessary type - A boolean: true if the expression is typable, false if is definitely a type error - A list of corrections missing (not sure about that one ?) *) -val type_lexpr : Type_env.t -> Expr.t -> Type.t option * bool +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_expr : Type_env.t -> Expr.t -> unit val reverse_type_lexpr : bool -> Type_env.t -> (Expr.t * Type.t) list -> Type_env.t option From e526ff16b7db270871270a3780cf55717a4e39a8 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Fri, 18 Apr 2025 17:26:35 +0100 Subject: [PATCH 13/37] Initialised Type_env with constructors for verification --- GillianCore/engine/Abstraction/Normaliser.ml | 3 +- GillianCore/engine/Abstraction/Normaliser.mli | 1 + GillianCore/engine/Abstraction/Verifier.ml | 28 +++++++++++-------- GillianCore/engine/FOLogic/type_env.mli | 2 +- GillianCore/gil_parser/gil_parsing.ml | 4 +-- 5 files changed, 23 insertions(+), 15 deletions(-) diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 7bda476d..6a82aba1 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -822,6 +822,7 @@ module Make (SPState : PState.S) = struct (** Given an assertion creates a symbolic state and a substitution *) let normalise_assertion ~(pred_defs : MP.preds_tbl_t) + ?(constructor_defs : Type_env.constructors_tbl_t option) ~(init_data : SPState.init_data) ?(pvars : SS.t option) (a : Asrt.t) : ((SPState.t * SESubst.t) list, string) result = @@ -838,7 +839,7 @@ module Make (SPState : PState.S) = struct (* Step 2a -- Create empty symbolic heap, symbolic store, typing environment, and substitution *) let store = SStore.init [] in - let gamma = Type_env.init () in + let gamma = Type_env.init ?constructor_defs () in let subst = SESubst.init [] in (* Step 2b -- Separate assertion *) diff --git a/GillianCore/engine/Abstraction/Normaliser.mli b/GillianCore/engine/Abstraction/Normaliser.mli index 116daf42..68c32e46 100644 --- a/GillianCore/engine/Abstraction/Normaliser.mli +++ b/GillianCore/engine/Abstraction/Normaliser.mli @@ -5,6 +5,7 @@ module Make (SPState : PState.S) : sig It returns the appropriate predicate state and all learned bindings. *) val normalise_assertion : pred_defs:MP.preds_tbl_t -> + ?constructor_defs:Type_env.constructors_tbl_t -> init_data:SPState.init_data -> ?pvars:Utils.Containers.SS.t -> Asrt.t -> diff --git a/GillianCore/engine/Abstraction/Verifier.ml b/GillianCore/engine/Abstraction/Verifier.ml index 1179a894..53006c8b 100644 --- a/GillianCore/engine/Abstraction/Verifier.ml +++ b/GillianCore/engine/Abstraction/Verifier.ml @@ -123,6 +123,7 @@ struct ~(init_data : SPState.init_data) (func_or_lemma_name : string) (preds : (string, MP.pred) Hashtbl.t) + (constructors : Type_env.constructors_tbl_t) (pred_ins : (string, int list) Hashtbl.t) (name : string) (params : string list) @@ -272,7 +273,7 @@ struct (* Step 1 - normalise the precondition *) match Normaliser.normalise_assertion ~init_data ~pred_defs:preds - ~pvars:(SS.of_list params) (fst pre) + ~constructor_defs:constructors ~pvars:(SS.of_list params) (fst pre) with | Error _ -> [ (None, None) ] | Ok normalised_assertions -> @@ -302,6 +303,7 @@ struct ~init_data (spec_name : string) (preds : MP.preds_tbl_t) + (constructors : Type_env.constructors_tbl_t) (pred_ins : (string, int list) Hashtbl.t) (name : string) (params : string list) @@ -309,8 +311,8 @@ struct (sspec : Spec.st) : (t option * Spec.st option) list = let ( let+ ) x f = List.map f x in let+ stest, sspec' = - testify ~init_data spec_name preds pred_ins name params id sspec.ss_pre - sspec.ss_posts sspec.ss_variant (Some sspec.ss_flag) + testify ~init_data spec_name preds constructors pred_ins name params id + sspec.ss_pre sspec.ss_posts sspec.ss_variant (Some sspec.ss_flag) (Spec.label_vars_to_set sspec.ss_label) sspec.ss_to_verify in @@ -325,6 +327,7 @@ struct ~init_data (spec_name : string) (preds : MP.preds_tbl_t) + (constructors : Type_env.constructors_tbl_t) (pred_ins : (string, int list) Hashtbl.t) (spec : Spec.t) : t list * Spec.t = if not spec.spec_to_verify then ([], spec) @@ -350,8 +353,8 @@ struct List.fold_left (fun (id, tests, sspecs) sspec -> let tests_and_specs = - testify_sspec ~init_data spec_name preds pred_ins spec.spec_name - spec.spec_params id sspec + testify_sspec ~init_data spec_name preds constructors pred_ins + spec.spec_name spec.spec_params id sspec in let new_tests, new_specs = List.fold_left @@ -379,15 +382,16 @@ struct let testify_lemma ~init_data (preds : MP.preds_tbl_t) + (constructors : Type_env.constructors_tbl_t) (pred_ins : (string, int list) Hashtbl.t) (lemma : Lemma.t) : t list * Lemma.t = let tests_and_specs = List.concat_map (fun Lemma.{ lemma_hyp; lemma_concs; lemma_spec_variant } -> let to_verify = Option.is_some lemma.lemma_proof in - testify ~init_data lemma.lemma_name preds pred_ins lemma.lemma_name - lemma.lemma_params 0 lemma_hyp lemma_concs lemma_spec_variant None - None to_verify) + testify ~init_data lemma.lemma_name preds constructors pred_ins + lemma.lemma_name lemma.lemma_params 0 lemma_hyp lemma_concs + lemma_spec_variant None None to_verify) lemma.lemma_specs in let tests, specs = @@ -768,7 +772,8 @@ struct List.concat_map (fun (spec : Spec.t) -> let tests, new_spec = - testify_spec ~init_data spec.spec_name preds pred_ins spec + testify_spec ~init_data spec.spec_name preds prog.constructors + pred_ins spec in let proc = Prog.get_proc_exn prog spec.spec_name in Hashtbl.replace prog.procs proc.proc_name @@ -797,7 +802,7 @@ struct List.concat_map (fun lemma -> let tests, new_lemma = - testify_lemma ~init_data preds pred_ins lemma + testify_lemma ~init_data preds prog.constructors pred_ins lemma in Hashtbl.replace prog.lemmas lemma.lemma_name new_lemma; tests) @@ -1026,7 +1031,8 @@ struct specs |> List.filter_map (fun (spec : Spec.t) -> let tests, new_spec = - testify_spec ~init_data spec.spec_name preds pred_ins spec + testify_spec ~init_data spec.spec_name preds prog.constructors + pred_ins spec in if List.length tests > 1 then DL.log (fun m -> diff --git a/GillianCore/engine/FOLogic/type_env.mli b/GillianCore/engine/FOLogic/type_env.mli index a5c54981..832fa903 100644 --- a/GillianCore/engine/FOLogic/type_env.mli +++ b/GillianCore/engine/FOLogic/type_env.mli @@ -7,7 +7,7 @@ open SVal (** @canonical Gillian.Symbolic.Type_env.t *) type t [@@deriving yojson] -type constructors_tbl_t [@@deriving yojson] +type constructors_tbl_t = (string, Constructor.t) Hashtbl.t [@@deriving yojson] val as_hashtbl : t -> (string, Type.t) Hashtbl.t val copy : t -> t diff --git a/GillianCore/gil_parser/gil_parsing.ml b/GillianCore/gil_parser/gil_parsing.ml index e1a079f8..abafd7eb 100644 --- a/GillianCore/gil_parser/gil_parsing.ml +++ b/GillianCore/gil_parser/gil_parsing.ml @@ -294,8 +294,8 @@ module Make (Annot : Annot.S) = struct in Prog.make_indexed ~lemmas:ext_program.lemmas ~preds:ext_program.preds ~only_specs:ext_program.only_specs ~procs ~predecessors - ~macros:ext_program.macros ~bi_specs:ext_program.bi_specs (* TODO *) - ~datatypes:(Hashtbl.create 1) ~constructors:(Hashtbl.create 1) () + ~macros:ext_program.macros ~bi_specs:ext_program.bi_specs + ~datatypes:ext_program.datatypes ~constructors:ext_program.constructors () let parse_literal lexbuf = parse GIL_Parser.lit_target lexbuf let parse_expression lexbuf = parse GIL_Parser.top_level_expr_target lexbuf From dc32b95d44a20e14435e65f6c4fb7a7f2e7e7a75 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Fri, 18 Apr 2025 18:48:43 +0100 Subject: [PATCH 14/37] Reductions handles Constructors --- GillianCore/engine/FOLogic/Reduction.ml | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index 5b6354d4..6c5eab63 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -64,7 +64,6 @@ let rec normalise_list_expressions (le : Expr.t) : Expr.t = let result = let exn msg = ReductionException (le, msg) in match (le : Expr.t) with - | Constructor _ -> failwith "TODO" (* TODO *) (* Literals **) | Lit (LList lst) -> Expr.from_lit_list (LList lst) (* Literals, variables, alocs *) @@ -137,6 +136,7 @@ let rec normalise_list_expressions (le : Expr.t) : Expr.t = | LstSub (le1, le2, le3) -> LstSub (f le1, f le2, f le3) | Exists (bt, le) -> Exists (bt, f le) | ForAll (bt, le) -> ForAll (bt, f le) + | Constructor (n, les) -> Constructor (n, List.map f les) (* | LstSub(le1, le2, le3) -> (match f le1, f le2, f le3 with @@ -881,7 +881,6 @@ and reduce_lexpr_loop let result : Expr.t = match le with - | Constructor _ -> failwith "TODO" (* ------------------------- Base cases ------------------------- *) @@ -904,6 +903,10 @@ and reduce_lexpr_loop ESet ------------------------- *) | ESet les -> ESet (Expr.Set.elements @@ Expr.Set.of_list @@ List.map f les) + (* ------------------------- + Constructors + ------------------------- *) + | Constructor (n, les) -> Constructor (n, List.map f les) (* ------------------------- ForAll + Exists ------------------------- *) @@ -1783,6 +1786,16 @@ and reduce_lexpr_loop when t <> StringType -> Expr.false_ | BinOp (UnOp (TypeOf, BinOp (_, SetMem, _)), Equal, Lit (Type t)) when t <> BooleanType -> Expr.false_ + (* BinOps: Equalities (Constructors) *) + | BinOp (Constructor (ln, lles), Equal, Constructor (rn, rles)) -> + if ln = rn && List.length lles = List.length rles then + Expr.conjunct + (List.map2 (fun le re -> Expr.BinOp (le, Equal, re)) lles rles) + else Expr.false_ + | BinOp (Constructor _, Equal, rle) as le -> ( + match rle with + | LVar _ | Constructor _ -> le + | _ -> Expr.false_) (* BinOps: Logic *) | BinOp (Lit (Bool true), And, e) | BinOp (e, And, Lit (Bool true)) From 7cf232639bc80c12ea111be9b59480323f045069 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Sun, 20 Apr 2025 20:30:41 +0100 Subject: [PATCH 15/37] Support for constructors within matching plans --- GillianCore/engine/Abstraction/MP.ml | 8 +-- wisl/examples/SLL_adt.wisl | 84 ++++++++++++++-------------- 2 files changed, 46 insertions(+), 46 deletions(-) diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index c4b0b590..dab21ede 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -140,7 +140,7 @@ let rec missing_expr (kb : KB.t) (e : Expr.t) : KB.t list = (* The remaining cases proceed recursively *) | UnOp (_, e) -> f e | BinOp (e1, _, e2) -> join [ e1; e2 ] - | NOp (_, le) | EList le | ESet le -> join le + | NOp (_, le) | EList le | ESet le | Constructor (_, le) -> join le | LstSub (e1, e2, e3) -> let result = join [ e1; e2; e3 ] in L.verbose (fun fmt -> @@ -153,7 +153,6 @@ let rec missing_expr (kb : KB.t) (e : Expr.t) : KB.t list = KB.add_seq (List.to_seq bt |> Seq.map (fun (x, _) -> Expr.LVar x)) kb in f' kb' e - | Constructor _ -> failwith "TODO" (* TODO *) (** [is_known kb e] returns true if the expression [e] is known under knowledge base [kb], and false otherwise *) @@ -171,7 +170,8 @@ let rec learn_expr (e : Expr.t) : outs = let f = learn_expr kb in match e with - | Constructor _ -> failwith "TODO" (* TODO *) + (* TODO: Constructors aren't invertible unless we have destructors *) + | Constructor _ -> [] (* Literals, abstract locations, sublists, and sets are never invertible *) | Lit _ | LstSub _ | ESet _ -> [] (* Nothing is learned if the top-level expr is a program or a logical variable *) @@ -443,7 +443,7 @@ let rec simple_ins_formula (kb : KB.t) (pf : Expr.t) : KB.t list = let ins = List.map (fun ins -> KB.diff ins binders) ins_pf in List.map minimise_matchables ins | Lit _ | PVar _ | LVar _ | ALoc _ | LstSub _ | NOp _ | EList _ | ESet _ -> [] - | Constructor _ -> failwith "TODO" (* TODO *) + | Constructor _ -> [] (* TODO *) (** [ins_outs_formula kb pf] returns a list of possible ins-outs pairs for a given formula [pf] under a given knowledge base [kb] *) diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl index 269acefc..9fc0bc4c 100644 --- a/wisl/examples/SLL_adt.wisl +++ b/wisl/examples/SLL_adt.wisl @@ -10,7 +10,7 @@ datatype MyList { // predicate SLL(+x, vs) { // Empty SLL - (x == null) * (vs == Nil); + (x == null) * (vs == Nil()); // One SLL node and the rest (x -b> #v, #next) * SLL(#next, #vs) * (vs == Cons(#v, #vs)) @@ -19,11 +19,11 @@ predicate SLL(+x, vs) { // // Pure predicate for list membership // -predicate list_member(+vs, +v, r : Bool){ - (vs == Nil) * (r == false); - (vs == Cons(v, #rest)) * (r == true) * list_member(#rest, v, #mem); - (vs == Cons(#v, #rest)) * (! (#v == v)) * list_member(#rest, v, r) -} +// predicate list_member(+vs, +v, r : Bool){ +// (vs == Nil) * (r == false); +// (vs == Cons(v, #rest)) * (r == true) * list_member(#rest, v, #mem); +// (vs == Cons(#v, #rest)) * (! (#v == v)) * list_member(#rest, v, r) +// } // 00. Allocating an SLL node with the given value { v == #v } @@ -66,44 +66,44 @@ function SLL_copy(x){ { SLL(#x, #vs) * SLL(ret, #vs) } // 08. Checking if a given value is in a given SLL -{ (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #r) } -function SLL_member(x, k){ - found := false; - if (x = null){ - skip - } else { - v := [x]; - if (v = k){ - found := true - } else { - t := [x + 1]; - found := SLL_member(t, k) - } - }; - return found -} -{ SLL(#x, #vs) * list_member(#vs, #k, #r) * (ret == #r) } +// { (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #r) } +// function SLL_member(x, k){ +// found := false; +// if (x = null){ +// skip +// } else { +// v := [x]; +// if (v = k){ +// found := true +// } else { +// t := [x + 1]; +// found := SLL_member(t, k) +// } +// }; +// return found +// } +// { SLL(#x, #vs) * list_member(#vs, #k, #r) * (ret == #r) } // 09. Removing a given value from a given SLL -{ (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #mem) } -function SLL_remove(x, k) { - if (x = null) { - skip - } else { - v := [x]; - next := [x + 1]; - if (v = k){ - free(x); - x := SLL_remove(next, k) - } else { - z := SLL_remove(next, k); - [x + 1] := z - } - }; - [[ fold list_member(Nil, #k, false) ]]; - return x -} -{ SLL(ret, #nvs) * list_member(#nvs, #k, false) } +// { (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #mem) } +// function SLL_remove(x, k) { +// if (x = null) { +// skip +// } else { +// v := [x]; +// next := [x + 1]; +// if (v = k){ +// free(x); +// x := SLL_remove(next, k) +// } else { +// z := SLL_remove(next, k); +// [x + 1] := z +// } +// }; +// [[ fold list_member(Nil, #k, false) ]]; +// return x +// } +// { SLL(ret, #nvs) * list_member(#nvs, #k, false) } // 10. Freeing a given SLL { (x == #x) * SLL(#x, #vs) } From 2496db709a7f15d7e07184ddda3f1540e350503d Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Mon, 21 Apr 2025 19:09:04 +0100 Subject: [PATCH 16/37] Encoding of types into SMT --- GillianCore/smt/smt.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/GillianCore/smt/smt.ml b/GillianCore/smt/smt.ml index 3aeffc83..e00a1fa9 100644 --- a/GillianCore/smt/smt.ml +++ b/GillianCore/smt/smt.ml @@ -182,6 +182,7 @@ module Type_operations = struct module List = (val nul "ListType" : Nullary) module Type = (val nul "TypeType" : Nullary) module Set = (val nul "SetType" : Nullary) + module Datatype = (val un "DatatypeType" "datatype-id" t_int) let t_gil_type = mk_datatype "GIL_Type" [] @@ -198,6 +199,7 @@ module Type_operations = struct (module List : Variant.S); (module Type : Variant.S); (module Set : Variant.S); + (module Datatype : Variant.S); ] end @@ -308,7 +310,8 @@ let encode_type (t : Type.t) = | ListType -> Type_operations.List.construct | TypeType -> Type_operations.Type.construct | SetType -> Type_operations.Set.construct - | DatatypeType _ -> failwith "TODO" (* TODO *) + | DatatypeType name -> + name |> encode_string |> Type_operations.Datatype.construct with _ -> Fmt.failwith "DEATH: encode_type with arg: %a" Type.pp t module Encoding = struct From ac7fd4b3dafe9a14c3c361c6b060cd8b7cb043d1 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Mon, 21 Apr 2025 20:23:52 +0100 Subject: [PATCH 17/37] Refactored Prog to only store datatype defs --- Gillian-C/lib/gilgen.ml | 1 - Gillian-JS/lib/Compiler/JSIL2GIL.ml | 3 +- GillianCore/GIL_Syntax/Datatype.ml | 1 + GillianCore/GIL_Syntax/Gil_syntax.mli | 5 +--- GillianCore/GIL_Syntax/Prog.ml | 6 +--- GillianCore/engine/Abstraction/Normaliser.ml | 4 +-- GillianCore/engine/Abstraction/Normaliser.mli | 2 +- GillianCore/engine/Abstraction/Verifier.ml | 22 +++++++------- GillianCore/engine/FOLogic/type_env.ml | 29 ++++++++++++++----- GillianCore/engine/FOLogic/type_env.mli | 5 ++-- GillianCore/engine/FOLogic/typing.ml | 2 +- GillianCore/gil_parser/gil_parsing.ml | 2 +- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 27 ++++++----------- 13 files changed, 54 insertions(+), 55 deletions(-) diff --git a/Gillian-C/lib/gilgen.ml b/Gillian-C/lib/gilgen.ml index fac37759..cfa382d4 100644 --- a/Gillian-C/lib/gilgen.ml +++ b/Gillian-C/lib/gilgen.ml @@ -1062,7 +1062,6 @@ let trans_program lemmas = Hashtbl.create 1; preds = Hashtbl.create 1; datatypes = Hashtbl.create 1; - constructors = Hashtbl.create 1; only_specs = Hashtbl.create 1; macros = Hashtbl.create 1; bi_specs = make_hashtbl (fun p -> p.BiSpec.bispec_name) bi_specs; diff --git a/Gillian-JS/lib/Compiler/JSIL2GIL.ml b/Gillian-JS/lib/Compiler/JSIL2GIL.ml index dcdadeb7..339bcd52 100644 --- a/Gillian-JS/lib/Compiler/JSIL2GIL.ml +++ b/Gillian-JS/lib/Compiler/JSIL2GIL.ml @@ -503,8 +503,7 @@ let jsil2core_prog (prog : EProg.t) : ('a, string) GProg.t = ~macros:(translate_tbl prog.macros jsil2gil_macro) ~bi_specs:(translate_tbl prog.bi_specs jsil2gil_bispec) ~proc_names:prog.proc_names ~predecessors:(Hashtbl.create 1) - ~datatypes:(Hashtbl.create 1) - ~constructors:(Hashtbl.create 1) (* TODO *) + ~datatypes:(Hashtbl.create 1) (* TODO *) () in result diff --git a/GillianCore/GIL_Syntax/Datatype.ml b/GillianCore/GIL_Syntax/Datatype.ml index c7c0cdb8..09e9b05e 100644 --- a/GillianCore/GIL_Syntax/Datatype.ml +++ b/GillianCore/GIL_Syntax/Datatype.ml @@ -4,3 +4,4 @@ type t = TypeDef__.datatype = { datatype_loc : Location.t option; datatype_constructors : Constructor.t list; } +[@@deriving yojson] diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 88428d4a..efe9d548 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -731,6 +731,7 @@ module Datatype : sig datatype_loc : Location.t option; datatype_constructors : Constructor.t list; } + [@@deriving yojson] end module Constructor : sig @@ -975,7 +976,6 @@ module Prog : sig lemmas : (string, Lemma.t) Hashtbl.t; (** Lemmas *) preds : (string, Pred.t) Hashtbl.t; (** Predicates *) datatypes : (string, Datatype.t) Hashtbl.t; - constructors : (string, Constructor.t) Hashtbl.t; only_specs : (string, Spec.t) Hashtbl.t; (** Specs without function definitions *) procs : (string, ('annot, 'label) Proc.t) Hashtbl.t; (** Proceudes *) @@ -992,7 +992,6 @@ module Prog : sig lemmas:(string, Lemma.t) Hashtbl.t -> preds:(string, Pred.t) Hashtbl.t -> datatypes:(string, Datatype.t) Hashtbl.t -> - constructors:(string, Constructor.t) Hashtbl.t -> only_specs:(string, Spec.t) Hashtbl.t -> procs:(string, ('annot, 'label) Proc.t) Hashtbl.t -> macros:(string, Macro.t) Hashtbl.t -> @@ -1009,7 +1008,6 @@ module Prog : sig lemmas:(string, Lemma.t) Hashtbl.t -> preds:(string, Pred.t) Hashtbl.t -> datatypes:(string, Datatype.t) Hashtbl.t -> - constructors:(string, Constructor.t) Hashtbl.t -> only_specs:(string, Spec.t) Hashtbl.t -> macros:(string, Macro.t) Hashtbl.t -> bi_specs:(string, BiSpec.t) Hashtbl.t -> @@ -1024,7 +1022,6 @@ module Prog : sig lemmas:(string, Lemma.t) Hashtbl.t -> preds:(string, Pred.t) Hashtbl.t -> datatypes:(string, Datatype.t) Hashtbl.t -> - constructors:(string, Constructor.t) Hashtbl.t -> only_specs:(string, Spec.t) Hashtbl.t -> macros:(string, Macro.t) Hashtbl.t -> bi_specs:(string, BiSpec.t) Hashtbl.t -> diff --git a/GillianCore/GIL_Syntax/Prog.ml b/GillianCore/GIL_Syntax/Prog.ml index c9adc51a..9acc18e9 100644 --- a/GillianCore/GIL_Syntax/Prog.ml +++ b/GillianCore/GIL_Syntax/Prog.ml @@ -8,7 +8,6 @@ type ('annot, 'label) t = { preds : (string, Pred.t) Hashtbl.t; (* Predicates = Name : String --> Definition *) datatypes : (string, Datatype.t) Hashtbl.t; - constructors : (string, Constructor.t) Hashtbl.t; only_specs : (string, Spec.t) Hashtbl.t; (* Specs = Name : String --> Spec *) procs : (string, ('annot, 'label) Proc.t) Hashtbl.t; @@ -26,7 +25,6 @@ let make ~lemmas ~preds ~datatypes - ~constructors ~only_specs ~procs ~macros @@ -39,7 +37,6 @@ let make lemmas; preds; datatypes; - constructors; only_specs; procs; macros; @@ -73,8 +70,7 @@ let create () = ~lemmas:(Hashtbl.create medium_tbl_size) ~preds:(Hashtbl.create big_tbl_size) ~datatypes:(Hashtbl.create small_tbl_size) - ~constructors:(Hashtbl.create small_tbl_size) - (* TODO: What table size to use for datatypes / constructors? *) + (* TODO: What table size to use for datatypes*) ~only_specs:(Hashtbl.create medium_tbl_size) ~procs:(Hashtbl.create big_tbl_size) ~macros:(Hashtbl.create small_tbl_size) diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 6a82aba1..7cc4c77a 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -822,7 +822,7 @@ module Make (SPState : PState.S) = struct (** Given an assertion creates a symbolic state and a substitution *) let normalise_assertion ~(pred_defs : MP.preds_tbl_t) - ?(constructor_defs : Type_env.constructors_tbl_t option) + ?(datatype_defs : Type_env.datatypes_tbl_t option) ~(init_data : SPState.init_data) ?(pvars : SS.t option) (a : Asrt.t) : ((SPState.t * SESubst.t) list, string) result = @@ -839,7 +839,7 @@ module Make (SPState : PState.S) = struct (* Step 2a -- Create empty symbolic heap, symbolic store, typing environment, and substitution *) let store = SStore.init [] in - let gamma = Type_env.init ?constructor_defs () in + let gamma = Type_env.init ?datatype_defs () in let subst = SESubst.init [] in (* Step 2b -- Separate assertion *) diff --git a/GillianCore/engine/Abstraction/Normaliser.mli b/GillianCore/engine/Abstraction/Normaliser.mli index 68c32e46..93cde33f 100644 --- a/GillianCore/engine/Abstraction/Normaliser.mli +++ b/GillianCore/engine/Abstraction/Normaliser.mli @@ -5,7 +5,7 @@ module Make (SPState : PState.S) : sig It returns the appropriate predicate state and all learned bindings. *) val normalise_assertion : pred_defs:MP.preds_tbl_t -> - ?constructor_defs:Type_env.constructors_tbl_t -> + ?datatype_defs:Type_env.datatypes_tbl_t -> init_data:SPState.init_data -> ?pvars:Utils.Containers.SS.t -> Asrt.t -> diff --git a/GillianCore/engine/Abstraction/Verifier.ml b/GillianCore/engine/Abstraction/Verifier.ml index 53006c8b..bd5f81da 100644 --- a/GillianCore/engine/Abstraction/Verifier.ml +++ b/GillianCore/engine/Abstraction/Verifier.ml @@ -123,7 +123,7 @@ struct ~(init_data : SPState.init_data) (func_or_lemma_name : string) (preds : (string, MP.pred) Hashtbl.t) - (constructors : Type_env.constructors_tbl_t) + (datatypes : Type_env.datatypes_tbl_t) (pred_ins : (string, int list) Hashtbl.t) (name : string) (params : string list) @@ -273,7 +273,7 @@ struct (* Step 1 - normalise the precondition *) match Normaliser.normalise_assertion ~init_data ~pred_defs:preds - ~constructor_defs:constructors ~pvars:(SS.of_list params) (fst pre) + ~datatype_defs:datatypes ~pvars:(SS.of_list params) (fst pre) with | Error _ -> [ (None, None) ] | Ok normalised_assertions -> @@ -303,7 +303,7 @@ struct ~init_data (spec_name : string) (preds : MP.preds_tbl_t) - (constructors : Type_env.constructors_tbl_t) + (datatypes : Type_env.datatypes_tbl_t) (pred_ins : (string, int list) Hashtbl.t) (name : string) (params : string list) @@ -311,7 +311,7 @@ struct (sspec : Spec.st) : (t option * Spec.st option) list = let ( let+ ) x f = List.map f x in let+ stest, sspec' = - testify ~init_data spec_name preds constructors pred_ins name params id + testify ~init_data spec_name preds datatypes pred_ins name params id sspec.ss_pre sspec.ss_posts sspec.ss_variant (Some sspec.ss_flag) (Spec.label_vars_to_set sspec.ss_label) sspec.ss_to_verify @@ -327,7 +327,7 @@ struct ~init_data (spec_name : string) (preds : MP.preds_tbl_t) - (constructors : Type_env.constructors_tbl_t) + (datatypes : Type_env.datatypes_tbl_t) (pred_ins : (string, int list) Hashtbl.t) (spec : Spec.t) : t list * Spec.t = if not spec.spec_to_verify then ([], spec) @@ -353,7 +353,7 @@ struct List.fold_left (fun (id, tests, sspecs) sspec -> let tests_and_specs = - testify_sspec ~init_data spec_name preds constructors pred_ins + testify_sspec ~init_data spec_name preds datatypes pred_ins spec.spec_name spec.spec_params id sspec in let new_tests, new_specs = @@ -382,14 +382,14 @@ struct let testify_lemma ~init_data (preds : MP.preds_tbl_t) - (constructors : Type_env.constructors_tbl_t) + (datatypes : Type_env.datatypes_tbl_t) (pred_ins : (string, int list) Hashtbl.t) (lemma : Lemma.t) : t list * Lemma.t = let tests_and_specs = List.concat_map (fun Lemma.{ lemma_hyp; lemma_concs; lemma_spec_variant } -> let to_verify = Option.is_some lemma.lemma_proof in - testify ~init_data lemma.lemma_name preds constructors pred_ins + testify ~init_data lemma.lemma_name preds datatypes pred_ins lemma.lemma_name lemma.lemma_params 0 lemma_hyp lemma_concs lemma_spec_variant None None to_verify) lemma.lemma_specs @@ -772,7 +772,7 @@ struct List.concat_map (fun (spec : Spec.t) -> let tests, new_spec = - testify_spec ~init_data spec.spec_name preds prog.constructors + testify_spec ~init_data spec.spec_name preds prog.datatypes pred_ins spec in let proc = Prog.get_proc_exn prog spec.spec_name in @@ -802,7 +802,7 @@ struct List.concat_map (fun lemma -> let tests, new_lemma = - testify_lemma ~init_data preds prog.constructors pred_ins lemma + testify_lemma ~init_data preds prog.datatypes pred_ins lemma in Hashtbl.replace prog.lemmas lemma.lemma_name new_lemma; tests) @@ -1031,7 +1031,7 @@ struct specs |> List.filter_map (fun (spec : Spec.t) -> let tests, new_spec = - testify_spec ~init_data spec.spec_name preds prog.constructors + testify_spec ~init_data spec.spec_name preds prog.datatypes pred_ins spec in if List.length tests > 1 then diff --git a/GillianCore/engine/FOLogic/type_env.ml b/GillianCore/engine/FOLogic/type_env.ml index 5a7da369..6b71f60c 100644 --- a/GillianCore/engine/FOLogic/type_env.ml +++ b/GillianCore/engine/FOLogic/type_env.ml @@ -5,10 +5,12 @@ open SVal module L = Logging type constructors_tbl_t = (string, Constructor.t) Hashtbl.t [@@deriving yojson] +type datatypes_tbl_t = (string, Datatype.t) Hashtbl.t [@@deriving yojson] type t = { var_types : (string, Type.t) Hashtbl.t; constructor_defs : constructors_tbl_t; + datatype_defs : datatypes_tbl_t; } [@@deriving yojson] @@ -20,13 +22,26 @@ let as_hashtbl x = x.var_types (*************************************) (* Initialisation *) -let init ?(constructor_defs = Hashtbl.create Config.medium_tbl_size) () : t = - { var_types = Hashtbl.create Config.medium_tbl_size; constructor_defs } +let init ?(datatype_defs = Hashtbl.create Config.medium_tbl_size) () : t = + let constructor_defs = Hashtbl.create Config.medium_tbl_size in + let add_constructor_to_tbl (constructor : Constructor.t) = + Hashtbl.add constructor_defs constructor.constructor_name constructor + in + let add_constructors_to_tbl _ (datatype : Datatype.t) = + List.iter add_constructor_to_tbl datatype.datatype_constructors + in + let () = Hashtbl.iter add_constructors_to_tbl datatype_defs in + { + var_types = Hashtbl.create Config.medium_tbl_size; + datatype_defs; + constructor_defs; + } (* Copy *) -let copy { var_types; constructor_defs } : t = +let copy { var_types; datatype_defs; constructor_defs } : t = { var_types = Hashtbl.copy var_types; + datatype_defs = Hashtbl.copy datatype_defs; constructor_defs = Hashtbl.copy constructor_defs; } @@ -178,7 +193,7 @@ let filter_with_info relevant_info (x : t) = filter x (fun x -> SS.mem x relevant) (*************************************) -(** Typing Environment Functions **) +(** Datatype Functions **) (*************************************) @@ -203,6 +218,6 @@ let get_constructor_field_types (x : t) (cname : string) : let constructor = Hashtbl.find_opt x.constructor_defs cname in Option.map (fun (c : Constructor.t) -> c.constructor_fields) constructor -let copy_constructors (x : t) : t = - let constructor_defs = Hashtbl.copy x.constructor_defs in - init ~constructor_defs () +let keeping_datatypes (x : t) : t = + let datatype_defs = Hashtbl.copy x.datatype_defs in + init ~datatype_defs () diff --git a/GillianCore/engine/FOLogic/type_env.mli b/GillianCore/engine/FOLogic/type_env.mli index 832fa903..17c1904e 100644 --- a/GillianCore/engine/FOLogic/type_env.mli +++ b/GillianCore/engine/FOLogic/type_env.mli @@ -8,6 +8,7 @@ open SVal type t [@@deriving yojson] type constructors_tbl_t = (string, Constructor.t) Hashtbl.t [@@deriving yojson] +type datatypes_tbl_t = (string, Datatype.t) Hashtbl.t [@@deriving yojson] val as_hashtbl : t -> (string, Type.t) Hashtbl.t val copy : t -> t @@ -20,7 +21,7 @@ val get : t -> string -> Type.t option val get_unsafe : t -> string -> Type.t val get_var_type_pairs : t -> (string * Type.t) Seq.t val get_vars_of_type : t -> Type.t -> string list -val init : ?constructor_defs:constructors_tbl_t -> unit -> t +val init : ?datatype_defs:datatypes_tbl_t -> unit -> t val mem : t -> string -> bool val empty : t -> bool val pp : Format.formatter -> t -> unit @@ -44,4 +45,4 @@ val filter_with_info : val get_constructor_type : t -> string -> Type.t option val get_constructor_type_unsafe : t -> string -> Type.t val get_constructor_field_types : t -> string -> Type.t option list option -val copy_constructors : t -> t +val keeping_datatypes : t -> t diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index df5e1201..0d9b41f2 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -198,7 +198,7 @@ let reverse_type_lexpr (flag : bool) (gamma : Type_env.t) (e_types : (Expr.t * Type.t) list) : Type_env.t option = - let new_gamma = Type_env.copy_constructors gamma in + let new_gamma = Type_env.keeping_datatypes gamma in let ret = List.fold_left (fun ac (e, t) -> ac && infer_types_to_gamma flag gamma new_gamma e t) diff --git a/GillianCore/gil_parser/gil_parsing.ml b/GillianCore/gil_parser/gil_parsing.ml index abafd7eb..1f891eb4 100644 --- a/GillianCore/gil_parser/gil_parsing.ml +++ b/GillianCore/gil_parser/gil_parsing.ml @@ -295,7 +295,7 @@ module Make (Annot : Annot.S) = struct Prog.make_indexed ~lemmas:ext_program.lemmas ~preds:ext_program.preds ~only_specs:ext_program.only_specs ~procs ~predecessors ~macros:ext_program.macros ~bi_specs:ext_program.bi_specs - ~datatypes:ext_program.datatypes ~constructors:ext_program.constructors () + ~datatypes:ext_program.datatypes () let parse_literal lexbuf = parse GIL_Parser.lit_target lexbuf let parse_expression lexbuf = parse GIL_Parser.top_level_expr_target lexbuf diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index 73d7afc3..36eba71f 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -1180,14 +1180,13 @@ let compile_datatype List.map (compile_constructor filepath) datatype_constructors in let datatype_loc = Some (CodeLoc.to_location datatype_loc) in - ( Datatype. - { - datatype_name; - datatype_source_path = Some filepath; - datatype_loc; - datatype_constructors = comp_constructors; - }, - comp_constructors ) + Datatype. + { + datatype_name; + datatype_source_path = Some filepath; + datatype_loc; + datatype_constructors = comp_constructors; + } let compile ~filepath WProg.{ context; predicates; lemmas; datatypes } = (* stuff useful to build hashtables *) @@ -1202,9 +1201,6 @@ let compile ~filepath WProg.{ context; predicates; lemmas; datatypes } = let get_pred_name pred = pred.Pred.pred_name in let get_lemma_name lemma = lemma.Lemma.lemma_name in let get_datatype_name datatype = datatype.Datatype.datatype_name in - let get_constructor_name constructor = - constructor.Constructor.constructor_name - in (* compile everything *) let comp_context = List.map (compile_function filepath) context in let comp_preds = List.map (compile_pred filepath) predicates in @@ -1213,17 +1209,12 @@ let compile ~filepath WProg.{ context; predicates; lemmas; datatypes } = (fun lemma -> compile_lemma filepath (preprocess_lemma lemma)) lemmas in - let comp_datatypes, comp_constructors = - List.split (List.map (compile_datatype filepath) datatypes) - in + let comp_datatypes = List.map (compile_datatype filepath) datatypes in (* build the hashtables *) let gil_procs = make_hashtbl get_proc_name (List.concat comp_context) in let gil_preds = make_hashtbl get_pred_name comp_preds in let gil_lemmas = make_hashtbl get_lemma_name comp_lemmas in let gil_datatypes = make_hashtbl get_datatype_name comp_datatypes in - let gil_constructors = - make_hashtbl get_constructor_name (List.concat comp_constructors) - in let proc_names = Hashtbl.fold (fun s _ l -> s :: l) gil_procs [] in let bi_specs = Hashtbl.create 1 in if Gillian.Utils.(Exec_mode.is_biabduction_exec !Config.current_exec_mode) @@ -1252,4 +1243,4 @@ let compile ~filepath WProg.{ context; predicates; lemmas; datatypes } = ~lemmas:gil_lemmas ~preds:gil_preds ~procs:gil_procs ~proc_names ~bi_specs ~only_specs:(Hashtbl.create 1) ~macros:(Hashtbl.create 1) ~predecessors:(Hashtbl.create 1) () (* TODO *) - ~datatypes:gil_datatypes ~constructors:gil_constructors + ~datatypes:gil_datatypes From 37d8841fe619d215e1ca9fe71b282c156bcfd1b6 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Wed, 23 Apr 2025 16:23:38 +0100 Subject: [PATCH 18/37] Encoding of ADTs into SMT --- GillianCore/engine/Abstraction/Normaliser.ml | 3 +- GillianCore/engine/Abstraction/Normaliser.mli | 1 - GillianCore/engine/Abstraction/Verifier.ml | 29 +- GillianCore/engine/FOLogic/FOSolver.ml | 21 +- GillianCore/engine/FOLogic/type_env.ml | 108 +++---- GillianCore/engine/FOLogic/type_env.mli | 12 +- GillianCore/engine/FOLogic/typing.ml | 10 +- GillianCore/smt/smt.ml | 267 +++++++++++++++--- GillianCore/smt/smt.mli | 22 +- wisl/examples/SLL_adt.wisl | 2 +- 10 files changed, 334 insertions(+), 141 deletions(-) diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 7cc4c77a..7bda476d 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -822,7 +822,6 @@ module Make (SPState : PState.S) = struct (** Given an assertion creates a symbolic state and a substitution *) let normalise_assertion ~(pred_defs : MP.preds_tbl_t) - ?(datatype_defs : Type_env.datatypes_tbl_t option) ~(init_data : SPState.init_data) ?(pvars : SS.t option) (a : Asrt.t) : ((SPState.t * SESubst.t) list, string) result = @@ -839,7 +838,7 @@ module Make (SPState : PState.S) = struct (* Step 2a -- Create empty symbolic heap, symbolic store, typing environment, and substitution *) let store = SStore.init [] in - let gamma = Type_env.init ?datatype_defs () in + let gamma = Type_env.init () in let subst = SESubst.init [] in (* Step 2b -- Separate assertion *) diff --git a/GillianCore/engine/Abstraction/Normaliser.mli b/GillianCore/engine/Abstraction/Normaliser.mli index 93cde33f..116daf42 100644 --- a/GillianCore/engine/Abstraction/Normaliser.mli +++ b/GillianCore/engine/Abstraction/Normaliser.mli @@ -5,7 +5,6 @@ module Make (SPState : PState.S) : sig It returns the appropriate predicate state and all learned bindings. *) val normalise_assertion : pred_defs:MP.preds_tbl_t -> - ?datatype_defs:Type_env.datatypes_tbl_t -> init_data:SPState.init_data -> ?pvars:Utils.Containers.SS.t -> Asrt.t -> diff --git a/GillianCore/engine/Abstraction/Verifier.ml b/GillianCore/engine/Abstraction/Verifier.ml index bd5f81da..f018530a 100644 --- a/GillianCore/engine/Abstraction/Verifier.ml +++ b/GillianCore/engine/Abstraction/Verifier.ml @@ -123,7 +123,6 @@ struct ~(init_data : SPState.init_data) (func_or_lemma_name : string) (preds : (string, MP.pred) Hashtbl.t) - (datatypes : Type_env.datatypes_tbl_t) (pred_ins : (string, int list) Hashtbl.t) (name : string) (params : string list) @@ -273,7 +272,7 @@ struct (* Step 1 - normalise the precondition *) match Normaliser.normalise_assertion ~init_data ~pred_defs:preds - ~datatype_defs:datatypes ~pvars:(SS.of_list params) (fst pre) + ~pvars:(SS.of_list params) (fst pre) with | Error _ -> [ (None, None) ] | Ok normalised_assertions -> @@ -303,7 +302,6 @@ struct ~init_data (spec_name : string) (preds : MP.preds_tbl_t) - (datatypes : Type_env.datatypes_tbl_t) (pred_ins : (string, int list) Hashtbl.t) (name : string) (params : string list) @@ -311,8 +309,8 @@ struct (sspec : Spec.st) : (t option * Spec.st option) list = let ( let+ ) x f = List.map f x in let+ stest, sspec' = - testify ~init_data spec_name preds datatypes pred_ins name params id - sspec.ss_pre sspec.ss_posts sspec.ss_variant (Some sspec.ss_flag) + testify ~init_data spec_name preds pred_ins name params id sspec.ss_pre + sspec.ss_posts sspec.ss_variant (Some sspec.ss_flag) (Spec.label_vars_to_set sspec.ss_label) sspec.ss_to_verify in @@ -327,7 +325,6 @@ struct ~init_data (spec_name : string) (preds : MP.preds_tbl_t) - (datatypes : Type_env.datatypes_tbl_t) (pred_ins : (string, int list) Hashtbl.t) (spec : Spec.t) : t list * Spec.t = if not spec.spec_to_verify then ([], spec) @@ -353,8 +350,8 @@ struct List.fold_left (fun (id, tests, sspecs) sspec -> let tests_and_specs = - testify_sspec ~init_data spec_name preds datatypes pred_ins - spec.spec_name spec.spec_params id sspec + testify_sspec ~init_data spec_name preds pred_ins spec.spec_name + spec.spec_params id sspec in let new_tests, new_specs = List.fold_left @@ -382,16 +379,15 @@ struct let testify_lemma ~init_data (preds : MP.preds_tbl_t) - (datatypes : Type_env.datatypes_tbl_t) (pred_ins : (string, int list) Hashtbl.t) (lemma : Lemma.t) : t list * Lemma.t = let tests_and_specs = List.concat_map (fun Lemma.{ lemma_hyp; lemma_concs; lemma_spec_variant } -> let to_verify = Option.is_some lemma.lemma_proof in - testify ~init_data lemma.lemma_name preds datatypes pred_ins - lemma.lemma_name lemma.lemma_params 0 lemma_hyp lemma_concs - lemma_spec_variant None None to_verify) + testify ~init_data lemma.lemma_name preds pred_ins lemma.lemma_name + lemma.lemma_params 0 lemma_hyp lemma_concs lemma_spec_variant None + None to_verify) lemma.lemma_specs in let tests, specs = @@ -772,8 +768,7 @@ struct List.concat_map (fun (spec : Spec.t) -> let tests, new_spec = - testify_spec ~init_data spec.spec_name preds prog.datatypes - pred_ins spec + testify_spec ~init_data spec.spec_name preds pred_ins spec in let proc = Prog.get_proc_exn prog spec.spec_name in Hashtbl.replace prog.procs proc.proc_name @@ -802,7 +797,7 @@ struct List.concat_map (fun lemma -> let tests, new_lemma = - testify_lemma ~init_data preds prog.datatypes pred_ins lemma + testify_lemma ~init_data preds pred_ins lemma in Hashtbl.replace prog.lemmas lemma.lemma_name new_lemma; tests) @@ -944,6 +939,7 @@ struct L.Phase.with_normal ~title:"Program verification" @@ fun () -> let open ResultsDir in let open ChangeTracker in + let () = Type_env.init_datatypes prog.datatypes in if incremental && prev_results_exist () then ( (* Only verify changed procedures and lemmas *) let cur_source_files = @@ -1031,8 +1027,7 @@ struct specs |> List.filter_map (fun (spec : Spec.t) -> let tests, new_spec = - testify_spec ~init_data spec.spec_name preds prog.datatypes - pred_ins spec + testify_spec ~init_data spec.spec_name preds pred_ins spec in if List.length tests > 1 then DL.log (fun m -> diff --git a/GillianCore/engine/FOLogic/FOSolver.ml b/GillianCore/engine/FOLogic/FOSolver.ml index f841f83b..c00a26bd 100644 --- a/GillianCore/engine/FOLogic/FOSolver.ml +++ b/GillianCore/engine/FOLogic/FOSolver.ml @@ -40,7 +40,12 @@ let simplify_pfs_and_gamma 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 + let model = + Smt.check_sat fs + (Type_env.as_hashtbl gamma) + (Type_env.get_constructors ()) + (Type_env.get_datatypes ()) + in let lvars = List.fold_left (fun ac vs -> @@ -64,7 +69,10 @@ let check_satisfiability_with_model (fs : Expr.t list) (gamma : Type_env.t) : | None -> None | Some model -> ( try - Smt.lift_model model (Type_env.as_hashtbl gamma) update smt_vars; + Smt.lift_model model + (Type_env.as_hashtbl gamma) + (Type_env.get_datatypes ()) + update smt_vars; Some subst with e -> let () = @@ -88,7 +96,12 @@ let check_satisfiability 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 + let result = + Smt.is_sat fs + (Type_env.as_hashtbl gamma) + (Type_env.get_constructors ()) + (Type_env.get_datatypes ()) + in (* if time <> "" then Utils.Statistics.update_statistics ("FOS: CheckSat: " ^ time) (Sys.time () -. t); *) @@ -201,6 +214,8 @@ let check_entailment Smt.check_sat (Expr.Set.of_list (PFS.to_list formulae)) (Type_env.as_hashtbl gamma_left) + (Type_env.get_constructors ()) + (Type_env.get_datatypes ()) in let ret = Option.is_none model in L.(verbose (fun m -> m "Entailment returned %b" ret)); diff --git a/GillianCore/engine/FOLogic/type_env.ml b/GillianCore/engine/FOLogic/type_env.ml index 6b71f60c..10e29e6c 100644 --- a/GillianCore/engine/FOLogic/type_env.ml +++ b/GillianCore/engine/FOLogic/type_env.ml @@ -6,15 +6,11 @@ module L = Logging type constructors_tbl_t = (string, Constructor.t) Hashtbl.t [@@deriving yojson] type datatypes_tbl_t = (string, Datatype.t) Hashtbl.t [@@deriving yojson] +type t = (string, Type.t) Hashtbl.t [@@deriving yojson] -type t = { - var_types : (string, Type.t) Hashtbl.t; - constructor_defs : constructors_tbl_t; - datatype_defs : datatypes_tbl_t; -} -[@@deriving yojson] - -let as_hashtbl x = x.var_types +let constructor_defs : constructors_tbl_t ref = ref (Hashtbl.create 1) +let datatype_defs : datatypes_tbl_t ref = ref (Hashtbl.create 1) +let as_hashtbl x = x (*************************************) (** Typing Environment Functions **) @@ -22,76 +18,55 @@ let as_hashtbl x = x.var_types (*************************************) (* Initialisation *) -let init ?(datatype_defs = Hashtbl.create Config.medium_tbl_size) () : t = - let constructor_defs = Hashtbl.create Config.medium_tbl_size in - let add_constructor_to_tbl (constructor : Constructor.t) = - Hashtbl.add constructor_defs constructor.constructor_name constructor - in - let add_constructors_to_tbl _ (datatype : Datatype.t) = - List.iter add_constructor_to_tbl datatype.datatype_constructors - in - let () = Hashtbl.iter add_constructors_to_tbl datatype_defs in - { - var_types = Hashtbl.create Config.medium_tbl_size; - datatype_defs; - constructor_defs; - } +let init () : t = Hashtbl.create Config.medium_tbl_size (* Copy *) -let copy { var_types; datatype_defs; constructor_defs } : t = - { - var_types = Hashtbl.copy var_types; - datatype_defs = Hashtbl.copy datatype_defs; - constructor_defs = Hashtbl.copy constructor_defs; - } +let copy x : t = Hashtbl.copy x (* Type of a variable *) -let get (x : t) (var : string) : Type.t option = - Hashtbl.find_opt x.var_types var +let get (x : t) (var : string) : Type.t option = Hashtbl.find_opt x var (* Membership *) -let mem (x : t) (v : string) : bool = Hashtbl.mem x.var_types v +let mem (x : t) (v : string) : bool = Hashtbl.mem x v (* Empty *) -let empty (x : t) : bool = Hashtbl.length x.var_types == 0 +let empty (x : t) : bool = Hashtbl.length x == 0 (* Type of a variable *) let get_unsafe (x : t) (var : string) : Type.t = - match Hashtbl.find_opt x.var_types var with + 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 *) let matchables (x : t) : SS.t = - Hashtbl.fold (fun var _ ac -> SS.add var ac) x.var_types SS.empty + Hashtbl.fold (fun var _ ac -> SS.add var ac) x SS.empty (* Get all variables *) let vars (x : t) : SS.t = - Hashtbl.fold (fun var _ ac -> SS.add var ac) x.var_types SS.empty + Hashtbl.fold (fun var _ ac -> SS.add var ac) x SS.empty (* Get all logical variables *) let lvars (x : t) : SS.t = Hashtbl.fold (fun var _ ac -> if is_lvar_name var then SS.add var ac else ac) - x.var_types SS.empty + x SS.empty (* Get all variables of specific type *) let get_vars_of_type (x : t) (tt : Type.t) : string list = Hashtbl.fold (fun var t ac_vars -> if t = tt then var :: ac_vars else ac_vars) - x.var_types [] + x [] (* Get all var-type pairs as a list *) -let get_var_type_pairs (x : t) : (string * Type.t) Seq.t = - Hashtbl.to_seq x.var_types +let get_var_type_pairs (x : t) : (string * Type.t) Seq.t = Hashtbl.to_seq x (* Iteration *) -let iter (x : t) (f : string -> Type.t -> unit) : unit = - Hashtbl.iter f x.var_types +let iter (x : t) (f : string -> Type.t -> unit) : unit = Hashtbl.iter f x let fold (x : t) (f : string -> Type.t -> 'a -> 'a) (init : 'a) : 'a = - Hashtbl.fold f x.var_types init + Hashtbl.fold f x init let pp fmt tenv = let pp_pair fmt (v, vt) = Fmt.pf fmt "(%s: %s)" v (Type.str vt) in @@ -110,20 +85,20 @@ let pp_by_need vars fmt tenv = let update (te : t) (x : string) (t : Type.t) : unit = match get te x with - | None -> Hashtbl.replace te.var_types x t + | None -> Hashtbl.replace te x t | Some t' when t' = t -> () | Some t' -> Fmt.failwith "Type_env update: Conflict: %s has type %s but required extension is %s" x (Type.str t') (Type.str t) -let remove (te : t) (x : string) : unit = Hashtbl.remove te.var_types x +let remove (te : t) (x : string) : unit = Hashtbl.remove te x (* Extend gamma with more_gamma *) let extend (x : t) (y : t) : unit = iter y (fun v t -> - match Hashtbl.find_opt x.var_types v with - | None -> Hashtbl.replace x.var_types v t + match Hashtbl.find_opt x v with + | None -> Hashtbl.replace x v t | Some t' -> if t <> t' then raise (Failure "Typing environment cannot be extended.")) @@ -169,7 +144,7 @@ let to_list_expr (x : t) : (Expr.t * Type.t) list = (fun x t (pairs : (Expr.t * Type.t) list) -> if Names.is_lvar_name x then (LVar x, t) :: pairs else (PVar x, t) :: pairs) - x.var_types [] + x [] in le_type_pairs @@ -177,13 +152,13 @@ let to_list (x : t) : (Var.t * Type.t) list = let le_type_pairs = Hashtbl.fold (fun x t (pairs : (Var.t * Type.t) list) -> (x, t) :: pairs) - x.var_types [] + x [] in le_type_pairs let reset (x : t) (reset : (Var.t * Type.t) list) = - Hashtbl.clear x.var_types; - List.iter (fun (y, t) -> Hashtbl.replace x.var_types y t) reset + Hashtbl.clear x; + List.iter (fun (y, t) -> Hashtbl.replace x y t) reset let is_well_formed (_ : t) : bool = true @@ -194,17 +169,28 @@ let filter_with_info relevant_info (x : t) = (*************************************) (** Datatype Functions **) - (*************************************) -let get_constructor_type (x : t) (cname : string) : Type.t option = - let constructor = Hashtbl.find_opt x.constructor_defs cname in +let init_datatypes (datatypes : datatypes_tbl_t) = + let constructors = Hashtbl.create Config.medium_tbl_size in + let add_constructor_to_tbl (c : Constructor.t) = + Hashtbl.add constructors c.constructor_name c + in + let add_constructors_to_tbl cs = List.iter add_constructor_to_tbl cs in + Hashtbl.iter + (fun _ (d : Datatype.t) -> add_constructors_to_tbl d.datatype_constructors) + datatypes; + datatype_defs := datatypes; + constructor_defs := constructors + +let get_constructor_type (cname : string) : Type.t option = + let constructor = Hashtbl.find_opt !constructor_defs cname in Option.map (fun (c : Constructor.t) -> Type.DatatypeType c.constructor_datatype) constructor -let get_constructor_type_unsafe (x : t) (cname : string) : Type.t = - let constructor = Hashtbl.find_opt x.constructor_defs cname in +let get_constructor_type_unsafe (cname : string) : Type.t = + let constructor = Hashtbl.find_opt !constructor_defs cname in match constructor with | Some c -> Type.DatatypeType c.constructor_datatype | None -> @@ -213,11 +199,11 @@ let get_constructor_type_unsafe (x : t) (cname : string) : Type.t = ("Type_env.get_constructor_type_unsafe: constructor " ^ cname ^ " not found.")) -let get_constructor_field_types (x : t) (cname : string) : - Type.t option list option = - let constructor = Hashtbl.find_opt x.constructor_defs cname in +let get_constructor_field_types (cname : string) : Type.t option list option = + let constructor = Hashtbl.find_opt !constructor_defs cname in Option.map (fun (c : Constructor.t) -> c.constructor_fields) constructor -let keeping_datatypes (x : t) : t = - let datatype_defs = Hashtbl.copy x.datatype_defs in - init ~datatype_defs () +let get_datatypes () : Datatype.t list = + List.of_seq (Hashtbl.to_seq_values !datatype_defs) + +let get_constructors () : constructors_tbl_t = !constructor_defs diff --git a/GillianCore/engine/FOLogic/type_env.mli b/GillianCore/engine/FOLogic/type_env.mli index 17c1904e..12097c40 100644 --- a/GillianCore/engine/FOLogic/type_env.mli +++ b/GillianCore/engine/FOLogic/type_env.mli @@ -21,7 +21,7 @@ val get : t -> string -> Type.t option val get_unsafe : t -> string -> Type.t val get_var_type_pairs : t -> (string * Type.t) Seq.t val get_vars_of_type : t -> Type.t -> string list -val init : ?datatype_defs:datatypes_tbl_t -> unit -> t +val init : unit -> t val mem : t -> string -> bool val empty : t -> bool val pp : Format.formatter -> t -> unit @@ -42,7 +42,9 @@ val is_well_formed : t -> bool val filter_with_info : Containers.SS.t * Containers.SS.t * Containers.SS.t -> t -> t -val get_constructor_type : t -> string -> Type.t option -val get_constructor_type_unsafe : t -> string -> Type.t -val get_constructor_field_types : t -> string -> Type.t option list option -val keeping_datatypes : t -> t +val get_constructor_type : string -> Type.t option +val get_constructor_type_unsafe : string -> Type.t +val get_constructor_field_types : string -> Type.t option list option +val get_datatypes : unit -> Datatype.t list +val get_constructors : unit -> constructors_tbl_t +val init_datatypes : datatypes_tbl_t -> unit diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index 0d9b41f2..32996e69 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -154,7 +154,7 @@ module Infer_types_to_gamma = struct | 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 | Constructor (n, les) -> ( - let field_types = Type_env.get_constructor_field_types gamma n in + let field_types = Type_env.get_constructor_field_types n in let check_field le tt = match tt with | Some tt -> f le tt @@ -164,7 +164,7 @@ module Infer_types_to_gamma = struct | Some tts -> if List.length tts <> List.length les then false else - tt = Type_env.get_constructor_type_unsafe gamma n + tt = Type_env.get_constructor_type_unsafe n && List.for_all2 check_field les tts | None -> false) | Exists (bt, le) | ForAll (bt, le) -> @@ -198,7 +198,7 @@ let reverse_type_lexpr (flag : bool) (gamma : Type_env.t) (e_types : (Expr.t * Type.t) list) : Type_env.t option = - let new_gamma = Type_env.keeping_datatypes gamma in + let new_gamma = Type_env.init () in let ret = List.fold_left (fun ac (e, t) -> ac && infer_types_to_gamma flag gamma new_gamma e t) @@ -474,11 +474,11 @@ module Type_lexpr = struct if not ite then def_neg else infer_type gamma le BooleanType and type_constructor gamma n les = - let tts_opt = Type_env.get_constructor_field_types gamma n in + let tts_opt = Type_env.get_constructor_field_types n in match tts_opt with | Some tts -> if typable_list gamma ?target_types:(Some tts) les then - def_pos (Type_env.get_constructor_type gamma n) + def_pos (Type_env.get_constructor_type n) else def_neg | None -> def_neg diff --git a/GillianCore/smt/smt.ml b/GillianCore/smt/smt.ml index e00a1fa9..a6b0cc7f 100644 --- a/GillianCore/smt/smt.ml +++ b/GillianCore/smt/smt.ml @@ -22,8 +22,8 @@ let () = z3_config |> List.iter (fun (k, v) -> cmd (set_option (":" ^ k) v)) exception SMT_unknown let pp_sexp = Sexplib.Sexp.pp_hum -let init_decls : sexp list ref = ref [] let builtin_funcs : sexp list ref = ref [] +let initialised : bool ref = ref false let sanitize_identifier = let pattern = Str.regexp "#" in @@ -34,6 +34,7 @@ let is_true = function | _ -> false type typenv = (string, Type.t) Hashtbl.t [@@deriving to_yojson] +type constructorstbl = (string, Constructor.t) Hashtbl.t [@@deriving to_yojson] let fs_to_yojson fs = fs |> Expr.Set.to_list |> list_to_yojson Expr.to_yojson @@ -116,6 +117,10 @@ module Variant = struct val access : sexp -> sexp end + module type Nary = sig + include S + end + let nul ?recognizer name = let recognizer = Option.value recognizer ~default:("is" ^ name) in let module M = struct @@ -138,6 +143,18 @@ module Variant = struct let access x = accessor <| x end in (module M : Unary) + + let n ?recognizer name param_typs = + let module N = (val nul ?recognizer name : Nullary) in + let module M = struct + include N + + let params = + List.mapi + (fun i param_typ -> ("param-" ^ string_of_int i, param_typ)) + param_typs + end in + (module M : Nary) end let declare_recognizer ~name ~constructor ~typ = @@ -146,7 +163,7 @@ let declare_recognizer ~name ~constructor ~typ = t_bool (list [ atom "_"; atom "is"; atom constructor ] <| atom "x") -let mk_datatype name type_params (variants : (module Variant.S) list) = +let mk_datatype' name type_params (variants : (module Variant.S) list) = let constructors, recognizer_defs = variants |> List.map (fun v -> @@ -159,9 +176,28 @@ let mk_datatype name type_params (variants : (module Variant.S) list) = (constructor, recognizer_def)) |> List.split in + let datatype = (name, type_params, constructors) in + (datatype, recognizer_defs) + +let mk_datatype name type_params (variants : (module Variant.S) list) = + let (_, _, constructors), recognizer_defs = + mk_datatype' name type_params variants + in let decl = declare_datatype name type_params constructors in - let () = init_decls := recognizer_defs @ (decl :: !init_decls) in - atom name + decl :: recognizer_defs + +(* Mutually recursive Datatypes *) +let mk_datatypes + (datatypes : (string * string list * (module Variant.S) list) list) = + let datatypes, recognizer_defs = + List.split + (List.map + (fun (name, type_params, variants) -> + mk_datatype' name type_params variants) + datatypes) + in + let decl = declare_datatypes datatypes in + decl :: List.concat recognizer_defs let mk_fun_decl name param_types result_type = let decl = declare_fun name param_types result_type in @@ -184,8 +220,11 @@ module Type_operations = struct module Set = (val nul "SetType" : Nullary) module Datatype = (val un "DatatypeType" "datatype-id" t_int) - let t_gil_type = - mk_datatype "GIL_Type" [] + let gil_type_name = "GIL_Type" + let t_gil_type = atom gil_type_name + + let init_decls = + mk_datatype gil_type_name [] [ (module Undefined : Variant.S); (module Null : Variant.S); @@ -210,6 +249,52 @@ module Lit_operations = struct let gil_literal_name = "GIL_Literal" let t_gil_literal = atom gil_literal_name + let t_gil_literal_list = t_seq t_gil_literal + let t_gil_literal_set = t_set t_gil_literal + + let native_sort_of_type = + let open Type in + function + | IntType | StringType | ObjectType -> t_int + | ListType -> t_seq t_gil_literal + | BooleanType -> t_bool + | NumberType -> t_real + | UndefinedType | NoneType | EmptyType | NullType -> t_gil_literal + | SetType -> t_set t_gil_literal + | TypeType -> t_gil_type + | DatatypeType name -> atom name + + let mk_constructor Constructor.{ constructor_name; constructor_fields; _ } = + let param_typ t = + Option.map native_sort_of_type t |> Option.value ~default:t_gil_literal + in + let param_typs = List.map param_typ constructor_fields in + let module N = (val n constructor_name param_typs : Variant.Nary) in + (module N : Variant.S) + + let mk_user_def_datatype Datatype.{ datatype_name; datatype_constructors; _ } + = + let variants = List.map mk_constructor datatype_constructors in + (datatype_name, [], variants) + + let mk_user_def_datatypes (datatypes : Datatype.t list) = + List.map mk_user_def_datatype datatypes + + let user_def_datatype_lit_variant_name (datatype_name : string) = + "Datatype" ^ datatype_name + + let user_def_datatype_lit_param_name (datatype_name : string) = + datatype_name ^ "Value" + + let mk_user_def_datatype_lit_variant Datatype.{ datatype_name; _ } = + let variant_name = user_def_datatype_lit_variant_name datatype_name in + let t_datatype = atom datatype_name in + let parameter_name = user_def_datatype_lit_param_name datatype_name in + let module N = (val un variant_name parameter_name t_datatype : Unary) in + (module N : Variant.S) + + let mk_user_def_datatype_lit_variants datatypes = + List.map mk_user_def_datatype_lit_variant datatypes module Undefined = (val nul "Undefined" : Nullary) module Null = (val nul "Null" : Nullary) @@ -223,8 +308,13 @@ module Lit_operations = struct module List = (val un "List" "listValue" (t_seq t_gil_literal) : Unary) module None = (val nul "None" : Nullary) - let _ = - mk_datatype gil_literal_name [] + module Datatype = struct + let access (name : string) (x : sexp) = + atom (user_def_datatype_lit_param_name name) <| x + end + + let init_decls user_def_datatypes = + let gil_literal_variants = [ (module Undefined : Variant.S); (module Null : Variant.S); @@ -238,11 +328,22 @@ module Lit_operations = struct (module List : Variant.S); (module None : Variant.S); ] + in + let gil_literal_user_def_variants = + mk_user_def_datatype_lit_variants user_def_datatypes + in + let gil_literal_datatype = + ( gil_literal_name, + [], + gil_literal_variants @ gil_literal_user_def_variants ) + in + mk_datatypes + (gil_literal_datatype :: mk_user_def_datatypes user_def_datatypes) end let t_gil_literal = Lit_operations.t_gil_literal -let t_gil_literal_list = t_seq t_gil_literal -let t_gil_literal_set = t_set t_gil_literal +let t_gil_literal_list = Lit_operations.t_gil_literal_list +let t_gil_literal_set = Lit_operations.t_gil_literal_set let seq_of ~typ = function | [] -> as_type (atom "seq.empty") typ @@ -263,7 +364,10 @@ module Ext_lit_operations = struct module Gil_set = (val un "Set" "setElem" t_gil_literal_set : Unary) - let t_gil_ext_literal = + let gil_ext_literal_name = "Extended_GIL_Literal" + let t_gil_ext_literal = atom gil_ext_literal_name + + let init_decls = mk_datatype "Extended_GIL_Literal" [] [ (module Gil_sing_elem : Variant.S); (module Gil_set : Variant.S) ] end @@ -331,7 +435,7 @@ module Encoding = struct | UndefinedType | NoneType | EmptyType | NullType -> t_gil_literal | SetType -> t_gil_literal_set | TypeType -> t_gil_type - | DatatypeType _ -> failwith "TODO" + | DatatypeType name -> atom name type t = { consts : (string * sexp) Hashset.t; [@default Hashset.empty ()] @@ -411,10 +515,10 @@ module Encoding = struct | TypeType -> Type.construct | BooleanType -> Bool.construct | ListType -> List.construct + | DatatypeType name -> ( <| ) (atom ("Datatype" ^ name)) | UndefinedType | NullType | EmptyType | NoneType | SetType -> Fmt.failwith "Cannot simple-wrap value of type %s" (Gil_syntax.Type.str typ) - | DatatypeType _ -> failwith "TODO" in construct expr | Extended_wrapped -> Ext_lit_operations.Gil_sing_elem.access expr @@ -437,6 +541,24 @@ module Encoding = struct | _ -> failwith "wrong encoding of set" let get_string = get_native ~accessor:Lit_operations.String.access + + let get_native_of_type ~(typ : Type.t) = + let open Lit_operations in + let accessor = + match typ with + | IntType -> Int.access + | NumberType -> Num.access + | StringType -> String.access + | ObjectType -> Loc.access + | TypeType -> Type.access + | BooleanType -> Bool.access + | ListType -> List.access + | DatatypeType name -> Datatype.access name + | UndefinedType | NullType | EmptyType | NoneType | SetType -> + Fmt.failwith "Cannot get native value of type %s" + (Gil_syntax.Type.str typ) + in + get_native ~accessor end let typeof_simple e = @@ -678,12 +800,14 @@ let encode_unop ~llen_lvars ~e (op : UnOp.t) le = let encode_quantified_expr ~(encode_expr : gamma:typenv -> + constructor_defs:constructorstbl -> llen_lvars:SS.t -> list_elem_vars:SS.t -> 'a -> Encoding.t) ~mk_quant ~gamma + ~constructor_defs ~llen_lvars ~list_elem_vars quantified_vars @@ -693,7 +817,9 @@ let encode_quantified_expr match quantified_vars with | [] -> (* A quantified assertion with no quantified variables is just the assertion *) - Some (encode_expr ~gamma ~llen_lvars ~list_elem_vars assertion) + Some + (encode_expr ~gamma ~constructor_defs ~llen_lvars ~list_elem_vars + assertion) | _ -> None in (* Start by updating gamma with the information provided by quantifier types. @@ -708,7 +834,9 @@ let encode_quantified_expr in (* Not the same gamma now!*) let encoded_assertion, consts, extra_asrts = - match encode_expr ~gamma ~llen_lvars ~list_elem_vars assertion with + match + encode_expr ~gamma ~constructor_defs ~llen_lvars ~list_elem_vars assertion + with | { kind = Native BooleanType; expr; consts; extra_asrts } -> (expr, consts, extra_asrts) | _ -> failwith "the thing inside forall is not boolean!" @@ -734,11 +862,15 @@ let encode_quantified_expr let rec encode_logical_expression ~(gamma : typenv) + ~(constructor_defs : constructorstbl) ~(llen_lvars : SS.t) ~(list_elem_vars : SS.t) (le : Expr.t) : Encoding.t = let open Encoding in - let f = encode_logical_expression ~gamma ~llen_lvars ~list_elem_vars in + let f = + encode_logical_expression ~gamma ~constructor_defs ~llen_lvars + ~list_elem_vars + in match le with | Lit lit -> encode_lit lit @@ -780,20 +912,34 @@ let rec encode_logical_expression seq_extract lst start len >- ListType | Exists (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression - ~mk_quant:exists ~gamma ~llen_lvars ~list_elem_vars bt e + ~mk_quant:exists ~gamma ~constructor_defs ~llen_lvars ~list_elem_vars bt + e | ForAll (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression - ~mk_quant:forall ~gamma ~llen_lvars ~list_elem_vars bt e - | Constructor _ -> failwith "TODO" (* TODO *) + ~mk_quant:forall ~gamma ~constructor_defs ~llen_lvars ~list_elem_vars bt + e + | Constructor (name, les) -> + let c = Hashtbl.find constructor_defs name in + let param_typs = c.constructor_fields in + let simple_wrap_or_native typopt = + match typopt with + | Some typ -> get_native_of_type ~typ + | None -> simple_wrap + in + let>-- args = List.map f les in + let args = List.map2 simple_wrap_or_native param_typs args in + let sexp = atom name $$ args in + sexp >- DatatypeType c.constructor_datatype let encode_assertion_top_level ~(gamma : typenv) + ~(constructor_defs : constructorstbl) ~(llen_lvars : SS.t) ~(list_elem_vars : SS.t) (a : Expr.t) : Encoding.t = try - encode_logical_expression ~gamma ~llen_lvars ~list_elem_vars - (Expr.push_in_negations a) + encode_logical_expression ~gamma ~constructor_defs ~llen_lvars + ~list_elem_vars (Expr.push_in_negations a) with e -> let s = Printexc.to_string e in let msg = @@ -866,14 +1012,19 @@ let lvars_as_list_elements (assertions : Expr.Set.t) : SS.t = SS.union new_lvars acc) assertions SS.empty -let encode_assertions (fs : Expr.Set.t) (gamma : typenv) : sexp list = +let encode_assertions + (fs : Expr.Set.t) + (gamma : typenv) + (constructor_defs : constructorstbl) : 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 = Expr.Set.elements fs - |> List.map (encode_assertion_top_level ~gamma ~llen_lvars ~list_elem_vars) + |> List.map + (encode_assertion_top_level ~gamma ~constructor_defs ~llen_lvars + ~list_elem_vars) in let consts = Hashtbl.fold @@ -929,21 +1080,43 @@ module Dump = struct cmds) end -let reset_solver () = - let () = cmd (pop 1) in - let () = RepeatCache.clear () in - let () = cmd (push 1) in - () +let init_solver (user_def_datatypes : Datatype.t list) = + let init_decls = + [ + Type_operations.init_decls; + Lit_operations.init_decls user_def_datatypes; + Ext_lit_operations.init_decls; + ] + in + let decls = List.concat init_decls in + let () = decls |> List.iter cmd in + cmd (push 1) + +let init_or_reset_solver (user_def_datatypes : Datatype.t list) = + if not !initialised then ( + (* If solver has not been initialised, initialise it *) + init_solver user_def_datatypes; + initialised := true) + else + (* Otherwise reset it *) + let () = cmd (pop 1) in + let () = RepeatCache.clear () in + let () = cmd (push 1) in + () -let exec_sat' (fs : Expr.Set.t) (gamma : typenv) : sexp option = +let exec_sat' + (fs : Expr.Set.t) + (gamma : typenv) + (constructor_defs : constructorstbl) + (datatype_defs : Datatype.t list) : 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") Expr.Set.iter Expr.pp) fs pp_typenv gamma) in - let () = reset_solver () in - let encoded_assertions = encode_assertions fs gamma in + let () = init_or_reset_solver datatype_defs in + let encoded_assertions = encode_assertions fs gamma constructor_defs in let () = if !Config.dump_smt then Dump.dump fs gamma encoded_assertions in let () = List.iter cmd !builtin_funcs in let () = List.iter cmd encoded_assertions in @@ -977,8 +1150,12 @@ let exec_sat' (fs : Expr.Set.t) (gamma : typenv) : sexp option = in ret -let exec_sat (fs : Expr.Set.t) (gamma : typenv) : sexp option = - try exec_sat' fs gamma +let exec_sat + (fs : Expr.Set.t) + (gamma : typenv) + (constructor_defs : constructorstbl) + (datatype_defs : Datatype.t list) : sexp option = + try exec_sat' fs gamma constructor_defs datatype_defs with UnexpectedSolverResponse _ as e -> let additional_data = [ @@ -989,7 +1166,11 @@ let exec_sat (fs : Expr.Set.t) (gamma : typenv) : sexp option = in raise Gillian_result.Exc.(internal_error ~additional_data "SMT failure") -let check_sat (fs : Expr.Set.t) (gamma : typenv) : sexp option = +let check_sat + (fs : Expr.Set.t) + (gamma : typenv) + (constructor_defs : constructorstbl) + (datatype_defs : Datatype.t list) : sexp option = match Hashtbl.find_opt sat_cache fs with | Some result -> let () = @@ -999,7 +1180,7 @@ let check_sat (fs : Expr.Set.t) (gamma : typenv) : sexp option = result | None -> let () = L.verbose (fun m -> m "SAT check not found in cache") in - let ret = exec_sat fs gamma in + let ret = exec_sat fs gamma constructor_defs datatype_defs in let () = L.verbose (fun m -> let f = Expr.conjunct (Expr.Set.elements fs) in @@ -1008,15 +1189,20 @@ let check_sat (fs : Expr.Set.t) (gamma : typenv) : sexp option = let () = Hashtbl.replace sat_cache fs ret in ret -let is_sat (fs : Expr.Set.t) (gamma : typenv) : bool = - check_sat fs gamma |> Option.is_some +let is_sat + (fs : Expr.Set.t) + (gamma : typenv) + (constructor_defs : constructorstbl) + (datatype_defs : Datatype.t list) : bool = + check_sat fs gamma constructor_defs datatype_defs |> Option.is_some let lift_model (model : sexp) (gamma : typenv) + (datatype_defs : Datatype.t list) (subst_update : string -> Expr.t -> unit) (target_vars : Expr.Set.t) : unit = - let () = reset_solver () in + let () = init_or_reset_solver datatype_defs in let model_eval = (model_eval' solver model).eval [] in let get_val x = @@ -1072,8 +1258,3 @@ let lift_model m "SMT binding for %s: %s\n" x binding) in v |> Option.iter (fun v -> subst_update x (Expr.Lit v))) - -let () = - let decls = List.rev !init_decls in - let () = decls |> List.iter cmd in - cmd (push 1) diff --git a/GillianCore/smt/smt.mli b/GillianCore/smt/smt.mli index 18cebade..d1443346 100644 --- a/GillianCore/smt/smt.mli +++ b/GillianCore/smt/smt.mli @@ -2,15 +2,31 @@ open Gil_syntax exception SMT_unknown -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 exec_sat : + Expr.Set.t -> + (string, Type.t) Hashtbl.t -> + (string, Constructor.t) Hashtbl.t -> + Datatype.t list -> + Sexplib.Sexp.t option + +val is_sat : + Expr.Set.t -> + (string, Type.t) Hashtbl.t -> + (string, Constructor.t) Hashtbl.t -> + Datatype.t list -> + bool val check_sat : - Expr.Set.t -> (string, Type.t) Hashtbl.t -> Sexplib.Sexp.t option + Expr.Set.t -> + (string, Type.t) Hashtbl.t -> + (string, Constructor.t) Hashtbl.t -> + Datatype.t list -> + Sexplib.Sexp.t option val lift_model : Sexplib.Sexp.t -> (string, Type.t) Hashtbl.t -> + Datatype.t list -> (string -> Expr.t -> unit) -> Expr.Set.t -> unit diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl index 9fc0bc4c..881149c4 100644 --- a/wisl/examples/SLL_adt.wisl +++ b/wisl/examples/SLL_adt.wisl @@ -32,7 +32,7 @@ function SLL_allocate_node(v){ [t] := v; return t } -{ SLL(ret, Cons(#v, Nil)) } +{ SLL(ret, Cons(#v, Nil())) } // From 077d6f55bc574ea51c65c5a4e415a6db4f529182 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Thu, 24 Apr 2025 16:17:10 +0100 Subject: [PATCH 19/37] Moved smt into engine. --- GillianCore/{smt => engine/FOLogic}/smt.ml | 0 GillianCore/{smt => engine/FOLogic}/smt.mli | 0 GillianCore/engine/dune | 5 +++-- GillianCore/monadic/delayed.ml | 1 + GillianCore/monadic/dune | 2 +- GillianCore/smt/dune | 7 ------- 6 files changed, 5 insertions(+), 10 deletions(-) rename GillianCore/{smt => engine/FOLogic}/smt.ml (100%) rename GillianCore/{smt => engine/FOLogic}/smt.mli (100%) delete mode 100644 GillianCore/smt/dune diff --git a/GillianCore/smt/smt.ml b/GillianCore/engine/FOLogic/smt.ml similarity index 100% rename from GillianCore/smt/smt.ml rename to GillianCore/engine/FOLogic/smt.ml diff --git a/GillianCore/smt/smt.mli b/GillianCore/engine/FOLogic/smt.mli similarity index 100% rename from GillianCore/smt/smt.mli rename to GillianCore/engine/FOLogic/smt.mli diff --git a/GillianCore/engine/dune b/GillianCore/engine/dune index dbeebc87..fde0afa9 100644 --- a/GillianCore/engine/dune +++ b/GillianCore/engine/dune @@ -5,7 +5,6 @@ (public_name gillian.engine) (libraries utils - smt menhirLib fmt cmdliner @@ -14,7 +13,9 @@ gil_parsing logging incrementalAnalysis - debugger_log) + debugger_log + simple_smt + sexplib) (preprocess (pps ppx_deriving.std ppx_deriving_yojson)) (flags diff --git a/GillianCore/monadic/delayed.ml b/GillianCore/monadic/delayed.ml index deae9e9a..5436ade0 100644 --- a/GillianCore/monadic/delayed.ml +++ b/GillianCore/monadic/delayed.ml @@ -1,5 +1,6 @@ module Expr = Gil_syntax.Expr module Type = Gil_syntax.Type +module Smt = Engine.Smt exception NonExhaustiveEntailment of Expr.t list diff --git a/GillianCore/monadic/dune b/GillianCore/monadic/dune index d54a77f3..32d89b3d 100644 --- a/GillianCore/monadic/dune +++ b/GillianCore/monadic/dune @@ -2,6 +2,6 @@ (name monadic) (public_name gillian.monadic) (flags -open Utils.Prelude) - (libraries gil_syntax engine utils fmt logging smt) + (libraries gil_syntax engine utils fmt logging) (preprocess (pps ppx_deriving.std ppx_deriving_yojson))) diff --git a/GillianCore/smt/dune b/GillianCore/smt/dune deleted file mode 100644 index 5f83de17..00000000 --- a/GillianCore/smt/dune +++ /dev/null @@ -1,7 +0,0 @@ -(library - (name smt) - (public_name gillian.smt) - (libraries gil_syntax utils simple_smt sexplib) - (preprocess - (pps ppx_deriving.std ppx_deriving_yojson)) - (flags :standard -open Utils.Prelude)) From 742a352f7213b3670bfd396a089c6908fd67a139 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Fri, 25 Apr 2025 16:08:03 +0100 Subject: [PATCH 20/37] Created datatype env and refactored --- GillianCore/engine/Abstraction/Verifier.ml | 5 +- GillianCore/engine/FOLogic/FOSolver.ml | 25 +-- GillianCore/engine/FOLogic/smt.ml | 153 +++++++----------- GillianCore/engine/FOLogic/smt.mli | 27 +--- GillianCore/engine/FOLogic/typing.ml | 48 +++--- .../engine/logical_env/datatype_env.ml | 83 ++++++++++ .../engine/logical_env/datatype_env.mli | 9 ++ .../{FOLogic => logical_env}/type_env.ml | 43 ----- .../{FOLogic => logical_env}/type_env.mli | 7 - 9 files changed, 192 insertions(+), 208 deletions(-) create mode 100644 GillianCore/engine/logical_env/datatype_env.ml create mode 100644 GillianCore/engine/logical_env/datatype_env.mli rename GillianCore/engine/{FOLogic => logical_env}/type_env.ml (76%) rename GillianCore/engine/{FOLogic => logical_env}/type_env.mli (83%) diff --git a/GillianCore/engine/Abstraction/Verifier.ml b/GillianCore/engine/Abstraction/Verifier.ml index f018530a..2e416c20 100644 --- a/GillianCore/engine/Abstraction/Verifier.ml +++ b/GillianCore/engine/Abstraction/Verifier.ml @@ -939,7 +939,10 @@ struct L.Phase.with_normal ~title:"Program verification" @@ fun () -> let open ResultsDir in let open ChangeTracker in - let () = Type_env.init_datatypes prog.datatypes in + (* Prepare datatype env *) + let () = Datatype_env.init prog.datatypes in + let () = Smt.init () in + if incremental && prev_results_exist () then ( (* Only verify changed procedures and lemmas *) let cur_source_files = diff --git a/GillianCore/engine/FOLogic/FOSolver.ml b/GillianCore/engine/FOLogic/FOSolver.ml index c00a26bd..97827d31 100644 --- a/GillianCore/engine/FOLogic/FOSolver.ml +++ b/GillianCore/engine/FOLogic/FOSolver.ml @@ -40,12 +40,7 @@ let simplify_pfs_and_gamma 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) - (Type_env.get_constructors ()) - (Type_env.get_datatypes ()) - in + let model = Smt.check_sat fs gamma in let lvars = List.fold_left (fun ac vs -> @@ -69,10 +64,7 @@ let check_satisfiability_with_model (fs : Expr.t list) (gamma : Type_env.t) : | None -> None | Some model -> ( try - Smt.lift_model model - (Type_env.as_hashtbl gamma) - (Type_env.get_datatypes ()) - update smt_vars; + Smt.lift_model model gamma update smt_vars; Some subst with e -> let () = @@ -96,12 +88,7 @@ let check_satisfiability 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) - (Type_env.get_constructors ()) - (Type_env.get_datatypes ()) - in + let result = Smt.is_sat fs gamma in (* if time <> "" then Utils.Statistics.update_statistics ("FOS: CheckSat: " ^ time) (Sys.time () -. t); *) @@ -211,11 +198,7 @@ let check_entailment let _ = Simplifications.simplify_pfs_and_gamma formulae gamma_left in let model = - Smt.check_sat - (Expr.Set.of_list (PFS.to_list formulae)) - (Type_env.as_hashtbl gamma_left) - (Type_env.get_constructors ()) - (Type_env.get_datatypes ()) + Smt.check_sat (Expr.Set.of_list (PFS.to_list formulae)) gamma in let ret = Option.is_none model in L.(verbose (fun m -> m "Entailment returned %b" ret)); diff --git a/GillianCore/engine/FOLogic/smt.ml b/GillianCore/engine/FOLogic/smt.ml index a6b0cc7f..79dd06b6 100644 --- a/GillianCore/engine/FOLogic/smt.ml +++ b/GillianCore/engine/FOLogic/smt.ml @@ -33,16 +33,11 @@ let is_true = function | Sexplib.Sexp.Atom "true" -> true | _ -> false -type typenv = (string, Type.t) Hashtbl.t [@@deriving to_yojson] -type constructorstbl = (string, Constructor.t) Hashtbl.t [@@deriving to_yojson] - let fs_to_yojson fs = fs |> Expr.Set.to_list |> list_to_yojson Expr.to_yojson let sexps_to_yojson sexps = `List (List.map (fun sexp -> `String (Sexplib.Sexp.to_string_hum sexp)) sexps) -let pp_typenv = Fmt.(Dump.hashtbl string (Fmt.of_to_string Type.str)) - let encoding_cache : (Expr.Set.t, sexp list) Hashtbl.t = Hashtbl.create Config.big_tbl_size @@ -799,15 +794,13 @@ let encode_unop ~llen_lvars ~e (op : UnOp.t) le = let encode_quantified_expr ~(encode_expr : - gamma:typenv -> - constructor_defs:constructorstbl -> + gamma:Type_env.t -> llen_lvars:SS.t -> list_elem_vars:SS.t -> 'a -> Encoding.t) ~mk_quant ~gamma - ~constructor_defs ~llen_lvars ~list_elem_vars quantified_vars @@ -817,26 +810,22 @@ let encode_quantified_expr match quantified_vars with | [] -> (* A quantified assertion with no quantified variables is just the assertion *) - Some - (encode_expr ~gamma ~constructor_defs ~llen_lvars ~list_elem_vars - assertion) + Some (encode_expr ~gamma ~llen_lvars ~list_elem_vars assertion) | _ -> None in (* Start by updating gamma with the information provided by quantifier types. There's very few foralls, so it's ok to copy the gamma entirely *) - let gamma = Hashtbl.copy gamma in + let gamma = Type_env.copy gamma in let () = quantified_vars |> List.iter (fun (x, typ) -> match typ with - | None -> Hashtbl.remove gamma x - | Some typ -> Hashtbl.replace gamma x typ) + | None -> Type_env.remove gamma x + | Some typ -> Type_env.update gamma x typ) in (* Not the same gamma now!*) let encoded_assertion, consts, extra_asrts = - match - encode_expr ~gamma ~constructor_defs ~llen_lvars ~list_elem_vars assertion - with + match encode_expr ~gamma ~llen_lvars ~list_elem_vars assertion with | { kind = Native BooleanType; expr; consts; extra_asrts } -> (expr, consts, extra_asrts) | _ -> failwith "the thing inside forall is not boolean!" @@ -861,22 +850,18 @@ let encode_quantified_expr native ~consts ~extra_asrts BooleanType expr let rec encode_logical_expression - ~(gamma : typenv) - ~(constructor_defs : constructorstbl) + ~(gamma : Type_env.t) ~(llen_lvars : SS.t) ~(list_elem_vars : SS.t) (le : Expr.t) : Encoding.t = let open Encoding in - let f = - encode_logical_expression ~gamma ~constructor_defs ~llen_lvars - ~list_elem_vars - in + let f = encode_logical_expression ~gamma ~llen_lvars ~list_elem_vars in match le with | Lit lit -> encode_lit lit | LVar var -> let kind, typ = - match Hashtbl.find_opt gamma var with + match Type_env.get gamma var with | Some typ -> (Native typ, native_sort_of_type typ) | None -> if SS.mem var list_elem_vars then (Simple_wrapped, t_gil_literal) @@ -912,39 +897,40 @@ let rec encode_logical_expression seq_extract lst start len >- ListType | Exists (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression - ~mk_quant:exists ~gamma ~constructor_defs ~llen_lvars ~list_elem_vars bt - e + ~mk_quant:exists ~gamma ~llen_lvars ~list_elem_vars bt e | ForAll (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression - ~mk_quant:forall ~gamma ~constructor_defs ~llen_lvars ~list_elem_vars bt - e - | Constructor (name, les) -> - let c = Hashtbl.find constructor_defs name in - let param_typs = c.constructor_fields in - let simple_wrap_or_native typopt = - match typopt with - | Some typ -> get_native_of_type ~typ - | None -> simple_wrap - in - let>-- args = List.map f les in - let args = List.map2 simple_wrap_or_native param_typs args in - let sexp = atom name $$ args in - sexp >- DatatypeType c.constructor_datatype + ~mk_quant:forall ~gamma ~llen_lvars ~list_elem_vars bt e + | Constructor (name, les) -> ( + let param_typs = Datatype_env.get_constructor_field_types name in + match param_typs with + | Some param_typs -> + let simple_wrap_or_native typopt = + match typopt with + | Some typ -> get_native_of_type ~typ + | None -> simple_wrap + in + let>-- args = List.map f les in + let args = List.map2 simple_wrap_or_native param_typs args in + let sexp = atom name $$ args in + sexp >- Datatype_env.get_constructor_type_unsafe name + | None -> + let msg = "SMT - Undefined constructor: " ^ name in + raise (Failure msg)) let encode_assertion_top_level - ~(gamma : typenv) - ~(constructor_defs : constructorstbl) + ~(gamma : Type_env.t) ~(llen_lvars : SS.t) ~(list_elem_vars : SS.t) (a : Expr.t) : Encoding.t = try - encode_logical_expression ~gamma ~constructor_defs ~llen_lvars - ~list_elem_vars (Expr.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" Expr.pp a - pp_typenv gamma s + Type_env.pp gamma s in let () = L.print_to_all msg in raise e @@ -1012,19 +998,14 @@ let lvars_as_list_elements (assertions : Expr.Set.t) : SS.t = SS.union new_lvars acc) assertions SS.empty -let encode_assertions - (fs : Expr.Set.t) - (gamma : typenv) - (constructor_defs : constructorstbl) : sexp list = +let encode_assertions (fs : Expr.Set.t) (gamma : Type_env.t) : 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 = Expr.Set.elements fs - |> List.map - (encode_assertion_top_level ~gamma ~constructor_defs ~llen_lvars - ~list_elem_vars) + |> List.map (encode_assertion_top_level ~gamma ~llen_lvars ~list_elem_vars) in let consts = Hashtbl.fold @@ -1075,28 +1056,31 @@ module Dump = struct (Format.formatter_of_out_channel c) "GIL query:\nFS: %a\nGAMMA: %a\nEncoded as SMT Query:\n%a@?" (Fmt.iter ~sep:Fmt.comma Expr.Set.iter Expr.pp) - fs pp_typenv gamma + fs Type_env.pp gamma (Fmt.list ~sep:(Fmt.any "\n") Sexplib.Sexp.pp_hum) cmds) end -let init_solver (user_def_datatypes : Datatype.t list) = +let init () = + if !initialised then + (* Solver has already been initialised *) + (* Pop off initial declarations if necessary *) + cmd (pop 2); + cmd (push 1); let init_decls = [ Type_operations.init_decls; - Lit_operations.init_decls user_def_datatypes; + Lit_operations.init_decls (Datatype_env.get_datatypes ()); Ext_lit_operations.init_decls; ] in let decls = List.concat init_decls in let () = decls |> List.iter cmd in - cmd (push 1) + cmd (push 1); + initialised := true -let init_or_reset_solver (user_def_datatypes : Datatype.t list) = - if not !initialised then ( - (* If solver has not been initialised, initialise it *) - init_solver user_def_datatypes; - initialised := true) +let init_or_reset () = + if not !initialised then init () else (* Otherwise reset it *) let () = cmd (pop 1) in @@ -1104,19 +1088,15 @@ let init_or_reset_solver (user_def_datatypes : Datatype.t list) = let () = cmd (push 1) in () -let exec_sat' - (fs : Expr.Set.t) - (gamma : typenv) - (constructor_defs : constructorstbl) - (datatype_defs : Datatype.t list) : sexp option = +let exec_sat' (fs : Expr.Set.t) (gamma : Type_env.t) : 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") Expr.Set.iter Expr.pp) - fs pp_typenv gamma) + fs Type_env.pp gamma) in - let () = init_or_reset_solver datatype_defs in - let encoded_assertions = encode_assertions fs gamma constructor_defs in + let () = init_or_reset () in + let encoded_assertions = encode_assertions fs gamma in let () = if !Config.dump_smt then Dump.dump fs gamma encoded_assertions in let () = List.iter cmd !builtin_funcs in let () = List.iter cmd encoded_assertions in @@ -1138,7 +1118,7 @@ let exec_sat' let additional_data = [ ("expressions", fs_to_yojson fs); - ("gamma", typenv_to_yojson gamma); + ("gamma", Type_env.to_yojson gamma); ("encoded_assertions", sexps_to_yojson encoded_assertions); ] in @@ -1150,27 +1130,19 @@ let exec_sat' in ret -let exec_sat - (fs : Expr.Set.t) - (gamma : typenv) - (constructor_defs : constructorstbl) - (datatype_defs : Datatype.t list) : sexp option = - try exec_sat' fs gamma constructor_defs datatype_defs +let exec_sat (fs : Expr.Set.t) (gamma : Type_env.t) : sexp option = + try exec_sat' fs gamma with UnexpectedSolverResponse _ as e -> let additional_data = [ ("smt_error", `String (Printexc.to_string e)); ("expressions", fs_to_yojson fs); - ("gamma", typenv_to_yojson gamma); + ("gamma", Type_env.to_yojson gamma); ] in raise Gillian_result.Exc.(internal_error ~additional_data "SMT failure") -let check_sat - (fs : Expr.Set.t) - (gamma : typenv) - (constructor_defs : constructorstbl) - (datatype_defs : Datatype.t list) : sexp option = +let check_sat (fs : Expr.Set.t) (gamma : Type_env.t) : sexp option = match Hashtbl.find_opt sat_cache fs with | Some result -> let () = @@ -1180,7 +1152,7 @@ let check_sat result | None -> let () = L.verbose (fun m -> m "SAT check not found in cache") in - let ret = exec_sat fs gamma constructor_defs datatype_defs in + let ret = exec_sat fs gamma in let () = L.verbose (fun m -> let f = Expr.conjunct (Expr.Set.elements fs) in @@ -1189,20 +1161,15 @@ let check_sat let () = Hashtbl.replace sat_cache fs ret in ret -let is_sat - (fs : Expr.Set.t) - (gamma : typenv) - (constructor_defs : constructorstbl) - (datatype_defs : Datatype.t list) : bool = - check_sat fs gamma constructor_defs datatype_defs |> Option.is_some +let is_sat (fs : Expr.Set.t) (gamma : Type_env.t) : bool = + check_sat fs gamma |> Option.is_some let lift_model (model : sexp) - (gamma : typenv) - (datatype_defs : Datatype.t list) + (gamma : Type_env.t) (subst_update : string -> Expr.t -> unit) (target_vars : Expr.Set.t) : unit = - let () = init_or_reset_solver datatype_defs in + let () = init_or_reset () in let model_eval = (model_eval' solver model).eval [] in let get_val x = @@ -1221,7 +1188,7 @@ let lift_model in let lift_val (x : string) : Literal.t option = - let* gil_type = Hashtbl.find_opt gamma x in + let* gil_type = Type_env.get gamma x in let* v = get_val x in match gil_type with | NumberType -> diff --git a/GillianCore/engine/FOLogic/smt.mli b/GillianCore/engine/FOLogic/smt.mli index d1443346..f8902052 100644 --- a/GillianCore/engine/FOLogic/smt.mli +++ b/GillianCore/engine/FOLogic/smt.mli @@ -2,31 +2,14 @@ open Gil_syntax exception SMT_unknown -val exec_sat : - Expr.Set.t -> - (string, Type.t) Hashtbl.t -> - (string, Constructor.t) Hashtbl.t -> - Datatype.t list -> - Sexplib.Sexp.t option - -val is_sat : - Expr.Set.t -> - (string, Type.t) Hashtbl.t -> - (string, Constructor.t) Hashtbl.t -> - Datatype.t list -> - bool - -val check_sat : - Expr.Set.t -> - (string, Type.t) Hashtbl.t -> - (string, Constructor.t) Hashtbl.t -> - Datatype.t list -> - Sexplib.Sexp.t option +val init : unit -> unit +val exec_sat : Expr.Set.t -> Type_env.t -> Sexplib.Sexp.t option +val is_sat : Expr.Set.t -> Type_env.t -> bool +val check_sat : Expr.Set.t -> Type_env.t -> Sexplib.Sexp.t option val lift_model : Sexplib.Sexp.t -> - (string, Type.t) Hashtbl.t -> - Datatype.t list -> + Type_env.t -> (string -> Expr.t -> unit) -> Expr.Set.t -> unit diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index 32996e69..839562a0 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -153,20 +153,24 @@ 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 - | Constructor (n, les) -> ( - let field_types = Type_env.get_constructor_field_types n in - let check_field le tt = - match tt with - | Some tt -> f le tt - | None -> true - in - match field_types with - | Some tts -> - if List.length tts <> List.length les then false - else - tt = Type_env.get_constructor_type_unsafe n - && List.for_all2 check_field les tts - | None -> false) + | Constructor (n, les) -> + if Datatype_env.is_initialised () then + let field_types = Datatype_env.get_constructor_field_types n in + let check_field le tt = + match tt with + | Some tt -> f le tt + | None -> true + in + match field_types with + | Some tts -> + if List.length tts <> List.length les then false + else + tt = Datatype_env.get_constructor_type_unsafe n + && List.for_all2 check_field les tts + | None -> false + else + (* Can't say for certain whether or not the constructor is typable *) + true | Exists (bt, le) | ForAll (bt, le) -> if not (tt = BooleanType) then false else @@ -474,13 +478,15 @@ module Type_lexpr = struct if not ite then def_neg else infer_type gamma le BooleanType and type_constructor gamma n les = - let tts_opt = Type_env.get_constructor_field_types n in - match tts_opt with - | Some tts -> - if typable_list gamma ?target_types:(Some tts) les then - def_pos (Type_env.get_constructor_type n) - else def_neg - | None -> def_neg + if Datatype_env.is_initialised () then + let tts_opt = Datatype_env.get_constructor_field_types n in + match tts_opt with + | Some tts -> + if typable_list gamma ?target_types:(Some tts) les then + def_pos (Datatype_env.get_constructor_type n) + else def_neg + | None -> def_neg + else (None, true) (** This function returns a triple [(t_opt, b, fs)] where - [t_opt] is the type of [le] if we can find one diff --git a/GillianCore/engine/logical_env/datatype_env.ml b/GillianCore/engine/logical_env/datatype_env.ml new file mode 100644 index 00000000..5e66b8de --- /dev/null +++ b/GillianCore/engine/logical_env/datatype_env.ml @@ -0,0 +1,83 @@ +type constructors_tbl = (string, Constructor.t) Hashtbl.t +type datatypes_tbl = (string, Datatype.t) Hashtbl.t +type t = { constructors : constructors_tbl; datatypes : datatypes_tbl } + +let datatype_env : t option ref = ref None + +(* Initialises the datatype env, ensuring datatype definitions are well formed. *) +let init datatypes = + let constructors = Hashtbl.create Config.medium_tbl_size in + + let check_type topt = + let open Type in + match topt with + | Some (DatatypeType n) -> + if not (Hashtbl.mem datatypes n) then + let msg = "Unknown type in constructor definition: " ^ n in + Logging.fail msg + | _ -> () + in + + let add_constructor_to_tbl (c : Constructor.t) = + if Hashtbl.mem constructors c.constructor_name then + let msg = + "Cannot reuse datatype constructor names: " ^ c.constructor_name + in + Logging.fail msg + else List.iter check_type c.constructor_fields; + Hashtbl.add constructors c.constructor_name c + in + + let add_constructors_to_tbl (cs : Constructor.t list) = + List.iter add_constructor_to_tbl cs + in + + let () = + Hashtbl.iter + (fun _ (d : Datatype.t) -> + add_constructors_to_tbl d.datatype_constructors) + datatypes + in + + datatype_env := Some { constructors; datatypes } + +let is_initialised () = + match !datatype_env with + | None -> false + | Some _ -> true + +let get_constructor_type cname : Type.t option = + let delta = !datatype_env in + let constructor = + Option.map (fun delta -> Hashtbl.find_opt delta.constructors cname) delta + in + Option.map + (fun (c : Constructor.t) -> Type.DatatypeType c.constructor_datatype) + (Option.join constructor) + +let get_constructor_type_unsafe cname : Type.t = + let typ = get_constructor_type cname in + match typ with + | Some t -> t + | None -> + raise + (Failure + ("Type_env.get_constructor_type_unsafe: constructor " ^ cname + ^ " not found.")) + +let get_constructor_field_types cname : Type.t option list option = + let delta = !datatype_env in + let constructor = + Option.map (fun delta -> Hashtbl.find_opt delta.constructors cname) delta + in + Option.map + (fun (c : Constructor.t) -> c.constructor_fields) + (Option.join constructor) + +let get_datatypes () : Datatype.t list = + let res = + Option.map + (fun delta -> List.of_seq (Hashtbl.to_seq_values delta.datatypes)) + !datatype_env + in + Option.value ~default:[] res diff --git a/GillianCore/engine/logical_env/datatype_env.mli b/GillianCore/engine/logical_env/datatype_env.mli new file mode 100644 index 00000000..0eefa527 --- /dev/null +++ b/GillianCore/engine/logical_env/datatype_env.mli @@ -0,0 +1,9 @@ +type constructors_tbl = (string, Constructor.t) Hashtbl.t +type datatypes_tbl = (string, Datatype.t) Hashtbl.t + +val init : datatypes_tbl -> unit +val is_initialised : unit -> bool +val get_constructor_type : string -> Type.t option +val get_constructor_type_unsafe : string -> Type.t +val get_constructor_field_types : string -> Type.t option list option +val get_datatypes : unit -> Datatype.t list diff --git a/GillianCore/engine/FOLogic/type_env.ml b/GillianCore/engine/logical_env/type_env.ml similarity index 76% rename from GillianCore/engine/FOLogic/type_env.ml rename to GillianCore/engine/logical_env/type_env.ml index 10e29e6c..ea2852f7 100644 --- a/GillianCore/engine/FOLogic/type_env.ml +++ b/GillianCore/engine/logical_env/type_env.ml @@ -8,8 +8,6 @@ type constructors_tbl_t = (string, Constructor.t) Hashtbl.t [@@deriving yojson] type datatypes_tbl_t = (string, Datatype.t) Hashtbl.t [@@deriving yojson] type t = (string, Type.t) Hashtbl.t [@@deriving yojson] -let constructor_defs : constructors_tbl_t ref = ref (Hashtbl.create 1) -let datatype_defs : datatypes_tbl_t ref = ref (Hashtbl.create 1) let as_hashtbl x = x (*************************************) @@ -166,44 +164,3 @@ let filter_with_info relevant_info (x : t) = let pvars, lvars, locs = relevant_info in let relevant = List.fold_left SS.union SS.empty [ pvars; lvars; locs ] in filter x (fun x -> SS.mem x relevant) - -(*************************************) -(** Datatype Functions **) -(*************************************) - -let init_datatypes (datatypes : datatypes_tbl_t) = - let constructors = Hashtbl.create Config.medium_tbl_size in - let add_constructor_to_tbl (c : Constructor.t) = - Hashtbl.add constructors c.constructor_name c - in - let add_constructors_to_tbl cs = List.iter add_constructor_to_tbl cs in - Hashtbl.iter - (fun _ (d : Datatype.t) -> add_constructors_to_tbl d.datatype_constructors) - datatypes; - datatype_defs := datatypes; - constructor_defs := constructors - -let get_constructor_type (cname : string) : Type.t option = - let constructor = Hashtbl.find_opt !constructor_defs cname in - Option.map - (fun (c : Constructor.t) -> Type.DatatypeType c.constructor_datatype) - constructor - -let get_constructor_type_unsafe (cname : string) : Type.t = - let constructor = Hashtbl.find_opt !constructor_defs cname in - match constructor with - | Some c -> Type.DatatypeType c.constructor_datatype - | None -> - raise - (Failure - ("Type_env.get_constructor_type_unsafe: constructor " ^ cname - ^ " not found.")) - -let get_constructor_field_types (cname : string) : Type.t option list option = - let constructor = Hashtbl.find_opt !constructor_defs cname in - Option.map (fun (c : Constructor.t) -> c.constructor_fields) constructor - -let get_datatypes () : Datatype.t list = - List.of_seq (Hashtbl.to_seq_values !datatype_defs) - -let get_constructors () : constructors_tbl_t = !constructor_defs diff --git a/GillianCore/engine/FOLogic/type_env.mli b/GillianCore/engine/logical_env/type_env.mli similarity index 83% rename from GillianCore/engine/FOLogic/type_env.mli rename to GillianCore/engine/logical_env/type_env.mli index 12097c40..e69b4b42 100644 --- a/GillianCore/engine/FOLogic/type_env.mli +++ b/GillianCore/engine/logical_env/type_env.mli @@ -41,10 +41,3 @@ val is_well_formed : t -> bool val filter_with_info : Containers.SS.t * Containers.SS.t * Containers.SS.t -> t -> t - -val get_constructor_type : string -> Type.t option -val get_constructor_type_unsafe : string -> Type.t -val get_constructor_field_types : string -> Type.t option list option -val get_datatypes : unit -> Datatype.t list -val get_constructors : unit -> constructors_tbl_t -val init_datatypes : datatypes_tbl_t -> unit From 7853a400f0b6bd9523c59a05b896eb99abbd2948 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Fri, 25 Apr 2025 19:22:01 +0100 Subject: [PATCH 21/37] Tying up loose ends --- GillianCore/engine/Abstraction/MP.ml | 11 +++++++++-- GillianCore/engine/Abstraction/Normaliser.ml | 7 +++++-- GillianCore/engine/symbolic_semantics/SState.ml | 2 +- wisl/examples/SLL_adt.wisl | 9 +++++++++ 4 files changed, 24 insertions(+), 5 deletions(-) diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index dab21ede..f24d6c3b 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -442,8 +442,15 @@ let rec simple_ins_formula (kb : KB.t) (pf : Expr.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 - | Lit _ | PVar _ | LVar _ | ALoc _ | LstSub _ | NOp _ | EList _ | ESet _ -> [] - | Constructor _ -> [] (* TODO *) + | Lit _ + | PVar _ + | LVar _ + | ALoc _ + | LstSub _ + | NOp _ + | EList _ + | ESet _ + | Constructor _ -> [] (** [ins_outs_formula kb pf] returns a list of possible ins-outs pairs for a given formula [pf] under a given knowledge base [kb] *) diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 7bda476d..f81f39ca 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -101,7 +101,7 @@ module Make (SPState : PState.S) = struct let result : Expr.t = match (le : Expr.t) with - | Constructor _ -> failwith "TODO" (* TODO *) + | Constructor (n, les) -> Constructor (n, List.map f les) | Lit _ -> le | LVar lvar -> Option.value ~default:(Expr.LVar lvar) (SESubst.get subst le) @@ -178,7 +178,10 @@ module Make (SPState : PState.S) = struct | Exists _ | ForAll _ -> Lit (Type BooleanType) | EList _ | LstSub _ | NOp (LstCat, _) -> Lit (Type ListType) | NOp (_, _) | ESet _ -> Lit (Type SetType) - | Constructor _ -> failwith "TODO" (* TODO *)) + | Constructor (n, _) as c -> ( + match Datatype_env.get_constructor_type n with + | Some t -> Lit (Type t) + | None -> UnOp (TypeOf, c))) | _ -> UnOp (uop, nle1))) | EList le_list -> let n_le_list = List.map f le_list in diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index e31232a7..a909e587 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -254,7 +254,7 @@ module Make (SMemory : SMemory.S) : | Exists (bt, e) -> Exists (bt, f e) | ForAll (bt, e) -> ForAll (bt, f e) | Lit _ | LVar _ | ALoc _ -> expr - | Constructor _ -> failwith "TODO" (* TODO *) + | Constructor (n, les) -> Constructor (n, List.map f les) in (* Perform reduction *) if no_reduce then result diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl index 881149c4..8cb26f5b 100644 --- a/wisl/examples/SLL_adt.wisl +++ b/wisl/examples/SLL_adt.wisl @@ -34,6 +34,15 @@ function SLL_allocate_node(v){ } { SLL(ret, Cons(#v, Nil())) } +// This incorrect spec should fail to verify +{ (v == #v) * (u == #u) } +function SLL_allocate_node_fails(u, v){ + t := new(2); + [t] := v; + return t +} +{ SLL(ret, Cons(#u, Nil())) } + // // RECURSIVE SLL MANIPULATION From d7d72349d44d9e6a5ff6ca37d7e5a7d79c7c12e0 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Sat, 26 Apr 2025 22:11:36 +0100 Subject: [PATCH 22/37] Refactored smt.ml --- GillianCore/engine/FOLogic/smt.ml | 53 +++++++++++++++++++++++++++++-- 1 file changed, 51 insertions(+), 2 deletions(-) diff --git a/GillianCore/engine/FOLogic/smt.ml b/GillianCore/engine/FOLogic/smt.ml index 79dd06b6..2b6a7106 100644 --- a/GillianCore/engine/FOLogic/smt.ml +++ b/GillianCore/engine/FOLogic/smt.ml @@ -114,6 +114,9 @@ module Variant = struct module type Nary = sig include S + + val num_params : int + val construct : sexp list -> sexp end let nul ?recognizer name = @@ -148,6 +151,20 @@ module Variant = struct List.mapi (fun i param_typ -> ("param-" ^ string_of_int i, param_typ)) param_typs + + let num_params = List.length params + + let construct xs = + let num_params_provided = List.length xs in + if num_params_provided == num_params then atom name $$ xs + else + let msg = + Printf.sprintf + "Invalid number of parameters for the constructor %s. %d \ + parameters were provided, but %d were expected." + name num_params_provided num_params + in + raise (Failure msg) end in (module M : Nary) end @@ -259,12 +276,19 @@ module Lit_operations = struct | TypeType -> t_gil_type | DatatypeType name -> atom name + let constructor_variants : (string, (module Variant.Nary)) Hashtbl.t ref = + ref (Hashtbl.create 1) + + let datatype_lit_variants : (string, (module Variant.Unary)) Hashtbl.t ref = + ref (Hashtbl.create 1) + let mk_constructor Constructor.{ constructor_name; constructor_fields; _ } = let param_typ t = Option.map native_sort_of_type t |> Option.value ~default:t_gil_literal in let param_typs = List.map param_typ constructor_fields in let module N = (val n constructor_name param_typs : Variant.Nary) in + Hashtbl.add !constructor_variants constructor_name (module N : Variant.Nary); (module N : Variant.S) let mk_user_def_datatype Datatype.{ datatype_name; datatype_constructors; _ } @@ -286,11 +310,26 @@ module Lit_operations = struct let t_datatype = atom datatype_name in let parameter_name = user_def_datatype_lit_param_name datatype_name in let module N = (val un variant_name parameter_name t_datatype : Unary) in + Hashtbl.add !datatype_lit_variants datatype_name (module N : Unary); (module N : Variant.S) let mk_user_def_datatype_lit_variants datatypes = List.map mk_user_def_datatype_lit_variant datatypes + let get_constructor_variant cname = + match Hashtbl.find_opt !constructor_variants cname with + | Some (module N) -> (module N : Nary) + | None -> + let msg = "SMT - Undefined constructor: " ^ cname in + raise (Failure msg) + + let get_datatype_lit_variant dname = + match Hashtbl.find_opt !datatype_lit_variants dname with + | Some (module U) -> (module U : Unary) + | None -> + let msg = "SMT - Undefined datatype: " ^ dname in + raise (Failure msg) + module Undefined = (val nul "Undefined" : Nullary) module Null = (val nul "Null" : Nullary) module Empty = (val nul "Empty" : Nullary) @@ -309,6 +348,9 @@ module Lit_operations = struct end let init_decls user_def_datatypes = + (* Reset variants tables on reinitialisation *) + constructor_variants := Hashtbl.create Config.medium_tbl_size; + datatype_lit_variants := Hashtbl.create Config.medium_tbl_size; let gil_literal_variants = [ (module Undefined : Variant.S); @@ -510,7 +552,11 @@ module Encoding = struct | TypeType -> Type.construct | BooleanType -> Bool.construct | ListType -> List.construct - | DatatypeType name -> ( <| ) (atom ("Datatype" ^ name)) + | DatatypeType name -> + let (module U : Variant.Unary) = + Lit_operations.get_datatype_lit_variant name + in + U.construct | UndefinedType | NullType | EmptyType | NoneType | SetType -> Fmt.failwith "Cannot simple-wrap value of type %s" (Gil_syntax.Type.str typ) @@ -912,7 +958,10 @@ let rec encode_logical_expression in let>-- args = List.map f les in let args = List.map2 simple_wrap_or_native param_typs args in - let sexp = atom name $$ args in + let (module V : Variant.Nary) = + Lit_operations.get_constructor_variant name + in + let sexp = V.construct args in sexp >- Datatype_env.get_constructor_type_unsafe name | None -> let msg = "SMT - Undefined constructor: " ^ name in From 23fe5cd4cbb3f783c13e7521ceeed429bda46147 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Sat, 26 Apr 2025 23:42:53 +0100 Subject: [PATCH 23/37] WISL: function -> proc --- wisl/examples/DLL_recursive.wisl | 2 +- wisl/examples/SLL_adt.wisl | 14 +- wisl/examples/SLL_ex_complete.wisl | 40 ++--- wisl/examples/SLL_ex_ongoing.wisl | 22 +-- wisl/examples/SLL_iterative.wisl | 6 +- wisl/examples/SLL_recursive.wisl | 12 +- wisl/examples/function.wisl | 10 ++ wisl/examples/loop.wisl | 2 +- wisl/examples/tree.wisl | 4 +- wisl/lib/ParserAndCompiler/WAnnot.ml | 6 +- wisl/lib/ParserAndCompiler/WLexer.mll | 1 + wisl/lib/ParserAndCompiler/WParser.mly | 30 ++-- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 201 ++++++++++++------------ wisl/lib/debugging/wislLifter.ml | 119 +++++++------- wisl/lib/syntax/{WFun.ml => WProc.ml} | 9 +- wisl/lib/syntax/{WFun.mli => WProc.mli} | 4 +- wisl/lib/syntax/WProg.ml | 69 ++++---- wisl/lib/syntax/WProg.mli | 16 +- wisl/lib/syntax/WSpec.ml | 10 +- wisl/lib/syntax/WSpec.mli | 4 +- wisl/lib/syntax/WStmt.ml | 11 +- wisl/lib/syntax/WStmt.mli | 4 +- wisl/lib/utils/wBranchCase.ml | 8 +- wisl/lib/utils/wErrors.ml | 22 +-- wisl/lib/utils/wErrors.mli | 6 +- 25 files changed, 320 insertions(+), 312 deletions(-) create mode 100644 wisl/examples/function.wisl rename wisl/lib/syntax/{WFun.ml => WProc.ml} (84%) rename wisl/lib/syntax/{WFun.mli => WProc.mli} (92%) diff --git a/wisl/examples/DLL_recursive.wisl b/wisl/examples/DLL_recursive.wisl index e182f359..f9a5115f 100644 --- a/wisl/examples/DLL_recursive.wisl +++ b/wisl/examples/DLL_recursive.wisl @@ -112,7 +112,7 @@ lemma dlseg_concat { // List concatenation { (x_a == #x_a) * (v_a == #v_a) * (x_b == #x_b) * (v_b == #v_b) * dlist(#x_a, #v_a, #alpha, #llena) * dlist(#x_b, #v_b, #beta, #llenb) } -function concat(x_a, v_a, x_b, v_b) { +proc concat(x_a, v_a, x_b, v_b) { r := new(2); if (x_a = null) { [r] := x_b; diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl index 8cb26f5b..0f42dc54 100644 --- a/wisl/examples/SLL_adt.wisl +++ b/wisl/examples/SLL_adt.wisl @@ -27,7 +27,7 @@ predicate SLL(+x, vs) { // 00. Allocating an SLL node with the given value { v == #v } -function SLL_allocate_node(v){ +proc SLL_allocate_node(v){ t := new(2); [t] := v; return t @@ -36,7 +36,7 @@ function SLL_allocate_node(v){ // This incorrect spec should fail to verify { (v == #v) * (u == #u) } -function SLL_allocate_node_fails(u, v){ +proc SLL_allocate_node_fails(u, v){ t := new(2); [t] := v; return t @@ -50,7 +50,7 @@ function SLL_allocate_node_fails(u, v){ // 01. Prepending a given value to a given SLL { (x == #x) * (k == #k) * SLL(#x, #vs) } -function SLL_prepend(x, k){ +proc SLL_prepend(x, k){ z := SLL_allocate_node(k); [z + 1] := x; return z @@ -59,7 +59,7 @@ function SLL_prepend(x, k){ // 05. Copying a given SLL { (x == #x) * SLL(#x, #vs) } -function SLL_copy(x){ +proc SLL_copy(x){ y := null; if (not (x = null)) { k := [x]; @@ -76,7 +76,7 @@ function SLL_copy(x){ // 08. Checking if a given value is in a given SLL // { (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #r) } -// function SLL_member(x, k){ +// proc SLL_member(x, k){ // found := false; // if (x = null){ // skip @@ -95,7 +95,7 @@ function SLL_copy(x){ // 09. Removing a given value from a given SLL // { (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #mem) } -// function SLL_remove(x, k) { +// proc SLL_remove(x, k) { // if (x = null) { // skip // } else { @@ -116,7 +116,7 @@ function SLL_copy(x){ // 10. Freeing a given SLL { (x == #x) * SLL(#x, #vs) } -function SLL_free(x){ +proc SLL_free(x){ if (x = null) { skip } else { diff --git a/wisl/examples/SLL_ex_complete.wisl b/wisl/examples/SLL_ex_complete.wisl index e48e9b5a..4724de1b 100644 --- a/wisl/examples/SLL_ex_complete.wisl +++ b/wisl/examples/SLL_ex_complete.wisl @@ -53,7 +53,7 @@ lemma list_member_concat { // 00. Allocating an SLL node with the given value { v == #v } -function SLL_allocate_node(v){ +proc SLL_allocate_node(v){ t := new(2); [t] := v; return t @@ -67,7 +67,7 @@ function SLL_allocate_node(v){ // 01. Prepending a given value to a given SLL { (x == #x) * (k == #k) * SLL(#x, #vs) } -function SLL_prepend(x, k){ +proc SLL_prepend(x, k){ z := SLL_allocate_node(k); [z + 1] := x; return z @@ -76,7 +76,7 @@ function SLL_prepend(x, k){ // 02. Appending a given value to a given SLL { (x == #x) * (k == #k) * SLL(#x, #vs) } -function SLL_append(x, k){ +proc SLL_append(x, k){ if (x = null) { x := SLL_allocate_node(k) } else { @@ -90,7 +90,7 @@ function SLL_append(x, k){ // 03. Appending a given SLL node to a given SLL { (x == #x) * (y == #y) * SLL(#x, #vs) * SLL(#y, [#vy]) } -function SLL_append_node(x, y) { +proc SLL_append_node(x, y) { if (x = null) { x := y } else { @@ -104,7 +104,7 @@ function SLL_append_node(x, y) { // 04. Concatenating two lists {(x == #x) * (y == #y) * SLL(#x, #vx) * SLL(#y, #vy) } -function SLL_concat(x, y) { +proc SLL_concat(x, y) { if (x = null){ x := y } else { @@ -118,7 +118,7 @@ function SLL_concat(x, y) { // 05. Copying a given SLL { (x == #x) * SLL(#x, #vs) } -function SLL_copy(x){ +proc SLL_copy(x){ y := null; if (not (x = null)) { k := [x]; @@ -135,7 +135,7 @@ function SLL_copy(x){ // 06. Calculating the length of a given SLL { (x == #x) * SLL(#x, #vs) } -function SLL_length(x) { +proc SLL_length(x) { n := 0; if (x = null){ n := 0 @@ -150,7 +150,7 @@ function SLL_length(x) { // 07. Reversing a given SLL { (x == #x) * SLL(#x, #vs) } -function SLL_reverse(x){ +proc SLL_reverse(x){ if (not (x = null)) { t := [x + 1]; [x + 1] := null; @@ -165,7 +165,7 @@ function SLL_reverse(x){ // 08. Checking if a given value is in a given SLL { (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #r) } -function SLL_member(x, k){ +proc SLL_member(x, k){ found := false; if (x = null){ skip @@ -184,7 +184,7 @@ function SLL_member(x, k){ // 09. Removing a given value from a given SLL { (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #mem) } -function SLL_remove(x, k) { +proc SLL_remove(x, k) { if (x = null) { skip } else { @@ -205,7 +205,7 @@ function SLL_remove(x, k) { // 10. Freeing a given SLL { (x == #x) * SLL(#x, #vs) } -function SLL_free(x){ +proc SLL_free(x){ if (x = null) { skip } else { @@ -284,7 +284,7 @@ lemma SLLseg_to_SLL { // 02. Appending a given value to a given SLL { (x == #x) * (k == #k) * SLL(#x, #vx) } -function SLL_append_iter(x, k){ +proc SLL_append_iter(x, k){ y := SLL_allocate_node(k); if (x = null) { x := y @@ -313,7 +313,7 @@ function SLL_append_iter(x, k){ // 03. Appending a given node to a given SLL { (x == #x) * (y == #y) * SLL(#x, #vs) * SLL(#y, [#vy]) } -function SLL_append_node_iter(x, y){ +proc SLL_append_node_iter(x, y){ if (x = null) { x := y } else { @@ -341,7 +341,7 @@ function SLL_append_node_iter(x, y){ // 04. Concatenating two lists {(x == #x) * (y == #y) * SLL(#x, #vx) * SLL(#y, #vy) } -function SLL_concat_iter(x, y){ +proc SLL_concat_iter(x, y){ if (x = null) { head := y } else { @@ -368,7 +368,7 @@ function SLL_concat_iter(x, y){ // 05. Copying a given SLL { (x == #x) * SLL(#x, #alpha) } -function SLL_copy_iter(x){ +proc SLL_copy_iter(x){ y := null; if (x = null){ skip @@ -406,7 +406,7 @@ function SLL_copy_iter(x){ // 06. Calculating the length of a given SLL { (x == #x) * SLL(x, #vx) } -function SLL_length_iter(x) { +proc SLL_length_iter(x) { y := x; n := 0; [[invariant {bind: n, y, #nvx, #nvy} @@ -427,7 +427,7 @@ function SLL_length_iter(x) { // 07. Reversing a given SLL // { (x == #x) * SLL(#x, #vx) } -// function SLL_reverse_iter(x) { +// proc SLL_reverse_iter(x) { // y := null; // [[ invariant {bind: x, y, z, #nvx, #nvy} // SLL(x, #nvx) * SLL(y, #nvy) * (#vx == ((rev #nvy) @ #nvx)) ]]; @@ -443,7 +443,7 @@ function SLL_length_iter(x) { // 08. Checking if a given value is in a given SLL { (x == #x) * (k == #k) * SLL(#x, #alpha) * list_member(#alpha, #k, #r) } -function SLL_member_iter(x, k) { +proc SLL_member_iter(x, k) { found := false; next := x; [[ invariant {bind: found, next, #beta, #gamma, #rg} @@ -472,7 +472,7 @@ function SLL_member_iter(x, k) { // 10. Freeing a given SLL { (x == #x) * SLL(#x, #vs) } -function SLL_free_iter(x) { +proc SLL_free_iter(x) { [[ invariant {bind: x, #rvs} SLL(x, #rvs) ]]; while (not (x = null)) { y := x; @@ -481,4 +481,4 @@ function SLL_free_iter(x) { }; return null } -{ (ret == null) } \ No newline at end of file +{ (ret == null) } diff --git a/wisl/examples/SLL_ex_ongoing.wisl b/wisl/examples/SLL_ex_ongoing.wisl index d9389829..49123f13 100644 --- a/wisl/examples/SLL_ex_ongoing.wisl +++ b/wisl/examples/SLL_ex_ongoing.wisl @@ -219,7 +219,7 @@ lemma list_member_concat { // // 00. Allocating an SLL node with the given value // -function SLL_allocate_node(v){ +proc SLL_allocate_node(v){ t := new(2); [t] := v; return t @@ -247,7 +247,7 @@ predicate SLL_prepend_post(+def, +x, +xs, +k, +vs, +n, +retval) { // Specified algorithm { (x == #x) * (k == #k) * SLL_prepend_pre(#def, #x, #xs, #vs, #n) } -function SLL_prepend(x, k){ +proc SLL_prepend(x, k){ z := SLL_allocate_node(k); [z + 1] := x; return z @@ -280,7 +280,7 @@ predicate SLL_length_post(+def, +x, +retval) { // Specified algorithm { (x == #x) * SLL_length_pre(#def, #x, #var) } with variant: #var -function SLL_length(x) { +proc SLL_length(x) { if (x = null){ n := 0 } else { @@ -298,7 +298,7 @@ function SLL_length(x) { // Specified algorithm { (x == #x) * SLL_len(x, #n) } -function SLL_length_iter(x) { +proc SLL_length_iter(x) { y := x; n := 0; [[ invariant {bind: n, y, #ny} @@ -336,7 +336,7 @@ predicate SLL_concat_post(+def, +x, +y, +xx, +xy, +vx, +vy, +nx, +ny, +retval) { // Specified algorithm {(x == #x) * (y == #y) * SLL_concat_pre(#def, #x, #y, #xx, #xy, #vx, #vy, #nx, #ny, #var) } with variant: #var -function SLL_concat(x, y) { +proc SLL_concat(x, y) { if (x = null){ x := y } else { @@ -354,7 +354,7 @@ function SLL_concat(x, y) { // Specified algorithm {(x == #x) * (y == #y) * SLL_vals(#x, #vx) * SLL_vals(#y, #vy) } -function SLL_concat_iter(x, y){ +proc SLL_concat_iter(x, y){ if (x = null) { head := y } else { @@ -399,7 +399,7 @@ predicate SLL_reverse_post(+def, +x, +xs, +vs, +n, +retval) { // Specified algorithm { (x == #x) * SLL_reverse_pre(#def, #x, #xs, #vs, #n, #var) } with variant: #var -function SLL_reverse(x){ +proc SLL_reverse(x){ if (not (x = null)) { t := [x + 1]; [x + 1] := null; @@ -431,7 +431,7 @@ predicate nounfold SLL_member_post(+def, +x, +vs) { // Specified algorithm { (x == #x) * (k == #k) * SLL_member_pre(#def, #x, #vs, #var) * list_member(#vs, #k, #r) } with variant: #var -function SLL_member(x, k){ +proc SLL_member(x, k){ found := false; if (x = null){ skip @@ -452,7 +452,7 @@ function SLL_member(x, k){ // 05i. List membership // { (x == #x) * (k == #k) * SLL_vals(#x, #vs) * list_member(#vs, #k, #r) } -function SLL_member_iter(x, k) { +proc SLL_member_iter(x, k) { found := false; next := x; [[ invariant {bind: found, next, #beta, #gamma, #rg} @@ -505,7 +505,7 @@ predicate SLL_free_post(+def, +x, +xs) { // Specified algorithm { (x == #x) * SLL_free_pre(#def, #x, #xs, #var) } with variant: #var -function SLL_free(x){ +proc SLL_free(x){ if (x = null) { skip } else { @@ -515,4 +515,4 @@ function SLL_free(x){ }; return null } -{ (ret == null) * SLL_free_post(#def, #x, #xs)} \ No newline at end of file +{ (ret == null) * SLL_free_post(#def, #x, #xs)} diff --git a/wisl/examples/SLL_iterative.wisl b/wisl/examples/SLL_iterative.wisl index e469fa53..c1c09602 100644 --- a/wisl/examples/SLL_iterative.wisl +++ b/wisl/examples/SLL_iterative.wisl @@ -57,7 +57,7 @@ lemma lseg_append(x, y, alpha, yval, ynext) { { (#x == x) * list(#x, #alpha) } -function llen(x) { +proc llen(x) { y := x; n := 0; [[invariant {exists: #a1, #a2} lseg(#x, y, #a1) * list(y, #a2) * (#alpha == #a1@#a2) * (n == len #a1) ]]; @@ -76,7 +76,7 @@ function llen(x) { { (x == #x) * (y == #y) * list(#x, #alpha) * list(#y, #beta) } -function concat(x, y) { +proc concat(x, y) { if (x = null) { x := y } else { @@ -96,4 +96,4 @@ function concat(x, y) { }; return x } -{ list(ret, #alpha @ #beta) } \ No newline at end of file +{ list(ret, #alpha @ #beta) } diff --git a/wisl/examples/SLL_recursive.wisl b/wisl/examples/SLL_recursive.wisl index a5caef62..6d12a48a 100644 --- a/wisl/examples/SLL_recursive.wisl +++ b/wisl/examples/SLL_recursive.wisl @@ -4,7 +4,7 @@ predicate list(+x, alpha) { } { (x == #x) * list(#x, #alpha) } -function llen(x) { +proc llen(x) { if (x = null) { n := 0 } else { @@ -17,7 +17,7 @@ function llen(x) { { list(#x, #alpha) * (ret == len(#alpha)) } { (x == #x) * (y == #y) * list(#x, #alpha) * list(#y, #beta) } -function concat(x, y) { +proc concat(x, y) { if (x = null) { r := y } else { @@ -32,7 +32,7 @@ function concat(x, y) { // { list(#x, #alpha) * (v == #v) } -// function append(x, v) { +// proc append(x, v) { // if (x = null) { // y := new(2); // [y] := v @@ -47,7 +47,7 @@ function concat(x, y) { // { list(ret, #alpha@[#v]) } // { list(x, #alpha) * (x == #x) } -// function copy(x) { +// proc copy(x) { // if (x = null) { // ch := null // } else { @@ -63,7 +63,7 @@ function concat(x, y) { // { list(#x, #alpha) * list(ret, #alpha) } // { list(x, #alpha) } -// function dispose_list(x) { +// proc dispose_list(x) { // if (x = null) { // skip // } else { @@ -73,4 +73,4 @@ function concat(x, y) { // }; // return null // } -// { emp } \ No newline at end of file +// { emp } diff --git a/wisl/examples/function.wisl b/wisl/examples/function.wisl new file mode 100644 index 00000000..10ae8b6f --- /dev/null +++ b/wisl/examples/function.wisl @@ -0,0 +1,10 @@ +function inc(x : Int) { + x + 1 +} + +{ x == #x } +proc increment(x) { + y := x + 1; + return y +} +{ ret == inc(#x) } diff --git a/wisl/examples/loop.wisl b/wisl/examples/loop.wisl index b502d75c..7d7e5bc7 100644 --- a/wisl/examples/loop.wisl +++ b/wisl/examples/loop.wisl @@ -44,7 +44,7 @@ lemma lseg_append(x, y, alpha, a, z) { } { (x == #x) * list(#x, #alpha) } -function llen(x) { +proc llen(x) { y := x; n := 0; [[ fold lseg(#x, y, []) ]]; diff --git a/wisl/examples/tree.wisl b/wisl/examples/tree.wisl index 15d79de7..89ac51e9 100644 --- a/wisl/examples/tree.wisl +++ b/wisl/examples/tree.wisl @@ -4,7 +4,7 @@ predicate tree(+t) { } { (x == #x) * tree(#x) } -function tree_dispose(x) { +proc tree_dispose(x) { if (x != null) { y := [x+1]; z := [x+2]; @@ -16,4 +16,4 @@ function tree_dispose(x) { }; return null } -{ emp } \ No newline at end of file +{ emp } diff --git a/wisl/lib/ParserAndCompiler/WAnnot.ml b/wisl/lib/ParserAndCompiler/WAnnot.ml index c7fa9c6c..542302c3 100644 --- a/wisl/lib/ParserAndCompiler/WAnnot.ml +++ b/wisl/lib/ParserAndCompiler/WAnnot.ml @@ -1,7 +1,7 @@ type nest_kind = | LoopBody of string - (** This command nests its loop body an (abstracted) function call *) - | FunCall of string (** This command nests the body of a function call *) + (** This command nests its loop body an (abstracted) proc call *) + | ProcCall of string (** This command nests the body of a proc call *) [@@deriving yojson] (** How does this command map to a WISL statment? *) @@ -11,7 +11,7 @@ type stmt_kind = | Return of bool (** Same as [Normal], but specific to the return statement *) | Hidden (** A command that doesn't map to a particular WISL statement *) - | LoopPrefix (** A command in the prefix of a loop body function *) + | LoopPrefix (** A command in the prefix of a loop body proc *) [@@deriving yojson, show] type t = { diff --git a/wisl/lib/ParserAndCompiler/WLexer.mll b/wisl/lib/ParserAndCompiler/WLexer.mll index c6dafa00..62ff8c60 100644 --- a/wisl/lib/ParserAndCompiler/WLexer.mll +++ b/wisl/lib/ParserAndCompiler/WLexer.mll @@ -36,6 +36,7 @@ rule read = | "free" { DELETE (curr lexbuf) } | "dispose"{ DELETE (curr lexbuf) } | "function" { FUNCTION (curr lexbuf) } + | "proc" { PROC (curr lexbuf) } | "predicate" { PREDICATE (curr lexbuf) } | "datatype" { DATATYPE (curr lexbuf) } | "invariant" { INVARIANT (curr lexbuf) } diff --git a/wisl/lib/ParserAndCompiler/WParser.mly b/wisl/lib/ParserAndCompiler/WParser.mly index 0cc081de..61ce8e01 100644 --- a/wisl/lib/ParserAndCompiler/WParser.mly +++ b/wisl/lib/ParserAndCompiler/WParser.mly @@ -2,7 +2,7 @@ (* key words *) %token TRUE FALSE NULL WHILE IF ELSE SKIP FRESH NEW DELETE -%token FUNCTION RETURN PREDICATE LEMMA DATATYPE +%token PROC FUNCTION RETURN PREDICATE LEMMA DATATYPE %token INVARIANT PACKAGE FOLD UNFOLD NOUNFOLD APPLY ASSERT ASSUME ASSUME_TYPE EXIST FORALL %token STATEMENT WITH VARIANT PROOF @@ -96,9 +96,9 @@ %start prog %start assert_only -%type definitions -%type fct_with_specs -%type fct +%type definitions +%type proc_with_specs +%type proc %type predicate %type lemma %type datatype @@ -141,31 +141,31 @@ definitions: | defs = definitions; l = lemma { let (fs, ps, ls, ds) = defs in (fs, ps, l::ls, ds) } - | defs = definitions; f = fct_with_specs + | defs = definitions; f = proc_with_specs { let (fs, ps, ls, ds) = defs in (f::fs, ps, ls, ds) } | defs = definitions; d = datatype { let (fs, ps, ls, ds) = defs in (fs, ps, ls, d::ds) } -fct_with_specs: - | lstart = LCBRACE; pre = logic_assertion; RCBRACE; variant = option(with_variant_def); f = fct; LCBRACE; +proc_with_specs: + | lstart = LCBRACE; pre = logic_assertion; RCBRACE; variant = option(with_variant_def); p = proc; LCBRACE; post = logic_assertion; lend = RCBRACE { let loc = CodeLoc.merge lstart lend in - WFun.add_spec f pre post variant loc } - | f = fct { f } + WProc.add_spec p pre post variant loc } + | p = proc { p } -fct: - | lstart = FUNCTION; lf = IDENTIFIER; LBRACE; params = var_list; RBRACE; (* block_start = *) LCBRACE; +proc: + | lstart = PROC; lp = IDENTIFIER; LBRACE; params = var_list; RBRACE; (* block_start = *) LCBRACE; stmtsandret = statement_list_and_return; lend = RCBRACE; - { let (_, f) = lf in + { let (_, p) = lp in let (stmts, e) = stmtsandret in (* let block_loc = CodeLoc.merge block_start lend in let () = WStmt.check_consistency stmts block_loc in *) let floc = CodeLoc.merge lstart lend in let fid = Generators.gen_id () in - WFun.{ - name = f; + WProc.{ + name = p; params = params; body = stmts; return_expr = e; @@ -242,7 +242,7 @@ statement: | lx = IDENTIFIER; ASSIGN; lf = IDENTIFIER; LBRACE; params = expr_list; lend = RBRACE { let (lstart, x) = lx in let (_, f) = lf in - let bare_stmt = WStmt.FunCall (x, f, params, None) in + let bare_stmt = WStmt.ProcCall (x, f, params, None) in let loc = CodeLoc.merge lstart lend in WStmt.make bare_stmt loc } diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index 36eba71f..f55bd27b 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -67,12 +67,12 @@ let rec compile_val v = | Str s -> Literal.String s | VList l -> Literal.LList (List.map compile_val l) -let rec compile_expr ?(fname = "main") ?(is_loop_prefix = false) expr : +let rec compile_expr ?(proc_name = "main") ?(is_loop_prefix = false) expr : (WAnnot.t * string option * string Cmd.t) list * Expr.t = - let gen_str = Generators.gen_str fname in - let compile_expr = compile_expr ~fname ~is_loop_prefix in + let gen_str = Generators.gen_str proc_name in + let compile_expr = compile_expr ~proc_name ~is_loop_prefix in let expr_of_string s = Expr.Lit (Literal.String s) in - let expr_fname_of_binop b = + let expr_pname_of_binop b = WBinOp.( match b with | PLUS -> expr_of_string internal_add @@ -83,11 +83,10 @@ let rec compile_expr ?(fname = "main") ?(is_loop_prefix = false) expr : | GREATERTHAN -> expr_of_string internal_gt | _ -> failwith - (Format.asprintf - "Binop %a does not correspond to an internal function" WBinOp.pp - b)) + (Format.asprintf "Binop %a does not correspond to an internal proc" + WBinOp.pp b)) in - let is_internal_func = + let is_internal_proc = WBinOp.( function | PLUS | MINUS | LESSEQUAL | LESSTHAN | GREATEREQUAL | GREATERTHAN -> true @@ -115,15 +114,15 @@ let rec compile_expr ?(fname = "main") ?(is_loop_prefix = false) expr : let cmdl2, comp_expr2 = compile_expr e2 in let expr = Expr.NOp (LstCat, [ comp_expr1; comp_expr2 ]) in (cmdl1 @ cmdl2, expr) - | BinOp (e1, b, e2) when is_internal_func b -> + | BinOp (e1, b, e2) when is_internal_proc b -> (* Operator corresponds to pointer arithmetics *) let call_var = gen_str gvar in - let internal_func = expr_fname_of_binop b in + let internal_proc = expr_pname_of_binop b in let cmdl1, comp_expr1 = compile_expr e1 in let cmdl2, comp_expr2 = compile_expr e2 in let call_i_plus = Cmd.Call - (call_var, internal_func, [ comp_expr1; comp_expr2 ], None, None) + (call_var, internal_proc, [ comp_expr1; comp_expr2 ], None, None) in ( cmdl1 @ cmdl2 @ [ @@ -150,10 +149,10 @@ let rec compile_expr ?(fname = "main") ?(is_loop_prefix = false) expr : (* compile_lexpr : WLExpr.t -> (string list * Asrt.t list * Expr.t) 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) : +let rec compile_lexpr ?(proc_name = "main") (lexpr : WLExpr.t) : string list * Asrt.t * Expr.t = - let gen_str = Generators.gen_str fname in - let compile_lexpr = compile_lexpr ~fname in + let gen_str = Generators.gen_str proc_name in + let compile_lexpr = compile_lexpr ~proc_name in let expr_pname_of_binop b = WBinOp.( match b with @@ -165,9 +164,8 @@ let rec compile_lexpr ?(fname = "main") (lexpr : WLExpr.t) : | GREATERTHAN -> internal_pred_gt | _ -> failwith - (Format.asprintf - "Binop %a does not correspond to an internal function" WBinOp.pp - b)) + (Format.asprintf "Binop %a does not correspond to an internal proc" + WBinOp.pp b)) in let is_internal_pred = WBinOp.( @@ -243,10 +241,10 @@ let rec compile_lexpr ?(fname = "main") (lexpr : WLExpr.t) : (List.concat gvars, List.concat asrtsl, Expr.Constructor (n, comp_exprs))) (* TODO: compile_lformula should return also the list of created existentials *) -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 +let rec compile_lformula ?(proc_name = "main") formula : Asrt.t * Expr.t = + let gen_str = Generators.gen_str proc_name in + let compile_lformula = compile_lformula ~proc_name in + let compile_lexpr = compile_lexpr ~proc_name in WLFormula.( match get formula with | LTrue -> ([], Expr.true_) @@ -292,11 +290,11 @@ let rec compile_lformula ?(fname = "main") formula : Asrt.t * Expr.t = (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 = - let compile_lassert = compile_lassert ~fname in - let gen_str = Generators.gen_str fname in - let compile_lexpr = compile_lexpr ~fname in - let compile_lformula = compile_lformula ~fname in +let rec compile_lassert ?(proc_name = "main") asser : string list * Asrt.t = + let compile_lassert = compile_lassert ~proc_name in + let gen_str = Generators.gen_str proc_name in + let compile_lexpr = compile_lexpr ~proc_name in + let compile_lformula = compile_lformula ~proc_name in let gil_add e k = (* builds GIL expression that is e + k *) let k_e = Expr.int k in @@ -400,10 +398,10 @@ let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = let al, f = compile_lformula lf in ([], 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 rec compile_lcmd ?(proc_name = "main") lcmd = + let compile_lassert = compile_lassert ~proc_name in + let compile_lcmd = compile_lcmd ~proc_name in + let compile_lexpr = compile_lexpr ~proc_name in let build_assert existentials lasrts = match lasrts with | [] -> None @@ -461,11 +459,11 @@ let rec compile_lcmd ?(fname = "main") lcmd = (None, LCmd.SL (SLCmd.SepAssert (comp_la, exs @ lb))) | Invariant _ -> failwith "Invariant is not before a loop." -let compile_inv_and_while ~fname ~while_stmt ~invariant = +let compile_inv_and_while ~proc_name ~while_stmt ~invariant = (* FIXME: Variables that are in the invariant but not existential might be wrong. *) let loopretvar = "loopretvar__" in - let gen_str = Generators.gen_str fname in - let loop_fname = gen_str (fname ^ "_loop") in + let gen_str = Generators.gen_str proc_name in + let loop_proc_name = gen_str (proc_name ^ "_loop") in let while_loc = WStmt.get_loc while_stmt in let invariant_loc = WLCmd.get_loc invariant in let inv_asrt, inv_exs, inv_variant = @@ -516,7 +514,7 @@ let compile_inv_and_while ~fname ~while_stmt ~invariant = in Hashtbl.of_seq (List.to_seq (var_subst @ lvar_subst)) in - let loop_funct = + let loop_proc = let guard_loc = WExpr.get_loc guard in let post_guard = WLAssert.make @@ -557,15 +555,15 @@ let compile_inv_and_while ~fname ~while_stmt ~invariant = (* FIGURE OUT VARIANT *) variant = inv_variant; spid = Generators.gen_id (); - fname = loop_fname; - fparams = vars; + proc_name = loop_proc_name; + proc_params = vars; sploc = while_loc; existentials = None; } in let pvars = List.map (fun x -> WExpr.make (Var x) while_loc) vars in let rec_call = - WStmt.make (FunCall (loopretvar, loop_fname, pvars, None)) while_loc + WStmt.make (ProcCall (loopretvar, loop_proc_name, pvars, None)) while_loc in let allvars = WExpr.make (WExpr.List pvars) while_loc in let ret_not_rec = WStmt.make (VarAssign (loopretvar, allvars)) while_loc in @@ -574,9 +572,9 @@ let compile_inv_and_while ~fname ~while_stmt ~invariant = WStmt.make (If (guard, wcmds @ [ rec_call ], [ ret_not_rec ])) while_loc; ] in - WFun. + WProc. { - name = loop_fname; + name = loop_proc_name; params = vars; body; spec = Some spec; @@ -590,7 +588,7 @@ let compile_inv_and_while ~fname ~while_stmt ~invariant = let call_cmd = Cmd.Call ( retv, - Lit (String loop_fname), + Lit (String loop_proc_name), List.map (fun x -> Expr.PVar x) vars, None, None ) @@ -618,19 +616,20 @@ let compile_inv_and_while ~fname ~while_stmt ~invariant = | [] -> List.rev acc in let annot_call_while = - { annot_while with nest_kind = Some (LoopBody loop_fname) } + { annot_while with nest_kind = Some (LoopBody loop_proc_name) } in let lab_cmds = (annot_call_while, None, call_cmd) :: map_reassign_vars [] reassign_vars in - (lab_cmds, loop_funct) + (lab_cmds, loop_proc) -let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = +let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl + = (* create generator that works in the context of this function *) - let compile_expr = compile_expr ~fname in - let compile_lcmd = compile_lcmd ~fname in - let compile_list = compile_stmt_list ~fname in - let gen_str = Generators.gen_str fname in + let compile_expr = compile_expr ~proc_name in + let compile_lcmd = compile_lcmd ~proc_name in + let compile_list = compile_stmt_list ~proc_name in + let gen_str = Generators.gen_str proc_name in let gil_expr_of_str s = Expr.Lit (Literal.String s) in let get_or_create_lab cmdl pre = match cmdl with @@ -653,16 +652,16 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = | { snode = Logic invariant; _ } :: while_stmt :: rest when WLCmd.is_inv invariant && WStmt.is_while while_stmt && !Gillian.Utils.Config.current_exec_mode = Verification -> - let cmds, fct = compile_inv_and_while ~fname ~while_stmt ~invariant in - let comp_rest, new_functions = compile_list rest in - (cmds @ comp_rest, fct :: new_functions) + let cmds, fct = compile_inv_and_while ~proc_name ~while_stmt ~invariant in + let comp_rest, new_procs = compile_list rest in + (cmds @ comp_rest, fct :: new_procs) | { snode = While _; _ } :: _ when !Gillian.Utils.Config.current_exec_mode = Verification -> failwith "While loop without invariant in Verification mode!" | { snode = While (e, sl); sid = sid_while; sloc } :: rest -> let looplab = gen_str loop_lab in let cmdle, guard = compile_expr e in - let comp_body, new_functions = compile_list sl in + let comp_body, new_procs = compile_list sl in let comp_body, bodlab = get_or_create_lab comp_body lbody_lab in let endlab = gen_str end_lab in let annot = @@ -680,19 +679,19 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = let backcmd_lab = (annot_hidden, None, backcmd) in let endcmd = Cmd.Skip in let endcmd_lab = (annot_hidden, Some endlab, endcmd) in - let comp_rest, new_functions_2 = compile_list rest in + let comp_rest, new_procs_2 = compile_list rest in ( [ headcmd_lab ] @ cmdle @ [ loopcmd_lab ] @ comp_body @ [ backcmd_lab; endcmd_lab ] @ comp_rest, - new_functions @ new_functions_2 ) + new_procs @ new_procs_2 ) (* Skip *) | { snode = Skip; sid; sloc } :: rest -> let cmd = Cmd.Skip in let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in - let comp_rest, new_functions = compile_list rest in - ((annot, None, cmd) :: comp_rest, new_functions) + let comp_rest, new_procs = compile_list rest in + ((annot, None, cmd) :: comp_rest, new_procs) (* Variable assignment *) | { snode = VarAssign (v, e); sid; sloc } :: rest -> let cmdle, comp_e = compile_expr e in @@ -700,16 +699,16 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in - let comp_rest, new_functions = compile_list rest in - (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_functions) + let comp_rest, new_procs = compile_list rest in + (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_procs) (* Fresh s-var *) | { snode = Fresh v; sid; sloc } :: rest -> let cmd = Cmd.Logic (LCmd.FreshSVar v) in let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in - let comp_rest, new_functions = compile_list rest in - ((annot, None, cmd) :: comp_rest, new_functions) + let comp_rest, new_procs = compile_list rest in + ((annot, None, cmd) :: comp_rest, new_procs) (* Object Deletion *) | { snode = Dispose e; sid; sloc } :: rest -> let cmdle, comp_e = compile_expr e in @@ -727,7 +726,7 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = let g_var = gen_str gvar in let failcmd = Cmd.Fail ("InvalidBlockPointer", [ comp_e ]) in let cmd = Cmd.LAction (g_var, dispose, [ nth comp_e 0 ]) in - let comp_rest, new_functions = compile_list rest in + let comp_rest, new_procs = compile_list rest in ( cmdle @ [ (annot, None, testcmd); @@ -735,7 +734,7 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = (annot_final, Some ctnlab, cmd); ] @ comp_rest, - new_functions ) + new_procs ) (* Delete e => ce := Ce(e); // (bunch of commands and then assign the result to e) v_get := [getcell](ce[0], ce[1]); @@ -772,8 +771,8 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = (annot_final, None, getvalcmd); ] in - let comp_rest, new_functions = compile_list rest in - (cmdle @ cmds @ comp_rest, new_functions) + let comp_rest, new_procs = compile_list rest in + (cmdle @ cmds @ comp_rest, new_procs) (* x := [e] => ce := Ce(e); // (bunch of commands and then assign the result to ce) @@ -797,10 +796,10 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = let setcmd = Cmd.LAction (v_set, setcell, [ nth e_v_get 0; nth e_v_get 1; comp_e2 ]) in - let comp_rest, new_functions = compile_list rest in + let comp_rest, new_procs = compile_list rest in ( cmdle1 @ cmdle2 @ ((get_annot, None, getcmd) :: (set_annot, None, setcmd) :: comp_rest), - new_functions ) + new_procs ) (* [e1] := e2 => ce1 := Ce(e1); ce2 := Ce(e2); @@ -819,13 +818,13 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = let newcmd = Cmd.LAction (x, alloc, [ Expr.Lit (Literal.Int (Z.of_int k)) ]) in - let comp_rest, new_functions = compile_list rest in - ((annot, None, newcmd) :: comp_rest, new_functions) + let comp_rest, new_procs = compile_list rest in + ((annot, None, newcmd) :: comp_rest, new_procs) (* x := new(k) => x := [alloc](k); // this is already a pointer *) - (* Function call *) - | { snode = FunCall (x, fn, el, to_bind); sid; sloc } :: rest -> + (* Proc call *) + | { snode = ProcCall (x, fn, el, to_bind); sid; sloc } :: rest -> let expr_fn = gil_expr_of_str fn in let cmdles, params = List.split (List.map compile_expr el) in let bindings = @@ -837,10 +836,10 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = let cmd = Cmd.Call (x, expr_fn, params, None, bindings) in let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) - ~nest_kind:(FunCall fn) () + ~nest_kind:(ProcCall fn) () in - let comp_rest, new_functions = compile_list rest in - (List.concat cmdles @ [ (annot, None, cmd) ] @ comp_rest, new_functions) + let comp_rest, new_procs = compile_list rest in + (List.concat cmdles @ [ (annot, None, cmd) ] @ comp_rest, new_procs) (* If-Else bloc *) | { snode = If (e, sl1, sl2); sid; sloc } :: rest -> let annot = @@ -855,8 +854,8 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = { annot with stmt_kind; branch_kind } in let cmdle, guard = compile_expr e in - let comp_sl1, new_functions1 = compile_list sl1 in - let comp_sl2, new_functions2 = compile_list sl2 in + let comp_sl1, new_procs1 = compile_list sl1 in + let comp_sl2, new_procs2 = compile_list sl2 in let endlab = gen_str endif_lab in let comp_sl1, thenlab = get_or_create_lab comp_sl1 then_lab in let comp_sl2, elselab = get_or_create_lab comp_sl2 else_lab in @@ -866,12 +865,12 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = let gotoendcmd_lab = (annot_hidden, None, gotoendcmd) in let endcmd = Cmd.Skip in let endcmd_lab = (annot_hidden, Some endlab, endcmd) in - let comp_rest, new_functions3 = compile_list rest in + let comp_rest, new_procs3 = compile_list rest in ( cmdle @ (ifelsecmd_lab :: comp_sl1) @ (gotoendcmd_lab :: comp_sl2) @ [ endcmd_lab ] @ comp_rest, - new_functions1 @ new_functions2 @ new_functions3 ) + new_procs1 @ new_procs2 @ new_procs3 ) (* Logic commands *) | { snode = Logic lcmd; sid; sloc } :: rest -> let annot = @@ -886,24 +885,24 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = let cmds_with_annot = List.map (fun lcmdp -> (annot, None, Cmd.Logic lcmdp)) lcmds in - let comp_rest, new_functions = compile_list rest in - (cmds_with_annot @ comp_rest, new_functions) + let comp_rest, new_procs = compile_list rest in + (cmds_with_annot @ comp_rest, new_procs) | { snode = Assert e; sid; sloc } :: rest -> let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in let cmdle, comp_e = compile_expr e 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) + let comp_rest, new_procs = compile_list rest in + (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_procs) | { snode = Assume e; sid; sloc } :: rest -> let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in let cmdle, comp_e = compile_expr e 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) + let comp_rest, new_procs = compile_list rest in + (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_procs) | { snode = AssumeType (e, t); sid; sloc } :: rest -> let typ = WType.to_gil t in let annot = @@ -911,19 +910,19 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = in let cmdle, comp_e = compile_expr e 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) + let comp_rest, new_procs = compile_list rest in + (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_procs) let compile_spec - ?(fname = "main") - WSpec.{ pre; post; variant; fparams; existentials; _ } = + ?(proc_name = "main") + WSpec.{ pre; post; variant; proc_params; existentials; _ } = let comp_pre = - let _, comp_pre = compile_lassert ~fname pre in + let _, comp_pre = compile_lassert ~proc_name pre in let loc = WLAssert.get_loc pre |> CodeLoc.to_location in (comp_pre, Some loc) in let comp_post = - let _, comp_post = compile_lassert ~fname post in + let _, comp_post = compile_lassert ~proc_name post in let loc = WLAssert.get_loc post |> CodeLoc.to_location in (comp_post, Some loc) in @@ -947,7 +946,7 @@ let compile_spec Spec.s_init ~ss_label comp_pre [ comp_post ] comp_variant Flag.Normal true in - Spec.init fname fparams [ single_spec ] false false true + Spec.init proc_name proc_params [ single_spec ] false false true let compile_pred filepath pred = let WPred.{ pred_definitions; pred_params; pred_name; pred_ins; pred_loc; _ } @@ -985,16 +984,14 @@ let compile_pred filepath pred = pred_nounfold = pred.pred_nounfold; } -let rec compile_function +let rec compile_proc filepath - WFun.{ name; params; body; spec; return_expr; is_loop_body; _ } = - let lbodylist, new_functions = - compile_stmt_list ~fname:name ~is_loop_prefix:is_loop_body body - in - let other_procs = - List.concat (List.map (compile_function filepath) new_functions) + WProc.{ name; params; body; spec; return_expr; is_loop_body; _ } = + let lbodylist, new_procs = + compile_stmt_list ~proc_name:name ~is_loop_prefix:is_loop_body body in - let cmdle, comp_ret_expr = compile_expr ~fname:name return_expr in + let other_procs = List.concat (List.map (compile_proc filepath) new_procs) in + let cmdle, comp_ret_expr = compile_expr ~proc_name:name return_expr in let ret_annot, final_ret_annot = WAnnot.make_multi ~origin_loc:(CodeLoc.to_location (WExpr.get_loc return_expr)) @@ -1011,7 +1008,7 @@ let rec compile_function let retcmd = (final_ret_annot, None, Cmd.ReturnNormal) in let lbody_withret = lbodylist @ retassigncmds @ [ retcmd ] in let gil_body = Array.of_list lbody_withret in - let gil_spec = Option.map (compile_spec ~fname:name) spec in + let gil_spec = Option.map (compile_spec ~proc_name:name) spec in Proc. { proc_name = name; @@ -1096,9 +1093,9 @@ let compile_lemma lemma_conclusion; _; } = - let compile_lcmd = compile_lcmd ~fname:lemma_name in - let compile_lexpr = compile_lexpr ~fname:lemma_name in - let compile_lassert = compile_lassert ~fname:lemma_name in + let compile_lcmd = compile_lcmd ~proc_name:lemma_name in + let compile_lexpr = compile_lexpr ~proc_name:lemma_name in + let compile_lassert = compile_lassert ~proc_name:lemma_name in let compile_and_agregate_lcmd lcmd = let a_opt, clcmd = compile_lcmd lcmd in match a_opt with @@ -1202,7 +1199,7 @@ let compile ~filepath WProg.{ context; predicates; lemmas; datatypes } = let get_lemma_name lemma = lemma.Lemma.lemma_name in let get_datatype_name datatype = datatype.Datatype.datatype_name in (* compile everything *) - let comp_context = List.map (compile_function filepath) context in + let comp_context = List.map (compile_proc filepath) context in let comp_preds = List.map (compile_pred filepath) predicates in let comp_lemmas = List.map diff --git a/wisl/lib/debugging/wislLifter.ml b/wisl/lib/debugging/wislLifter.ml index 212e7d25..9b9c6b55 100644 --- a/wisl/lib/debugging/wislLifter.ml +++ b/wisl/lib/debugging/wislLifter.ml @@ -64,18 +64,17 @@ struct | `WLCmd lcmd -> Some (Fmt.str "%a" WLCmd.pp lcmd) | `WStmt stmt -> Some (Fmt.str "%a" WStmt.pp_head stmt) | `WLExpr le -> Some (Fmt.str "LEXpr: %a" WLExpr.pp le) - | `WFun f -> Some (Fmt.str "WFun: %s" f.name) + | `WProc f -> Some (Fmt.str "WProc: %s" f.name) | `None -> None | _ -> failwith "get_origin_node_str: Unknown Kind of Node" - let get_fun_call_name exec_data = + let get_proc_call_name exec_data = let cmd = CmdReport.(exec_data.cmd_report.cmd) in match cmd with | Cmd.Call (_, name_expr, _, _, _) -> ( match name_expr with | Expr.Lit (Literal.String name) -> Some name - | _ -> - failwith "get_fun_call_name: function name wasn't a literal expr!") + | _ -> failwith "get_proc_call_name: proc name wasn't a literal expr!") | _ -> None type cmd_data = { @@ -88,7 +87,7 @@ struct loc : string * int; prev : (id * Branch_case.t option) option; callers : id list; - func_return_label : (string * int) option; + proc_return_label : (string * int) option; } [@@deriving yojson] @@ -169,10 +168,10 @@ struct = let- () = match (nest_kind, ends) with - | Some (FunCall _), [ (Unknown, bdata) ] -> - Some (Ok [ (FuncExitPlaceholder, bdata) ]) - | Some (FunCall _), _ -> - Some (Error "Unexpected branching in cmd with FunCall nest!") + | Some (ProcCall _), [ (Unknown, bdata) ] -> + Some (Ok [ (ProcExitPlaceholder, bdata) ]) + | Some (ProcCall _), _ -> + Some (Error "Unexpected branching in cmd with ProcCall nest!") | _ -> None in let counts = Hashtbl.create 0 in @@ -203,8 +202,8 @@ struct | Return _ -> true | _ -> false - let is_loop_end ~is_loop_func ~proc_name exec_data = - is_loop_func && get_fun_call_name exec_data = Some proc_name + let is_loop_end ~is_loop_proc ~proc_name exec_data = + is_loop_proc && get_proc_call_name exec_data = Some proc_name let finish ~exec_data partial = let ({ prev; all_ids; ends; nest_kind; matches; errors; has_return; _ } @@ -335,7 +334,7 @@ struct ~id ~tl_ast ~annot - ~is_loop_func + ~is_loop_proc ~proc_name ~exec_data (partial : partial_data) = @@ -345,7 +344,7 @@ struct match get_origin_node_str tl_ast (Some origin_id) with | Some display -> Ok (display, false) | None -> - if is_loop_end ~is_loop_func ~proc_name exec_data then + if is_loop_end ~is_loop_proc ~proc_name exec_data then Ok ("", true) else Error "Couldn't get display!" in @@ -396,19 +395,19 @@ struct let update_submap ~prog ~(annot : Annot.t) partial = match (partial.nest_kind, annot.nest_kind) with - | None, Some (FunCall fn) -> + | None, Some (ProcCall fn) -> let () = if not (is_fcall_using_spec fn prog) then - partial.nest_kind <- Some (FunCall fn) + partial.nest_kind <- Some (ProcCall fn) in Ok () | None, nest -> partial.nest_kind <- nest; Ok () - | Some _, (None | Some (FunCall _)) -> Ok () + | Some _, (None | Some (ProcCall _)) -> Ok () | Some _, Some _ -> Error "HORROR - multiple submaps!" - let f ~tl_ast ~prog ~prev_id ~is_loop_func ~proc_name exec_data partial = + let f ~tl_ast ~prog ~prev_id ~is_loop_proc ~proc_name exec_data partial = let { id; cmd_report; errors; matches; _ } = exec_data in let annot = CmdReport.(cmd_report.annot) in let** branch_kind, branch_case = @@ -416,7 +415,7 @@ struct in let** () = update_paths ~exec_data ~branch_case ~branch_kind partial in let** () = - update_canonical_cmd_info ~id ~tl_ast ~annot ~exec_data ~is_loop_func + update_canonical_cmd_info ~id ~tl_ast ~annot ~exec_data ~is_loop_proc ~proc_name partial in let** () = update_submap ~prog ~annot partial in @@ -457,7 +456,7 @@ struct ~tl_ast ~prog ~get_prev - ~is_loop_func + ~is_loop_proc ~proc_name ~prev_id exec_data = @@ -467,7 +466,7 @@ struct in Hashtbl.replace partials exec_data.id partial; let result = - update ~tl_ast ~prog ~prev_id ~is_loop_func ~proc_name exec_data partial + update ~tl_ast ~prog ~prev_id ~is_loop_proc ~proc_name exec_data partial |> Result_utils.or_else (fun e -> failwith ~exec_data ~partial ~partials e) in @@ -487,10 +486,10 @@ struct tl_ast : tl_ast; [@to_yojson fun _ -> `Null] partial_cmds : Partial_cmds.t; map : map; - mutable is_loop_func : bool; + mutable is_loop_proc : bool; prog : (annot, int) Prog.t; [@to_yojson fun _ -> `Null] - func_return_map : (id, string * int ref) Hashtbl.t; - mutable func_return_count : int; + proc_return_map : (id, string * int ref) Hashtbl.t; + mutable proc_return_count : int; } [@@deriving to_yojson] @@ -532,11 +531,11 @@ struct ]) ("WislLifter.insert_new_cmd: " ^ msg) - let new_function_return_label caller_id state = - state.func_return_count <- state.func_return_count + 1; - let label = int_to_letters state.func_return_count in + let new_proc_return_label caller_id state = + state.proc_return_count <- state.proc_return_count + 1; + let label = int_to_letters state.proc_return_count in let count = ref 0 in - Hashtbl.add state.func_return_map caller_id (label, count); + Hashtbl.add state.proc_return_map caller_id (label, count); (label, count) let update_caller_branches ~caller_id ~cont_id (label, ix) state = @@ -545,8 +544,8 @@ struct let new_next = match node.next with | Some (Branch nexts) -> - let nexts = List.remove_assoc FuncExitPlaceholder nexts in - let case = Case (FuncExit label, ix) in + let nexts = List.remove_assoc ProcExitPlaceholder nexts in + let case = Case (ProcExit label, ix) in let bdata = (cont_id, None) in let nexts = nexts @ [ (case, (None, bdata)) ] in Ok (Some (Branch nexts)) @@ -572,16 +571,16 @@ struct Fmt.error "update_caller_branches - caller %a not found" pp_id caller_id - let resolve_func_branches ~state finished_partial = + let resolve_proc_branches ~state finished_partial = let Partial_cmds.{ all_ids; next_kind; callers; has_return; _ } = finished_partial in match (next_kind, has_return, callers) with | Zero, true, caller_id :: _ -> let label, count = - match Hashtbl.find_opt state.func_return_map caller_id with + match Hashtbl.find_opt state.proc_return_map caller_id with | Some (label, count) -> (label, count) - | None -> new_function_return_label caller_id state + | None -> new_proc_return_label caller_id state in incr count; let label = (label, !count) in @@ -590,7 +589,7 @@ struct Ok (Some label) | _ -> Ok None - let make_new_cmd ~func_return_label finished_partial = + let make_new_cmd ~proc_return_label finished_partial = let Partial_cmds. { all_ids; @@ -617,7 +616,7 @@ struct submap; prev; callers; - func_return_label; + proc_return_label; loc; } in @@ -712,7 +711,7 @@ struct let- () = insert_to_empty_map ~state ~prev ~stack_direction new_cmd in match (stack_direction, prev) with | _, None -> Error "inserting to non-empty map with no prev!" - | Some In, Some (parent_id, Some FuncExitPlaceholder) + | Some In, Some (parent_id, Some ProcExitPlaceholder) | Some In, Some (parent_id, None) -> let new_cmd = new_cmd |> with_prev None in let++ () = insert_as_submap ~state ~parent_id new_cmd.data.id in @@ -724,12 +723,12 @@ struct new_cmd | Some (Out prev_id), Some (inner_prev_id, _) -> let** case = - let func_return_label = - (get_exn state.map inner_prev_id).data.func_return_label + let proc_return_label = + (get_exn state.map inner_prev_id).data.proc_return_label in - match func_return_label with - | Some (label, ix) -> Ok (Case (FuncExit label, ix)) - | None -> Error "stepping out without function return label!" + match proc_return_label with + | Some (label, ix) -> Ok (Case (ProcExit label, ix)) + | None -> Error "stepping out without proc return label!" in let new_cmd = new_cmd |> with_prev (Some (prev_id, Some case)) in let++ () = insert_as_next ~state ~prev_id ~case new_cmd.data.id in @@ -740,10 +739,10 @@ struct let Partial_cmds.{ id; all_ids; prev; stack_direction; _ } = finished_partial in - let** func_return_label = - resolve_func_branches ~state finished_partial + let** proc_return_label = + resolve_proc_branches ~state finished_partial in - let new_cmd = make_new_cmd ~func_return_label finished_partial in + let new_cmd = make_new_cmd ~proc_return_label finished_partial in let** new_cmd = insert_cmd ~state ~prev ~stack_direction new_cmd in let () = insert state.map ~id ~all_ids new_cmd in let () = @@ -757,9 +756,9 @@ struct let insert_new_cmd = Insert_new_cmd.f module Init_or_handle = struct - (** Loop body functions have some boilerplate we want to ignore. + (** Loop body procs have some boilerplate we want to ignore. This would normally be [Hidden], but we want to only consider - the true case of the function *) + the true case of the proc *) let handle_loop_prefix exec_data = let { cmd_report; id; _ } = exec_data in let annot = CmdReport.(cmd_report.annot) in @@ -800,19 +799,19 @@ struct let f ~state ?prev_id ?gil_case (exec_data : exec_data) = let- () = let+ id, case = handle_loop_prefix exec_data in - state.is_loop_func <- true; + state.is_loop_proc <- true; Either.Left (id, case) in let gil_case = Option_utils.coalesce gil_case exec_data.cmd_report.branch_case in - let { tl_ast; partial_cmds = partials; is_loop_func; proc_name; prog; _ } + let { tl_ast; partial_cmds = partials; is_loop_proc; proc_name; prog; _ } = state in match let get_prev = get_prev ~state ~gil_case ~prev_id in - Partial_cmds.handle ~partials ~tl_ast ~prog ~get_prev ~is_loop_func + Partial_cmds.handle ~partials ~tl_ast ~prog ~get_prev ~is_loop_proc ~proc_name ~prev_id exec_data with | Finished finished -> @@ -981,10 +980,10 @@ struct (* If a FinalCmd is in a function call, get the caller ID and the relevant branch case for stepping forward, while checking that it actually exists. *) - let get_next_from_end state { callers; func_return_label; _ } = + let get_next_from_end state { callers; proc_return_label; _ } = let* caller_id = List_utils.hd_opt callers in - let* label, ix = func_return_label in - let case = Case (FuncExit label, ix) in + let* label, ix = proc_return_label in + let case = Case (ProcExit label, ix) in let* _ = match (get_exn state.map caller_id).next with | Some (Branch nexts) -> List.assoc_opt case nexts @@ -997,8 +996,8 @@ struct match (node.next, case, node.data.submap) with | (None | Some (Single _)), Some _, _ -> failwith "HORROR - tried to step case for non-branch cmd" - | ( Some (Branch [ (FuncExitPlaceholder, _) ]), - Some FuncExitPlaceholder, + | ( Some (Branch [ (ProcExitPlaceholder, _) ]), + Some ProcExitPlaceholder, Submap submap_id ) -> Either.left submap_id | Some (Single (None, _)), None, _ -> let id = List.hd (List.rev node.data.all_ids) in @@ -1102,7 +1101,7 @@ struct (* Bodge: step in if on func exit placeholder *) let- () = match (case, cmd.data.submap) with - | Some FuncExitPlaceholder, Submap submap_id -> + | Some ProcExitPlaceholder, Submap submap_id -> Some (submap_id, Debugger_utils.Step) | _ -> None in @@ -1125,8 +1124,8 @@ struct let () = match (node.next, node.data.submap) with | Some (Branch nexts), (NoSubmap | Proc _) -> - if List.mem_assoc FuncExitPlaceholder nexts then - step state id (Some FuncExitPlaceholder) |> ignore + if List.mem_assoc ProcExitPlaceholder nexts then + step state id (Some ProcExitPlaceholder) |> ignore | _ -> () in let node = get_exn state.map id in @@ -1141,7 +1140,7 @@ struct let node = get_exn state.map id in (* Failsafe in case of error paths in submap *) match node.next with - | Some (Branch [ (FuncExitPlaceholder, _) ]) -> (id, Debugger_utils.Step) + | Some (Branch [ (ProcExitPlaceholder, _) ]) -> (id, Debugger_utils.Step) | _ -> step_branch state id None let step_back state id = @@ -1203,10 +1202,10 @@ struct tl_ast; partial_cmds; map = Exec_map.make (); - is_loop_func = false; + is_loop_proc = false; prog; - func_return_map = Hashtbl.create 0; - func_return_count = 0; + proc_return_map = Hashtbl.create 0; + proc_return_count = 0; } in let finish_init () = diff --git a/wisl/lib/syntax/WFun.ml b/wisl/lib/syntax/WProc.ml similarity index 84% rename from wisl/lib/syntax/WFun.ml rename to wisl/lib/syntax/WProc.ml index 0e846de4..262b64c9 100644 --- a/wisl/lib/syntax/WFun.ml +++ b/wisl/lib/syntax/WProc.ml @@ -20,14 +20,14 @@ let add_spec f pre post variant loc = let spec = WSpec.make pre post variant f.name f.params loc in { f with spec = Some spec; floc = loc } -let functions_called f = WStmt.functions_called_by_list f.body +let procs_called f = WStmt.procs_called_by_list f.body let has_spec f = Option.is_some f.spec let get_by_id id f = let stmt_list_visitor = list_visitor_builder WStmt.get_by_id id in let aux_spec = Option.fold ~some:(WSpec.get_by_id id) ~none:`None in let expr_getter = WExpr.get_by_id id in - let self_or_none = if f.fid = id then `WFun f else `None in + let self_or_none = if f.fid = id then `WProc f else `None in let return_getter (ret_exp : WExpr.t) = if WExpr.get_id ret_exp = id then `Return ret_exp else `None in @@ -42,13 +42,12 @@ let pp fmt f = match f.spec with | None -> Format.fprintf fmt - "@[@[function %s(%a)@] {@,%a;@,@[return@ %a@]@]@\n}" - f.name + "@[@[proc %s(%a)@] {@,%a;@,@[return@ %a@]@]@\n}" f.name (WPrettyUtils.pp_list Format.pp_print_string) f.params pp_list_stmt f.body WExpr.pp f.return_expr | Some spec -> Format.fprintf fmt - "@[{ %a }@]@[@[function %s(%a)@] {@,\ + "@[{ %a }@]@[@[proc %s(%a)@] {@,\ %a;@,\ @[return@ %a@]@]@\n\ }@\n\ diff --git a/wisl/lib/syntax/WFun.mli b/wisl/lib/syntax/WProc.mli similarity index 92% rename from wisl/lib/syntax/WFun.mli rename to wisl/lib/syntax/WProc.mli index 8ea4ea7a..104b1c62 100644 --- a/wisl/lib/syntax/WFun.mli +++ b/wisl/lib/syntax/WProc.mli @@ -17,7 +17,7 @@ val get_spec : t -> WSpec.t option val add_spec : t -> WLAssert.t -> WLAssert.t -> WLExpr.t option -> CodeLoc.t -> t -val functions_called : t -> string list +val procs_called : t -> string list val has_spec : t -> bool val get_by_id : @@ -26,7 +26,7 @@ val get_by_id : [> `None | `Return of WExpr.t | `WExpr of WExpr.t - | `WFun of t + | `WProc of t | `WLAssert of WLAssert.t | `WLCmd of WLCmd.t | `WLExpr of WLExpr.t diff --git a/wisl/lib/syntax/WProg.ml b/wisl/lib/syntax/WProg.ml index 0efef49c..19e2cf96 100644 --- a/wisl/lib/syntax/WProg.ml +++ b/wisl/lib/syntax/WProg.ml @@ -1,7 +1,7 @@ open VisitorUtils type t = { - context : WFun.t list; + context : WProc.t list; predicates : WPred.t list; lemmas : WLemma.t list; datatypes : WDatatype.t list; @@ -11,7 +11,7 @@ let get_context p = p.context let pp_context = WPrettyUtils.pp_list ~sep:(format_of_string "@,@,") - ~suf:(format_of_string "@]@.") WFun.pp + ~suf:(format_of_string "@]@.") WProc.pp let pp fmt = function | prog -> Format.fprintf fmt "%a" pp_context prog.context @@ -20,32 +20,32 @@ module StringSet = Set.Make (String) module StringMap = Map.Make (String) let never_called_during_symb prog = - let fmap = + let pmap = List.fold_left - (fun map f -> StringMap.add (WFun.get_name f) f map) + (fun map p -> StringMap.add (WProc.get_name p) p map) StringMap.empty prog.context in - let allf = StringSet.of_list (List.map WFun.get_name prog.context) in - let has_spec fname = - let f = StringMap.find fname fmap in - WFun.has_spec f + let allp = StringSet.of_list (List.map WProc.get_name prog.context) in + let has_spec pname = + let p = StringMap.find pname pmap in + WProc.has_spec p in - let have_spec = StringSet.filter has_spec allf in + let have_spec = StringSet.filter has_spec allp in let rec find_fixed_point compare f a = let b = f a in if compare a b = 0 then b else find_fixed_point compare f b in - let fold_fun fname set = - let f = StringMap.find_opt fname fmap in + let fold_proc pname set = + let p = StringMap.find_opt pname pmap in StringSet.union set - (StringSet.of_list (Option.fold ~some:WFun.functions_called ~none:[] f)) + (StringSet.of_list (Option.fold ~some:WProc.procs_called ~none:[] p)) in - let step set = StringSet.fold fold_fun set set in + let step set = StringSet.fold fold_proc set set in let called = find_fixed_point StringSet.compare step have_spec in - let not_called_names = StringSet.diff allf called in + let not_called_names = StringSet.diff allp called in let not_called = List.map - (fun x -> StringMap.find x fmap) + (fun x -> StringMap.find x pmap) (StringSet.elements not_called_names) in not_called @@ -57,39 +57,40 @@ let get_pred prog name = in aux prog.predicates -let get_fun prog name = +let get_proc prog name = let rec aux = function | [] -> None - | p :: r -> if String.equal (WFun.get_name p) name then Some p else aux r + | p :: r -> if String.equal (WProc.get_name p) name then Some p else aux r in aux prog.context -let get_by_id ?(fname = None) prog id = +let get_by_id ?(proc_name = None) prog id = match id with | None -> `None | Some id -> ( - let aux_f = list_visitor_builder WFun.get_by_id id in - let aux_p = list_visitor_builder WPred.get_by_id id in - let aux_l = list_visitor_builder WLemma.get_by_id id in - let fun_getter = WFun.get_by_id id in - match fname with + let aux_proc = list_visitor_builder WProc.get_by_id id in + let aux_pred = list_visitor_builder WPred.get_by_id id in + let aux_lemma = list_visitor_builder WLemma.get_by_id id in + let proc_getter = WProc.get_by_id id in + match proc_name with | None -> - aux_f prog.context |>> (aux_p, prog.predicates) - |>> (aux_l, prog.lemmas) - | Some f -> ( - match List.find_opt (fun ff -> ff.WFun.name = f) prog.context with + aux_proc prog.context + |>> (aux_pred, prog.predicates) + |>> (aux_lemma, prog.lemmas) + | Some p -> ( + match List.find_opt (fun pp -> pp.WProc.name = p) prog.context with | None -> `None - | Some ff -> fun_getter ff)) + | Some ff -> proc_getter ff)) -let get_function_name_of_element prog id = - let is_in_function f = - match WFun.get_by_id id f with +let get_proc_name_of_element prog id = + let is_in_proc p = + match WProc.get_by_id id p with | `None -> false | _ -> true in - let rec find_f l = + let rec find_p l = match l with - | f :: r -> if is_in_function f then WFun.get_name f else find_f r + | p :: r -> if is_in_proc p then WProc.get_name p else find_p r | _ -> "" in - find_f prog.context + find_p prog.context diff --git a/wisl/lib/syntax/WProg.mli b/wisl/lib/syntax/WProg.mli index e11b16f0..9a408126 100644 --- a/wisl/lib/syntax/WProg.mli +++ b/wisl/lib/syntax/WProg.mli @@ -1,20 +1,20 @@ type t = { - context : WFun.t list; + context : WProc.t list; predicates : WPred.t list; lemmas : WLemma.t list; datatypes : WDatatype.t list; } -val get_context : t -> WFun.t list +val get_context : t -> WProc.t list val get_by_id : - ?fname:string option -> + ?proc_name:string option -> t -> int option -> [> `None | `Return of WExpr.t | `WExpr of WExpr.t - | `WFun of WFun.t + | `WProc of WProc.t | `WLAssert of WLAssert.t | `WLCmd of WLCmd.t | `WLExpr of WLExpr.t @@ -25,8 +25,8 @@ val get_by_id : | `WStmt of WStmt.t ] val get_pred : t -> string -> WPred.t option -val get_fun : t -> string -> WFun.t option -val never_called_during_symb : t -> WFun.t list -val pp_context : Format.formatter -> WFun.t list -> unit +val get_proc : t -> string -> WProc.t option +val never_called_during_symb : t -> WProc.t list +val pp_context : Format.formatter -> WProc.t list -> unit val pp : Format.formatter -> t -> unit -val get_function_name_of_element : t -> int -> string +val get_proc_name_of_element : t -> int -> string diff --git a/wisl/lib/syntax/WSpec.ml b/wisl/lib/syntax/WSpec.ml index 71214181..7c700a69 100644 --- a/wisl/lib/syntax/WSpec.ml +++ b/wisl/lib/syntax/WSpec.ml @@ -6,9 +6,9 @@ type t = { variant : WLExpr.t option; existentials : (string * string list) option; spid : int; - fname : string; + proc_name : string; (* name of the function *) - fparams : string list; + proc_params : string list; (* parameters of the function *) sploc : CodeLoc.t; } @@ -23,14 +23,14 @@ let get_by_id id spec = let self_or_none = if get_id spec = id then `WSpec spec else `None in self_or_none |>> (lassert_getter, spec.pre) |>> (lassert_getter, spec.post) -let make ?existentials pre post variant fname fparams loc = +let make ?existentials pre post variant proc_name proc_params loc = { pre; post; variant; spid = Generators.gen_id (); sploc = loc; - fname; - fparams; + proc_name; + proc_params; existentials; } diff --git a/wisl/lib/syntax/WSpec.mli b/wisl/lib/syntax/WSpec.mli index 4a60c441..be9ec065 100644 --- a/wisl/lib/syntax/WSpec.mli +++ b/wisl/lib/syntax/WSpec.mli @@ -4,8 +4,8 @@ type t = { variant : WLExpr.t option; (** Variant *) existentials : (string * string list) option; (** Existentials in the spec *) spid : int; (** Unique identifier of AST el *) - fname : string; (** Name of the function the spec is attached to *) - fparams : string list; + proc_name : string; (** Name of the function the spec is attached to *) + proc_params : string list; (** Parameters of the function the spec is attached to *) sploc : CodeLoc.t; (** Code location of the spec *) } diff --git a/wisl/lib/syntax/WStmt.ml b/wisl/lib/syntax/WStmt.ml index f3e63499..e5c29065 100644 --- a/wisl/lib/syntax/WStmt.ml +++ b/wisl/lib/syntax/WStmt.ml @@ -8,7 +8,7 @@ type tt = | Dispose of WExpr.t | Lookup of string * WExpr.t (* x := [e] *) | Update of WExpr.t * WExpr.t (* [e] := [e] *) - | FunCall of string * string * WExpr.t list * (string * string list) option + | ProcCall of string * string * WExpr.t list * (string * string list) option (* The last bit is only for internal use *) | While of WExpr.t * t list | If of WExpr.t * t list * t list @@ -40,7 +40,7 @@ and pp fmt stmt = | Lookup (v, e) -> Format.fprintf fmt "@[%s := [%a]@]" v WExpr.pp e | Update (e1, e2) -> Format.fprintf fmt "@[[%a] := %a@]" WExpr.pp e1 WExpr.pp e2 - | FunCall (v, f, el, _) -> + | ProcCall (v, f, el, _) -> Format.fprintf fmt "@[%s := %s(%a)@]" v f (WPrettyUtils.pp_list WExpr.pp) el @@ -78,10 +78,11 @@ let is_unfold s = | Logic lcmd when WLCmd.is_unfold lcmd -> true | _ -> false -let functions_called_by_list sl = +let procs_called_by_list sl = let rec aux already = function | [] -> already - | { snode = FunCall (_, fname, _, _); _ } :: r -> aux (fname :: already) r + | { snode = ProcCall (_, proc_name, _, _); _ } :: r -> + aux (proc_name :: already) r | { snode = While (_, slp); _ } :: r -> aux (aux already slp @ already) r | { snode = If (_, slp1, slp2); _ } :: r -> aux (aux already slp1 @ aux already slp2 @ already) r @@ -103,7 +104,7 @@ let rec get_by_id id stmt = | Assume e | AssumeType (e, _) -> expr_getter e | Update (e1, e2) -> expr_getter e1 |>> (expr_getter, e2) - | FunCall (_, _, el, _) -> expr_list_visitor el + | ProcCall (_, _, el, _) -> expr_list_visitor el | While (e, sl) -> expr_getter e |>> (list_visitor, sl) | If (e, sl1, sl2) -> expr_getter e |>> (list_visitor, sl1) |>> (list_visitor, sl2) diff --git a/wisl/lib/syntax/WStmt.mli b/wisl/lib/syntax/WStmt.mli index be905165..79baa3c6 100644 --- a/wisl/lib/syntax/WStmt.mli +++ b/wisl/lib/syntax/WStmt.mli @@ -6,7 +6,7 @@ type tt = | Dispose of WExpr.t (** free(e) *) | Lookup of string * WExpr.t (** x := [e] *) | Update of WExpr.t * WExpr.t (** [e] := [e] *) - | FunCall of string * string * WExpr.t list * (string * string list) option + | ProcCall of string * string * WExpr.t list * (string * string list) option (** x := f(e1, ..., en), last bit should be ignored *) | While of WExpr.t * t list (** while (e) \{ s \} *) | If of WExpr.t * t list * t list (** if (e) \{ s \} else \{ s \} *) @@ -39,6 +39,6 @@ val get_by_id : | `WLFormula of WLFormula.t | `WStmt of t ] -val functions_called_by_list : t list -> string list +val procs_called_by_list : t list -> string list (* val check_consistency : t list -> CodeLoc.t -> unit *) diff --git a/wisl/lib/utils/wBranchCase.ml b/wisl/lib/utils/wBranchCase.ml index d8b80279..55def35c 100644 --- a/wisl/lib/utils/wBranchCase.ml +++ b/wisl/lib/utils/wBranchCase.ml @@ -1,15 +1,15 @@ type kind = IfElseKind | WhileLoopKind [@@deriving yojson] -type case = IfElse of bool | WhileLoop of bool | FuncExit of string | Unknown +type case = IfElse of bool | WhileLoop of bool | ProcExit of string | Unknown [@@deriving yojson] -type t = Case of case * int | FuncExitPlaceholder [@@deriving yojson] +type t = Case of case * int | ProcExitPlaceholder [@@deriving yojson] let pp fmt = function | Case (Unknown, i) -> Fmt.pf fmt "%d" i | Case ((IfElse b | WhileLoop b), -1) -> Fmt.pf fmt "%B" b | Case ((IfElse b | WhileLoop b), i) -> Fmt.pf fmt "%B - %d" b i - | Case (FuncExit label, i) -> Fmt.pf fmt "%s-%d" label i - | FuncExitPlaceholder -> Fmt.pf fmt "" + | Case (ProcExit label, i) -> Fmt.pf fmt "%s-%d" label i + | ProcExitPlaceholder -> Fmt.pf fmt "" let display = Fmt.str "%a" pp diff --git a/wisl/lib/utils/wErrors.ml b/wisl/lib/utils/wErrors.ml index 569dd1e9..3eab32b8 100644 --- a/wisl/lib/utils/wErrors.ml +++ b/wisl/lib/utils/wErrors.ml @@ -16,7 +16,7 @@ type t = { code : string; severity : severity; related_information : related_info_t list; - function_name : string; + proc_name : string; } type res_t = (unit, t) result @@ -28,8 +28,8 @@ type error_code_t = | SyntaxError | MissingResource | UnconsistentStmtBloc - | FunctionNotVerified - | UndefinedFunction + | ProcNotVerified + | UndefinedProc | UndefinedLemma | MissingInvariant @@ -40,8 +40,8 @@ let str_error_code = function | SyntaxError -> "SyntaxError" | MissingResource -> "MissingResource" | UnconsistentStmtBloc -> "UnconsistentStmtBloc" - | FunctionNotVerified -> "FunctionNotVerified" - | UndefinedFunction -> "UndefinedFonction" + | ProcNotVerified -> "ProcNotVerified" + | UndefinedProc -> "UndefinedProc" | UndefinedLemma -> "UndefinedLemma" | MissingInvariant -> "MissingInvariant" @@ -53,21 +53,21 @@ let get_errors results = in get_errors' [] results -let build_consistency_error message range function_name = +let build_consistency_error message range proc_name = let code = str_error_code UnconsistentStmtBloc in let severity = SevError in let related_information = [] in - { message; range; code; severity; related_information; function_name } + { message; range; code; severity; related_information; proc_name } -let build_warning_not_called range function_name = - let code = str_error_code FunctionNotVerified in +let build_warning_not_called range proc_name = + let code = str_error_code ProcNotVerified in let message = "This function is never verified because it has no specification and is \ never called from a function that is verified" in let severity = SevWarning in let related_information = [] in - { code; message; severity; related_information; range; function_name } + { code; message; severity; related_information; range; proc_name } let build_warning_invariant range = let code = str_error_code MissingInvariant in @@ -77,7 +77,7 @@ let build_warning_invariant range = in let severity = SevWarning in let related_information = [] in - { code; message; severity; related_information; range; function_name = "" } + { code; message; severity; related_information; range; proc_name = "" } let build_err_string error_code id loc message = Format.sprintf "%s;%i;%s;%s" diff --git a/wisl/lib/utils/wErrors.mli b/wisl/lib/utils/wErrors.mli index f4fba6a0..33d9573d 100644 --- a/wisl/lib/utils/wErrors.mli +++ b/wisl/lib/utils/wErrors.mli @@ -9,7 +9,7 @@ type t = { code : string; severity : severity; related_information : related_info_t list; - function_name : string; + proc_name : string; } type error_code_t = @@ -19,8 +19,8 @@ type error_code_t = | SyntaxError | MissingResource | UnconsistentStmtBloc - | FunctionNotVerified - | UndefinedFunction + | ProcNotVerified + | UndefinedProc | UndefinedLemma | MissingInvariant From f290d9d0e3f1d35269eaa18013095ae3736b4b75 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Sun, 27 Apr 2025 12:23:38 +0100 Subject: [PATCH 24/37] Parsing of WISL functions --- wisl/examples/SLL_adt.wisl | 106 ++++++---------------- wisl/lib/ParserAndCompiler/WLexer.mll | 1 + wisl/lib/ParserAndCompiler/WParser.mly | 116 ++++++++++++++++--------- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 7 +- wisl/lib/syntax/WFunc.ml | 6 ++ wisl/lib/syntax/WFunc.mli | 6 ++ wisl/lib/syntax/WLExpr.ml | 11 +-- wisl/lib/syntax/WLExpr.mli | 3 +- wisl/lib/syntax/WProg.ml | 1 + wisl/lib/syntax/WProg.mli | 1 + wisl/lib/syntax/WType.ml | 2 +- 11 files changed, 132 insertions(+), 128 deletions(-) create mode 100644 wisl/lib/syntax/WFunc.ml create mode 100644 wisl/lib/syntax/WFunc.mli diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl index 0f42dc54..0756982d 100644 --- a/wisl/examples/SLL_adt.wisl +++ b/wisl/examples/SLL_adt.wisl @@ -1,4 +1,3 @@ -// Define a list ADT for use in specification language datatype MyList { Nil; Cons(Any, MyList) @@ -6,122 +5,73 @@ datatype MyList { // -// Standard over-approximating SLL predicate with contents +// Standard over-approximating sll predicate with contents // -predicate SLL(+x, vs) { - // Empty SLL - (x == null) * (vs == Nil()); - // One SLL node and the rest - (x -b> #v, #next) * SLL(#next, #vs) * - (vs == Cons(#v, #vs)) +predicate sll(+x, vs) { + // Empty sll + (x == null) * (vs == 'Nil); + // One sll node and the rest + (x -b> #v, #next) * sll(#next, #vs) * + (vs == 'Cons(#v, #vs)) } -// -// Pure predicate for list membership -// -// predicate list_member(+vs, +v, r : Bool){ -// (vs == Nil) * (r == false); -// (vs == Cons(v, #rest)) * (r == true) * list_member(#rest, v, #mem); -// (vs == Cons(#v, #rest)) * (! (#v == v)) * list_member(#rest, v, r) -// } - -// 00. Allocating an SLL node with the given value +// 00. Allocating an sll node with the given value { v == #v } -proc SLL_allocate_node(v){ +proc sll_allocate_node(v){ t := new(2); [t] := v; return t } -{ SLL(ret, Cons(#v, Nil())) } +{ sll(ret, 'Cons(#v, 'Nil)) } // This incorrect spec should fail to verify { (v == #v) * (u == #u) } -proc SLL_allocate_node_fails(u, v){ +proc sll_allocate_node_fails(u, v){ t := new(2); [t] := v; return t } -{ SLL(ret, Cons(#u, Nil())) } +{ sll(ret, 'Cons(#u, 'Nil)) } // -// RECURSIVE SLL MANIPULATION +// RECURSIVE sll MANIPULATION // -// 01. Prepending a given value to a given SLL -{ (x == #x) * (k == #k) * SLL(#x, #vs) } -proc SLL_prepend(x, k){ - z := SLL_allocate_node(k); +// 01. Prepending a given value to a given sll +{ (x == #x) * (k == #k) * sll(#x, #vs) } +proc sll_prepend(x, k){ + z := sll_allocate_node(k); [z + 1] := x; return z } -{ SLL(ret, Cons(#k, #vs)) } +{ sll(ret, 'Cons(#k, #vs)) } -// 05. Copying a given SLL -{ (x == #x) * SLL(#x, #vs) } -proc SLL_copy(x){ +// 05. Copying a given sll +{ (x == #x) * sll(#x, #vs) } +proc sll_copy(x){ y := null; if (not (x = null)) { k := [x]; - y := SLL_allocate_node(k); + y := sll_allocate_node(k); t := [x + 1]; - z := SLL_copy(t); + z := sll_copy(t); [y + 1] := z } else { skip }; return y } -{ SLL(#x, #vs) * SLL(ret, #vs) } - -// 08. Checking if a given value is in a given SLL -// { (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #r) } -// proc SLL_member(x, k){ -// found := false; -// if (x = null){ -// skip -// } else { -// v := [x]; -// if (v = k){ -// found := true -// } else { -// t := [x + 1]; -// found := SLL_member(t, k) -// } -// }; -// return found -// } -// { SLL(#x, #vs) * list_member(#vs, #k, #r) * (ret == #r) } - -// 09. Removing a given value from a given SLL -// { (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #mem) } -// proc SLL_remove(x, k) { -// if (x = null) { -// skip -// } else { -// v := [x]; -// next := [x + 1]; -// if (v = k){ -// free(x); -// x := SLL_remove(next, k) -// } else { -// z := SLL_remove(next, k); -// [x + 1] := z -// } -// }; -// [[ fold list_member(Nil, #k, false) ]]; -// return x -// } -// { SLL(ret, #nvs) * list_member(#nvs, #k, false) } +{ sll(#x, #vs) * sll(ret, #vs) } -// 10. Freeing a given SLL -{ (x == #x) * SLL(#x, #vs) } -proc SLL_free(x){ +// 10. Freeing a given sll +{ (x == #x) * sll(#x, #vs) } +proc sll_free(x){ if (x = null) { skip } else { t := [x + 1]; - z := SLL_free(t); + z := sll_free(t); free(x) }; return null diff --git a/wisl/lib/ParserAndCompiler/WLexer.mll b/wisl/lib/ParserAndCompiler/WLexer.mll index 62ff8c60..ad3c7932 100644 --- a/wisl/lib/ParserAndCompiler/WLexer.mll +++ b/wisl/lib/ParserAndCompiler/WLexer.mll @@ -93,6 +93,7 @@ rule read = | ',' { COMMA (curr lexbuf) } | "." { DOT (curr lexbuf) } | ';' { SEMICOLON (curr lexbuf) } + | '\'' { QUOTE (curr lexbuf) } | "|-" { VDASH (curr lexbuf) } (* binary operators *) | "::" { LSTCONS } diff --git a/wisl/lib/ParserAndCompiler/WParser.mly b/wisl/lib/ParserAndCompiler/WParser.mly index 61ce8e01..a6fad0b3 100644 --- a/wisl/lib/ParserAndCompiler/WParser.mly +++ b/wisl/lib/ParserAndCompiler/WParser.mly @@ -23,6 +23,7 @@ %token SETOPEN /* -{ */ %token SETCLOSE /* }- */ %token VDASH /* |- */ +%token QUOTE /* ' */ (* types *) %token TLIST @@ -96,57 +97,62 @@ %start prog %start assert_only -%type definitions -%type proc_with_specs -%type proc -%type predicate -%type lemma -%type datatype -%type var_list -%type statement_list_and_return -%type statement_list -%type expression -%type expr_list -%type logic_command -%type logic_assertion -%type value_with_loc -%type unop_with_loc -%type binop -%type variant_def -%type with_variant_def -%type proof_def -%type <(string * WType.t option) * bool> pred_param_ins -%type bindings_with_loc -%type logic_pure_formula -%type logic_expression -%type logic_binop -%type logic_value_with_loc -%type constructor -%type constructor_fields +%type definitions +%type proc_with_specs +%type proc +%type predicate +%type lemma +%type datatype +%type func +%type var_list +%type statement_list_and_return +%type statement_list +%type expression +%type expr_list +%type logic_command +%type logic_assertion +%type value_with_loc +%type unop_with_loc +%type binop +%type variant_def +%type with_variant_def +%type proof_def +%type <(string * WType.t option) * bool> pred_param_ins +%type bindings_with_loc +%type logic_pure_formula +%type logic_expression +%type logic_binop +%type logic_value_with_loc +%type constructor +%type constructor_fields +%type func_param %% prog: | defs = definitions; EOF { - let (fc, preds, lemmas, datatypes) = defs in - WProg.{ lemmas = lemmas; predicates = preds; context = fc; datatypes = datatypes } } + let (fc, preds, lemmas, datatypes, funcs) = defs in + WProg.{ lemmas = lemmas; predicates = preds; context = fc; datatypes = datatypes; functions = funcs} } assert_only: | la = logic_assertion; EOF { la } definitions: - | (* empty *) { ([], [], [], []) } + | (* empty *) { ([], [], [], [], []) } | defs = definitions; p = predicate - { let (fs, ps, ls, ds) = defs in - (fs, p::ps, ls, ds) } + { let (procs, preds, lemmas, datatypes, funcs) = defs in + (procs, p::preds, lemmas, datatypes, funcs) } | defs = definitions; l = lemma - { let (fs, ps, ls, ds) = defs in - (fs, ps, l::ls, ds) } - | defs = definitions; f = proc_with_specs - { let (fs, ps, ls, ds) = defs in - (f::fs, ps, ls, ds) } + { let (procs, preds, lemmas, datatypes, funcs) = defs in + (procs, preds, l::lemmas, datatypes, funcs) } + | defs = definitions; p = proc_with_specs + { let (procs, preds, lemmas, datatypes, funcs) = defs in + (p::procs, preds, lemmas, datatypes, funcs) } | defs = definitions; d = datatype - { let (fs, ps, ls, ds) = defs in - (fs, ps, ls, d::ds) } + { let (procs, preds, lemmas, datatypes, funcs) = defs in + (procs, preds, lemmas, d::datatypes, funcs) } + | defs = definitions; f = func + { let (procs, preds, lemmas, datatypes, funcs) = defs in + (procs, preds, lemmas, datatypes, f::funcs) } proc_with_specs: | lstart = LCBRACE; pre = logic_assertion; RCBRACE; variant = option(with_variant_def); p = proc; LCBRACE; @@ -635,9 +641,18 @@ logic_expression: | lname = IDENTIFIER; LBRACE; l = separated_list(COMMA, logic_expression); lend = RBRACE { let (lstart, name) = lname in let loc = CodeLoc.merge lstart lend in - let bare_lexpr = WLExpr.LConstructor (name, l) in + let bare_lexpr = WLExpr.LFuncApp (name, l) in + WLExpr.make bare_lexpr loc } + | lstart = QUOTE; lname = IDENTIFIER; + llend = option(logic_constructor_app_params) + { let (_, name) = lname in + let (l, lend) = Option.value ~default:([], lstart) llend in + let loc = CodeLoc.merge lstart lend in + let bare_lexpr = WLExpr.LConstructorApp (name, l) in WLExpr.make bare_lexpr loc } +logic_constructor_app_params: + | LBRACE; lst = separated_list(COMMA, logic_expression); lend = RBRACE; { (lst, lend) } (* We also have lists in the logic *) logic_binop: @@ -700,3 +715,24 @@ constructor: constructor_fields: | LBRACE; args = separated_list(COMMA, type_target); lend = RBRACE { (args, lend) } + + +(* Logical Functions *) + +func: + | lstart = FUNCTION; lfname = IDENTIFIER; LBRACE; func_params = separated_list(COMMA, func_param); + RBRACE; LCBRACE; func_definition=logic_expression; lend = RCBRACE + { + let func_loc = CodeLoc.merge lstart lend in + let (_, func_name) = lfname in + WFunc.{ + func_name; + func_params; + func_definition; + func_loc; + } + } + +func_param: + | lx = IDENTIFIER; typ = option(preceded(COLON, type_target)) + { let (_, x) = lx in (x, typ) } diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index f55bd27b..9d89f843 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -234,11 +234,12 @@ let rec compile_lexpr ?(proc_name = "main") (lexpr : WLExpr.t) : list_split_3 (List.map compile_lexpr l) in (List.concat gvars, List.concat asrtsl, Expr.ESet comp_exprs) - | LConstructor (n, l) -> + | LConstructorApp (n, l) -> let gvars, asrtsl, comp_exprs = list_split_3 (List.map compile_lexpr l) in - (List.concat gvars, List.concat asrtsl, Expr.Constructor (n, comp_exprs))) + (List.concat gvars, List.concat asrtsl, Expr.Constructor (n, comp_exprs)) + | LFuncApp (_, _) -> failwith "TODO") (* TODO: compile_lformula should return also the list of created existentials *) let rec compile_lformula ?(proc_name = "main") formula : Asrt.t * Expr.t = @@ -1185,7 +1186,7 @@ let compile_datatype datatype_constructors = comp_constructors; } -let compile ~filepath WProg.{ context; predicates; lemmas; datatypes } = +let compile ~filepath WProg.{ context; predicates; lemmas; datatypes; _ } = (* stuff useful to build hashtables *) let make_hashtbl get_name deflist = let hashtbl = Hashtbl.create (List.length deflist) in diff --git a/wisl/lib/syntax/WFunc.ml b/wisl/lib/syntax/WFunc.ml new file mode 100644 index 00000000..d98c404a --- /dev/null +++ b/wisl/lib/syntax/WFunc.ml @@ -0,0 +1,6 @@ +type t = { + func_name : string; + func_params : (string * WType.t option) list; + func_definition : WLExpr.t; + func_loc : CodeLoc.t; +} diff --git a/wisl/lib/syntax/WFunc.mli b/wisl/lib/syntax/WFunc.mli new file mode 100644 index 00000000..d98c404a --- /dev/null +++ b/wisl/lib/syntax/WFunc.mli @@ -0,0 +1,6 @@ +type t = { + func_name : string; + func_params : (string * WType.t option) list; + func_definition : WLExpr.t; + func_loc : CodeLoc.t; +} diff --git a/wisl/lib/syntax/WLExpr.ml b/wisl/lib/syntax/WLExpr.ml index 7ac0da64..5a2d0223 100644 --- a/wisl/lib/syntax/WLExpr.ml +++ b/wisl/lib/syntax/WLExpr.ml @@ -9,8 +9,8 @@ type tt = | LLSub of t * t * t | LEList of t list | LESet of t list - (* TODO: Double check handling of LConstructor in functions that manipulate WLExpr *) - | LConstructor of string * t list + | LFuncApp of string * t list (* Function application *) + | LConstructorApp of string * t list (* Constructor application *) and t = { wleid : int; wleloc : CodeLoc.t; wlenode : tt } @@ -50,7 +50,7 @@ let rec get_by_id id lexpr = | LUnOp (_, lep) -> getter lep | LEList lel -> list_visitor lel | LESet lel -> list_visitor lel - | LConstructor (_, lel) -> list_visitor lel + | LFuncApp (_, lel) | LConstructorApp (_, lel) -> list_visitor lel | _ -> `None in let self_or_none = if get_id lexpr = id then `WLExpr lexpr else `None in @@ -74,7 +74,7 @@ let rec pp fmt lexpr = | LESet lel -> WPrettyUtils.pp_list ~pre:(format_of_string "@[-{") ~suf:(format_of_string "}-@]") pp fmt lel - | LConstructor (name, lel) -> + | LFuncApp (name, lel) | LConstructorApp (name, lel) -> Format.fprintf fmt "@[%s" name; WPrettyUtils.pp_list ~pre:(format_of_string "(") ~suf:(format_of_string ")@]") ~empty:(format_of_string "@]") pp fmt lel @@ -94,6 +94,7 @@ let rec substitution (subst : (string, tt) Hashtbl.t) (e : t) : t = | LLSub (e1, e2, e3) -> LLSub (f e1, f e2, f e3) | LEList le -> LEList (List.map f le) | LESet le -> LESet (List.map f le) - | LConstructor (name, le) -> LConstructor (name, List.map f le) + | LFuncApp (name, le) | LConstructorApp (name, le) -> + LFuncApp (name, List.map f le) in { wleid; wleloc; wlenode } diff --git a/wisl/lib/syntax/WLExpr.mli b/wisl/lib/syntax/WLExpr.mli index e4541d2c..9575f520 100644 --- a/wisl/lib/syntax/WLExpr.mli +++ b/wisl/lib/syntax/WLExpr.mli @@ -7,7 +7,8 @@ type tt = | LLSub of t * t * t | LEList of t list | LESet of t list - | LConstructor of string * t list + | LFuncApp of string * t list + | LConstructorApp of string * t list and t diff --git a/wisl/lib/syntax/WProg.ml b/wisl/lib/syntax/WProg.ml index 19e2cf96..0d8bebb9 100644 --- a/wisl/lib/syntax/WProg.ml +++ b/wisl/lib/syntax/WProg.ml @@ -5,6 +5,7 @@ type t = { predicates : WPred.t list; lemmas : WLemma.t list; datatypes : WDatatype.t list; + functions : WFunc.t list; } let get_context p = p.context diff --git a/wisl/lib/syntax/WProg.mli b/wisl/lib/syntax/WProg.mli index 9a408126..ac8b5dcb 100644 --- a/wisl/lib/syntax/WProg.mli +++ b/wisl/lib/syntax/WProg.mli @@ -3,6 +3,7 @@ type t = { predicates : WPred.t list; lemmas : WLemma.t list; datatypes : WDatatype.t list; + functions : WFunc.t list; } val get_context : t -> WProc.t list diff --git a/wisl/lib/syntax/WType.ml b/wisl/lib/syntax/WType.ml index c3b61b51..50ec68ef 100644 --- a/wisl/lib/syntax/WType.ml +++ b/wisl/lib/syntax/WType.ml @@ -135,7 +135,7 @@ let rec infer_logic_expr knownp lexpr = TypeMap.add bare_lexpr WList (List.fold_left infer_logic_expr knownp lel) | LESet lel -> TypeMap.add bare_lexpr WSet (List.fold_left infer_logic_expr knownp lel) - | LConstructor (n, lel) -> + | LFuncApp (n, lel) | LConstructorApp (n, lel) -> TypeMap.add bare_lexpr (WDatatype n) (List.fold_left infer_logic_expr knownp lel) From 08265788586abcaf7e5c455d5694bc54bf21674b Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Sun, 27 Apr 2025 12:32:04 +0100 Subject: [PATCH 25/37] Fixed pretty printer for constructor app in WISL --- wisl/lib/syntax/WLExpr.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/wisl/lib/syntax/WLExpr.ml b/wisl/lib/syntax/WLExpr.ml index 5a2d0223..8069fe0e 100644 --- a/wisl/lib/syntax/WLExpr.ml +++ b/wisl/lib/syntax/WLExpr.ml @@ -74,10 +74,14 @@ let rec pp fmt lexpr = | LESet lel -> WPrettyUtils.pp_list ~pre:(format_of_string "@[-{") ~suf:(format_of_string "}-@]") pp fmt lel - | LFuncApp (name, lel) | LConstructorApp (name, lel) -> + | LFuncApp (name, lel) -> Format.fprintf fmt "@[%s" name; WPrettyUtils.pp_list ~pre:(format_of_string "(") ~suf:(format_of_string ")@]") ~empty:(format_of_string "@]") pp fmt lel + | LConstructorApp (name, lel) -> + Format.fprintf fmt "@['%s" name; + WPrettyUtils.pp_list ~pre:(format_of_string "(") + ~suf:(format_of_string ")@]") ~empty:(format_of_string "@]") pp fmt lel let str = Format.asprintf "%a" pp From 9e25b8ed54d45e62c0f10831d5a6d413cab7a5f8 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Sun, 27 Apr 2025 12:51:53 +0100 Subject: [PATCH 26/37] Refactored Constructor -> ConstructorApp --- GillianCore/GIL_Syntax/Expr.ml | 10 ++++++---- GillianCore/GIL_Syntax/Gil_syntax.mli | 17 ++++++++++------- GillianCore/GIL_Syntax/TypeDef__.ml | 2 +- GillianCore/engine/Abstraction/MP.ml | 6 +++--- GillianCore/engine/Abstraction/Normaliser.ml | 4 ++-- GillianCore/engine/FOLogic/Reduction.ml | 10 +++++----- GillianCore/engine/FOLogic/smt.ml | 2 +- GillianCore/engine/FOLogic/typing.ml | 4 ++-- .../engine/concrete_semantics/CExprEval.ml | 2 +- GillianCore/engine/symbolic_semantics/SState.ml | 2 +- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 4 +++- 11 files changed, 35 insertions(+), 28 deletions(-) diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index 34bd24c2..e656c64f 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -16,7 +16,7 @@ type t = TypeDef__.expr = (** Existential quantification. *) | ForAll of (string * Type.t option) list * t (** Universal quantification. *) - | Constructor of string * t list (** Datatype constructor *) + | ConstructorApp of string * t list (** Datatype constructor *) [@@deriving eq, ord] let to_yojson = TypeDef__.expr_to_yojson @@ -378,7 +378,8 @@ let rec map_opt match map_e e with | Some e' -> Some (ForAll (bt, e')) | _ -> None) - | Constructor (n, les) -> aux les (fun les -> Constructor (n, les)) + | ConstructorApp (n, les) -> + aux les (fun les -> ConstructorApp (n, les)) in Option.map f_after mapped_expr @@ -416,7 +417,8 @@ let rec pp fmt e = Fmt.pf fmt "(forall %a . %a)" (Fmt.list ~sep:Fmt.comma pp_var_with_type) bt pp e - | Constructor (n, ll) -> Fmt.pf fmt "%s(%a)" n (Fmt.list ~sep:Fmt.comma pp) ll + | ConstructorApp (n, ll) -> + Fmt.pf fmt "%s(%a)" n (Fmt.list ~sep:Fmt.comma pp) ll let rec full_pp fmt e = match e with @@ -479,7 +481,7 @@ let rec is_concrete (le : t) : bool = | BinOp (e1, _, e2) -> loop [ e1; e2 ] | LstSub (e1, e2, e3) -> loop [ e1; e2; e3 ] | NOp (_, les) | EList les | ESet les -> loop les - | Constructor (_, _) -> false + | ConstructorApp (_, _) -> false (* TODO: Pretty sure constructors are not concrete, but double check *) let is_concrete_zero_i : t -> bool = function diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index efe9d548..f76a2ace 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -251,7 +251,7 @@ module Expr : sig | Exists of (string * Type.t option) list * t (** Existential quantification. *) | ForAll of (string * Type.t option) list * t - | Constructor of string * t list + | ConstructorApp of string * t list [@@deriving yojson] (** {2: Helpers for building expressions} @@ -1178,7 +1178,8 @@ module Visitors : sig ; visit_Car : 'c -> UnOp.t -> UnOp.t ; visit_Cdr : 'c -> UnOp.t -> UnOp.t ; visit_Constant : 'c -> Literal.t -> Constant.t -> Literal.t - ; visit_Constructor : 'c -> Expr.t -> string -> Expr.t list -> Expr.t + ; visit_ConstructorApp : + 'c -> Expr.t -> string -> Expr.t list -> Expr.t ; visit_ECall : 'c -> 'f Cmd.t -> @@ -1439,7 +1440,9 @@ module Visitors : sig method visit_Car : 'c -> UnOp.t -> UnOp.t method visit_Cdr : 'c -> UnOp.t -> UnOp.t method visit_Constant : 'c -> Literal.t -> Constant.t -> Literal.t - method visit_Constructor : 'c -> Expr.t -> string -> Expr.t list -> Expr.t + + method visit_ConstructorApp : + 'c -> Expr.t -> string -> Expr.t list -> Expr.t method visit_ECall : 'c -> 'f Cmd.t -> string -> Expr.t -> Expr.t list -> 'f option -> 'f Cmd.t @@ -1736,7 +1739,7 @@ module Visitors : sig ; visit_Car : 'c -> 'f ; visit_Cdr : 'c -> 'f ; visit_Constant : 'c -> Constant.t -> 'f - ; visit_Constructor : 'c -> string -> Expr.t list -> 'f + ; visit_ConstructorApp : 'c -> string -> Expr.t list -> 'f ; visit_IDiv : 'c -> 'f ; visit_FDiv : 'c -> 'f ; visit_ECall : @@ -1961,7 +1964,7 @@ module Visitors : sig method visit_Car : 'c -> 'f method visit_Cdr : 'c -> 'f method visit_Constant : 'c -> Constant.t -> 'f - method visit_Constructor : 'c -> string -> Expr.t list -> 'f + method visit_ConstructorApp : 'c -> string -> Expr.t list -> 'f method visit_IDiv : 'c -> 'f method visit_FDiv : 'c -> 'f @@ -2188,7 +2191,7 @@ module Visitors : sig ; visit_Car : 'c -> unit ; visit_Cdr : 'c -> unit ; visit_Constant : 'c -> Constant.t -> unit - ; visit_Constructor : 'c -> string -> Expr.t list -> unit + ; visit_ConstructorApp : 'c -> string -> Expr.t list -> unit ; visit_ECall : 'c -> string -> Expr.t -> Expr.t list -> 'f option -> unit ; visit_EList : 'c -> Expr.t list -> unit @@ -2412,7 +2415,7 @@ module Visitors : sig method visit_Car : 'c -> unit method visit_Cdr : 'c -> unit method visit_Constant : 'c -> Constant.t -> unit - method visit_Constructor : 'c -> string -> Expr.t list -> unit + method visit_ConstructorApp : 'c -> string -> Expr.t list -> unit method visit_ECall : 'c -> string -> Expr.t -> Expr.t list -> 'f option -> unit diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index c7534681..51b775fb 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -153,7 +153,7 @@ and expr = | ESet of expr list | Exists of (string * typ option) list * expr | ForAll of (string * typ option) list * expr - | Constructor of string * expr list + | ConstructorApp of string * expr list and assertion_atom = | Emp diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index f24d6c3b..a733e041 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -140,7 +140,7 @@ let rec missing_expr (kb : KB.t) (e : Expr.t) : KB.t list = (* The remaining cases proceed recursively *) | UnOp (_, e) -> f e | BinOp (e1, _, e2) -> join [ e1; e2 ] - | NOp (_, le) | EList le | ESet le | Constructor (_, le) -> join le + | NOp (_, le) | EList le | ESet le | ConstructorApp (_, le) -> join le | LstSub (e1, e2, e3) -> let result = join [ e1; e2; e3 ] in L.verbose (fun fmt -> @@ -171,7 +171,7 @@ let rec learn_expr let f = learn_expr kb in match e with (* TODO: Constructors aren't invertible unless we have destructors *) - | Constructor _ -> [] + | ConstructorApp _ -> [] (* Literals, abstract locations, sublists, and sets are never invertible *) | Lit _ | LstSub _ | ESet _ -> [] (* Nothing is learned if the top-level expr is a program or a logical variable *) @@ -450,7 +450,7 @@ let rec simple_ins_formula (kb : KB.t) (pf : Expr.t) : KB.t list = | NOp _ | EList _ | ESet _ - | Constructor _ -> [] + | ConstructorApp _ -> [] (** [ins_outs_formula kb pf] returns a list of possible ins-outs pairs for a given formula [pf] under a given knowledge base [kb] *) diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index f81f39ca..2ba69e8f 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -101,7 +101,7 @@ module Make (SPState : PState.S) = struct let result : Expr.t = match (le : Expr.t) with - | Constructor (n, les) -> Constructor (n, List.map f les) + | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) | Lit _ -> le | LVar lvar -> Option.value ~default:(Expr.LVar lvar) (SESubst.get subst le) @@ -178,7 +178,7 @@ module Make (SPState : PState.S) = struct | Exists _ | ForAll _ -> Lit (Type BooleanType) | EList _ | LstSub _ | NOp (LstCat, _) -> Lit (Type ListType) | NOp (_, _) | ESet _ -> Lit (Type SetType) - | Constructor (n, _) as c -> ( + | ConstructorApp (n, _) as c -> ( match Datatype_env.get_constructor_type n with | Some t -> Lit (Type t) | None -> UnOp (TypeOf, c))) diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index 6c5eab63..c0862f35 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -136,7 +136,7 @@ let rec normalise_list_expressions (le : Expr.t) : Expr.t = | LstSub (le1, le2, le3) -> LstSub (f le1, f le2, f le3) | Exists (bt, le) -> Exists (bt, f le) | ForAll (bt, le) -> ForAll (bt, f le) - | Constructor (n, les) -> Constructor (n, List.map f les) + | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) (* | LstSub(le1, le2, le3) -> (match f le1, f le2, f le3 with @@ -906,7 +906,7 @@ and reduce_lexpr_loop (* ------------------------- Constructors ------------------------- *) - | Constructor (n, les) -> Constructor (n, List.map f les) + | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) (* ------------------------- ForAll + Exists ------------------------- *) @@ -1787,14 +1787,14 @@ and reduce_lexpr_loop | BinOp (UnOp (TypeOf, BinOp (_, SetMem, _)), Equal, Lit (Type t)) when t <> BooleanType -> Expr.false_ (* BinOps: Equalities (Constructors) *) - | BinOp (Constructor (ln, lles), Equal, Constructor (rn, rles)) -> + | BinOp (ConstructorApp (ln, lles), Equal, ConstructorApp (rn, rles)) -> if ln = rn && List.length lles = List.length rles then Expr.conjunct (List.map2 (fun le re -> Expr.BinOp (le, Equal, re)) lles rles) else Expr.false_ - | BinOp (Constructor _, Equal, rle) as le -> ( + | BinOp (ConstructorApp _, Equal, rle) as le -> ( match rle with - | LVar _ | Constructor _ -> le + | LVar _ | ConstructorApp _ -> le | _ -> Expr.false_) (* BinOps: Logic *) | BinOp (Lit (Bool true), And, e) diff --git a/GillianCore/engine/FOLogic/smt.ml b/GillianCore/engine/FOLogic/smt.ml index 2b6a7106..13abde44 100644 --- a/GillianCore/engine/FOLogic/smt.ml +++ b/GillianCore/engine/FOLogic/smt.ml @@ -947,7 +947,7 @@ let rec encode_logical_expression | ForAll (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression ~mk_quant:forall ~gamma ~llen_lvars ~list_elem_vars bt e - | Constructor (name, les) -> ( + | ConstructorApp (name, les) -> ( let param_typs = Datatype_env.get_constructor_field_types name in match param_typs with | Some param_typs -> diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index 839562a0..f833315d 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -153,7 +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 - | Constructor (n, les) -> + | ConstructorApp (n, les) -> if Datatype_env.is_initialised () then let field_types = Datatype_env.get_constructor_field_types n in let check_field le tt = @@ -518,7 +518,7 @@ module Type_lexpr = struct let all_typable = typable_list ?target_type:(Some ListType) les in if all_typable then (Some ListType, true) else def_neg | LstSub (le1, le2, le3) -> type_lstsub gamma le1 le2 le3 - | Constructor (n, les) -> type_constructor gamma n les + | ConstructorApp (n, les) -> type_constructor gamma n les in result diff --git a/GillianCore/engine/concrete_semantics/CExprEval.ml b/GillianCore/engine/concrete_semantics/CExprEval.ml index 054b0adf..cdda0927 100644 --- a/GillianCore/engine/concrete_semantics/CExprEval.ml +++ b/GillianCore/engine/concrete_semantics/CExprEval.ml @@ -330,7 +330,7 @@ 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 _ | ForAll _ | Constructor _ -> + | ALoc _ | LVar _ | ESet _ | Exists _ | ForAll _ | ConstructorApp _ -> raise (Exceptions.Impossible "eval_expr concrete: aloc, lvar, set, exists, for all or \ diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index a909e587..9cdfe3ff 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -254,7 +254,7 @@ module Make (SMemory : SMemory.S) : | Exists (bt, e) -> Exists (bt, f e) | ForAll (bt, e) -> ForAll (bt, f e) | Lit _ | LVar _ | ALoc _ -> expr - | Constructor (n, les) -> Constructor (n, List.map f les) + | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) in (* Perform reduction *) if no_reduce then result diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index 9d89f843..9d65cde9 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -238,7 +238,9 @@ let rec compile_lexpr ?(proc_name = "main") (lexpr : WLExpr.t) : let gvars, asrtsl, comp_exprs = list_split_3 (List.map compile_lexpr l) in - (List.concat gvars, List.concat asrtsl, Expr.Constructor (n, comp_exprs)) + ( List.concat gvars, + List.concat asrtsl, + Expr.ConstructorApp (n, comp_exprs) ) | LFuncApp (_, _) -> failwith "TODO") (* TODO: compile_lformula should return also the list of created existentials *) From 54e98aedf1baa24b0b374a11963373776e12a9f6 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Sun, 27 Apr 2025 14:03:53 +0100 Subject: [PATCH 27/37] Added functions and function calls to GIL AST --- Gillian-C/lib/gilgen.ml | 1 + Gillian-JS/lib/Compiler/JSIL2GIL.ml | 3 +- GillianCore/GIL_Syntax/Expr.ml | 9 ++++-- GillianCore/GIL_Syntax/Func.ml | 8 ++++++ GillianCore/GIL_Syntax/Gil_syntax.ml | 1 + GillianCore/GIL_Syntax/Gil_syntax.mli | 28 +++++++++++++++++++ GillianCore/GIL_Syntax/Prog.ml | 7 +++-- GillianCore/GIL_Syntax/TypeDef__.ml | 10 +++++++ GillianCore/engine/Abstraction/MP.ml | 3 ++ GillianCore/engine/Abstraction/Normaliser.ml | 2 ++ GillianCore/engine/FOLogic/Reduction.ml | 2 ++ GillianCore/engine/FOLogic/smt.ml | 1 + GillianCore/engine/FOLogic/typing.ml | 2 ++ .../engine/concrete_semantics/CExprEval.ml | 12 ++++++-- .../engine/symbolic_semantics/SState.ml | 1 + GillianCore/gil_parser/gil_parsing.ml | 1 + wisl/lib/ParserAndCompiler/wisl2Gil.ml | 2 +- 17 files changed, 83 insertions(+), 10 deletions(-) create mode 100644 GillianCore/GIL_Syntax/Func.ml diff --git a/Gillian-C/lib/gilgen.ml b/Gillian-C/lib/gilgen.ml index cfa382d4..1f053e66 100644 --- a/Gillian-C/lib/gilgen.ml +++ b/Gillian-C/lib/gilgen.ml @@ -1061,6 +1061,7 @@ let trans_program imports = []; lemmas = Hashtbl.create 1; preds = Hashtbl.create 1; + funcs = Hashtbl.create 1; datatypes = Hashtbl.create 1; only_specs = Hashtbl.create 1; macros = Hashtbl.create 1; diff --git a/Gillian-JS/lib/Compiler/JSIL2GIL.ml b/Gillian-JS/lib/Compiler/JSIL2GIL.ml index 339bcd52..9bbb3b28 100644 --- a/Gillian-JS/lib/Compiler/JSIL2GIL.ml +++ b/Gillian-JS/lib/Compiler/JSIL2GIL.ml @@ -503,7 +503,8 @@ let jsil2core_prog (prog : EProg.t) : ('a, string) GProg.t = ~macros:(translate_tbl prog.macros jsil2gil_macro) ~bi_specs:(translate_tbl prog.bi_specs jsil2gil_bispec) ~proc_names:prog.proc_names ~predecessors:(Hashtbl.create 1) - ~datatypes:(Hashtbl.create 1) (* TODO *) + ~datatypes:(Hashtbl.create 1) + ~funcs:(Hashtbl.create 1) (* TODO *) () in result diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index e656c64f..6e3e1786 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -17,6 +17,7 @@ type t = TypeDef__.expr = | ForAll of (string * Type.t option) list * t (** Universal quantification. *) | ConstructorApp of string * t list (** Datatype constructor *) + | FuncApp of string * t list (** Function application *) [@@deriving eq, ord] let to_yojson = TypeDef__.expr_to_yojson @@ -380,6 +381,7 @@ let rec map_opt | _ -> None) | ConstructorApp (n, les) -> aux les (fun les -> ConstructorApp (n, les)) + | FuncApp (n, les) -> aux les (fun les -> FuncApp (n, les)) in Option.map f_after mapped_expr @@ -418,7 +420,8 @@ let rec pp fmt e = (Fmt.list ~sep:Fmt.comma pp_var_with_type) bt pp e | ConstructorApp (n, ll) -> - Fmt.pf fmt "%s(%a)" n (Fmt.list ~sep:Fmt.comma pp) ll + Fmt.pf fmt "'%s(%a)" n (Fmt.list ~sep:Fmt.comma pp) ll + | FuncApp (n, ll) -> Fmt.pf fmt "%s(%a)" n (Fmt.list ~sep:Fmt.comma pp) ll let rec full_pp fmt e = match e with @@ -481,8 +484,8 @@ let rec is_concrete (le : t) : bool = | BinOp (e1, _, e2) -> loop [ e1; e2 ] | LstSub (e1, e2, e3) -> loop [ e1; e2; e3 ] | NOp (_, les) | EList les | ESet les -> loop les - | ConstructorApp (_, _) -> false -(* TODO: Pretty sure constructors are not concrete, but double check *) + | ConstructorApp (_, _) | FuncApp _ -> false +(* TODO: Pretty sure constructors / func app are not concrete, but double check *) let is_concrete_zero_i : t -> bool = function | Lit (Int z) -> Z.equal Z.zero z diff --git a/GillianCore/GIL_Syntax/Func.ml b/GillianCore/GIL_Syntax/Func.ml new file mode 100644 index 00000000..70db2b3e --- /dev/null +++ b/GillianCore/GIL_Syntax/Func.ml @@ -0,0 +1,8 @@ +type t = TypeDef__.func = { + func_name : string; + func_source_path : string option; + func_loc : Location.t option; + func_num_params : int; + func_params : (string * Type.t option) list; + func_definition : Expr.t; +} diff --git a/GillianCore/GIL_Syntax/Gil_syntax.ml b/GillianCore/GIL_Syntax/Gil_syntax.ml index 8a181d34..06d8ece8 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.ml +++ b/GillianCore/GIL_Syntax/Gil_syntax.ml @@ -9,6 +9,7 @@ module Constant = Constant module Constructor = Constructor module Datatype = Datatype module Expr = Expr +module Func = Func module Flag = Flag module LCmd = LCmd module Lemma = Lemma diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index f76a2ace..0eed802e 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -252,6 +252,7 @@ module Expr : sig (** Existential quantification. *) | ForAll of (string * Type.t option) list * t | ConstructorApp of string * t list + | FuncApp of string * t list [@@deriving yojson] (** {2: Helpers for building expressions} @@ -734,6 +735,17 @@ module Datatype : sig [@@deriving yojson] end +module Func : sig + type t = { + func_name : string; + func_source_path : string option; + func_loc : Location.t option; + func_num_params : int; + func_params : (string * Type.t option) list; + func_definition : Expr.t; + } +end + module Constructor : sig type t = TypeDef__.constructor = { constructor_name : string; @@ -975,6 +987,7 @@ module Prog : sig (** List of imported GIL files, and whether each has to be verified *) lemmas : (string, Lemma.t) Hashtbl.t; (** Lemmas *) preds : (string, Pred.t) Hashtbl.t; (** Predicates *) + funcs : (string, Func.t) Hashtbl.t; (** Predicates *) datatypes : (string, Datatype.t) Hashtbl.t; only_specs : (string, Spec.t) Hashtbl.t; (** Specs without function definitions *) @@ -991,6 +1004,7 @@ module Prog : sig imports:(string * bool) list -> lemmas:(string, Lemma.t) Hashtbl.t -> preds:(string, Pred.t) Hashtbl.t -> + funcs:(string, Func.t) Hashtbl.t -> datatypes:(string, Datatype.t) Hashtbl.t -> only_specs:(string, Spec.t) Hashtbl.t -> procs:(string, ('annot, 'label) Proc.t) Hashtbl.t -> @@ -1007,6 +1021,7 @@ module Prog : sig imports:(string * bool) list -> lemmas:(string, Lemma.t) Hashtbl.t -> preds:(string, Pred.t) Hashtbl.t -> + funcs:(string, Func.t) Hashtbl.t -> datatypes:(string, Datatype.t) Hashtbl.t -> only_specs:(string, Spec.t) Hashtbl.t -> macros:(string, Macro.t) Hashtbl.t -> @@ -1021,6 +1036,7 @@ module Prog : sig predecessors:(string * int * int * int) list -> lemmas:(string, Lemma.t) Hashtbl.t -> preds:(string, Pred.t) Hashtbl.t -> + funcs:(string, Func.t) Hashtbl.t -> datatypes:(string, Datatype.t) Hashtbl.t -> only_specs:(string, Spec.t) Hashtbl.t -> macros:(string, Macro.t) Hashtbl.t -> @@ -1205,6 +1221,7 @@ module Visitors : sig ; visit_FMod : 'c -> BinOp.t -> BinOp.t ; visit_ForAll : 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t + ; visit_FuncApp : 'c -> Expr.t -> string -> Expr.t list -> Expr.t ; visit_FPlus : 'c -> BinOp.t -> BinOp.t ; visit_FTimes : 'c -> BinOp.t -> BinOp.t ; visit_FUnaryMinus : 'c -> UnOp.t -> UnOp.t @@ -1379,6 +1396,7 @@ module Visitors : sig ; visit_datatype : 'c -> Datatype.t -> Datatype.t ; visit_expr : 'c -> Expr.t -> Expr.t ; visit_flag : 'c -> Flag.t -> Flag.t + ; visit_func : 'c -> Func.t -> Func.t ; visit_lcmd : 'c -> LCmd.t -> LCmd.t ; visit_lemma : 'c -> Lemma.t -> Lemma.t ; visit_lemma_spec : 'c -> Lemma.spec -> Lemma.spec @@ -1464,6 +1482,7 @@ module Visitors : sig method visit_FLessThanEqual : 'c -> BinOp.t -> BinOp.t method visit_FMinus : 'c -> BinOp.t -> BinOp.t method visit_FMod : 'c -> BinOp.t -> BinOp.t + method visit_FuncApp : 'c -> Expr.t -> string -> Expr.t list -> Expr.t method visit_FPlus : 'c -> BinOp.t -> BinOp.t method visit_FTimes : 'c -> BinOp.t -> BinOp.t method visit_FUnaryMinus : 'c -> UnOp.t -> UnOp.t @@ -1653,6 +1672,7 @@ module Visitors : sig method visit_datatype : 'c -> Datatype.t -> Datatype.t method visit_expr : 'c -> Expr.t -> Expr.t method visit_flag : 'c -> Flag.t -> Flag.t + method visit_func : 'c -> Func.t -> Func.t method private visit_float : 'env. 'env -> float -> float method private visit_int : 'env. 'env -> int -> int method private visit_int32 : 'env. 'env -> int32 -> int32 @@ -1855,6 +1875,7 @@ module Visitors : sig ; visit_SignedRightShiftF : 'c -> 'f ; visit_Skip : 'c -> 'f ; visit_FreshSVar : 'c -> string -> 'f + ; visit_FuncApp : 'c -> string -> Expr.t list -> 'f ; visit_StrCat : 'c -> 'f ; visit_StrLen : 'c -> 'f ; visit_StrLess : 'c -> 'f @@ -1908,6 +1929,7 @@ module Visitors : sig ; visit_datatype : 'c -> Datatype.t -> 'f ; visit_expr : 'c -> Expr.t -> 'f ; visit_flag : 'c -> Flag.t -> 'f + ; visit_func : 'c -> Func.t -> 'f ; visit_lcmd : 'c -> LCmd.t -> 'f ; visit_lemma : 'c -> Lemma.t -> 'f ; visit_lemma_spec : 'c -> Lemma.spec -> 'f @@ -2084,6 +2106,7 @@ module Visitors : sig method visit_SignedRightShiftF : 'c -> 'f method visit_Skip : 'c -> 'f method visit_FreshSVar : 'c -> string -> 'f + method visit_FuncApp : 'c -> string -> Expr.t list -> 'f method visit_StrCat : 'c -> 'f method visit_StrLen : 'c -> 'f method visit_StrLess : 'c -> 'f @@ -2135,6 +2158,7 @@ module Visitors : sig method visit_datatype : 'c -> Datatype.t -> 'f method visit_expr : 'c -> Expr.t -> 'f method visit_flag : 'c -> Flag.t -> 'f + method visit_func : 'c -> Func.t -> 'f method visit_lcmd : 'c -> LCmd.t -> 'f method visit_lemma : 'c -> Lemma.t -> 'f method visit_lemma_spec : 'c -> Lemma.spec -> 'f @@ -2312,6 +2336,7 @@ module Visitors : sig ; visit_SignedRightShiftF : 'c -> unit ; visit_Skip : 'c -> unit ; visit_FreshSVar : 'c -> string -> unit + ; visit_FuncApp : 'c -> string -> Expr.t list -> unit ; visit_StrCat : 'c -> unit ; visit_StrLen : 'c -> unit ; visit_StrLess : 'c -> unit @@ -2360,6 +2385,7 @@ module Visitors : sig ; visit_datatype : 'c -> Datatype.t -> unit ; visit_expr : 'c -> Expr.t -> unit ; visit_flag : 'c -> Flag.t -> unit + ; visit_func : 'c -> Func.t -> unit ; visit_lcmd : 'c -> LCmd.t -> unit ; visit_lemma : 'c -> Lemma.t -> unit ; visit_lemma_spec : 'c -> Lemma.spec -> unit @@ -2542,6 +2568,7 @@ module Visitors : sig method visit_SignedRightShiftF : 'c -> unit method visit_Skip : 'c -> unit method visit_FreshSVar : 'c -> string -> unit + method visit_FuncApp : 'c -> string -> Expr.t list -> unit method visit_StrCat : 'c -> unit method visit_StrLen : 'c -> unit method visit_StrLess : 'c -> unit @@ -2600,6 +2627,7 @@ module Visitors : sig method visit_datatype : 'c -> Datatype.t -> unit method visit_expr : 'c -> Expr.t -> unit method visit_flag : 'c -> Flag.t -> unit + method visit_func : 'c -> Func.t -> unit method private visit_float : 'env. 'env -> float -> unit method private visit_int : 'env. 'env -> int -> unit method private visit_int32 : 'env. 'env -> int32 -> unit diff --git a/GillianCore/GIL_Syntax/Prog.ml b/GillianCore/GIL_Syntax/Prog.ml index 9acc18e9..8362c0ae 100644 --- a/GillianCore/GIL_Syntax/Prog.ml +++ b/GillianCore/GIL_Syntax/Prog.ml @@ -7,6 +7,7 @@ type ('annot, 'label) t = { (* Lemmas *) preds : (string, Pred.t) Hashtbl.t; (* Predicates = Name : String --> Definition *) + funcs : (string, Func.t) Hashtbl.t; datatypes : (string, Datatype.t) Hashtbl.t; only_specs : (string, Spec.t) Hashtbl.t; (* Specs = Name : String --> Spec *) @@ -24,6 +25,7 @@ let make ~imports ~lemmas ~preds + ~funcs ~datatypes ~only_specs ~procs @@ -36,6 +38,7 @@ let make imports; lemmas; preds; + funcs; datatypes; only_specs; procs; @@ -69,8 +72,8 @@ let create () = make_labeled ~imports:[] ~lemmas:(Hashtbl.create medium_tbl_size) ~preds:(Hashtbl.create big_tbl_size) - ~datatypes:(Hashtbl.create small_tbl_size) - (* TODO: What table size to use for datatypes*) + ~funcs:(Hashtbl.create medium_tbl_size) + ~datatypes:(Hashtbl.create medium_tbl_size) ~only_specs:(Hashtbl.create medium_tbl_size) ~procs:(Hashtbl.create big_tbl_size) ~macros:(Hashtbl.create small_tbl_size) diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index 51b775fb..8c9aeeb9 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -154,6 +154,7 @@ and expr = | Exists of (string * typ option) list * expr | ForAll of (string * typ option) list * expr | ConstructorApp of string * expr list + | FuncApp of string * expr list and assertion_atom = | Emp @@ -248,6 +249,15 @@ and datatype = { datatype_constructors : constructor list; } +and func = { + func_name : string; + func_source_path : string option; + func_loc : location option; + func_num_params : int; + func_params : (string * typ option) list; + func_definition : expr; +} + and constructor = { constructor_name : string; constructor_source_path : string option; diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index a733e041..ffd33cdd 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -140,6 +140,7 @@ let rec missing_expr (kb : KB.t) (e : Expr.t) : KB.t list = (* The remaining cases proceed recursively *) | UnOp (_, e) -> f e | BinOp (e1, _, e2) -> join [ e1; e2 ] + | FuncApp _ -> failwith "TODO" | NOp (_, le) | EList le | ESet le | ConstructorApp (_, le) -> join le | LstSub (e1, e2, e3) -> let result = join [ e1; e2; e3 ] in @@ -170,6 +171,7 @@ let rec learn_expr (e : Expr.t) : outs = let f = learn_expr kb in match e with + | FuncApp _ -> failwith "TODO" (* TODO: Constructors aren't invertible unless we have destructors *) | ConstructorApp _ -> [] (* Literals, abstract locations, sublists, and sets are never invertible *) @@ -451,6 +453,7 @@ let rec simple_ins_formula (kb : KB.t) (pf : Expr.t) : KB.t list = | EList _ | ESet _ | ConstructorApp _ -> [] + | FuncApp _ -> failwith "TODO" (** [ins_outs_formula kb pf] returns a list of possible ins-outs pairs for a given formula [pf] under a given knowledge base [kb] *) diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 2ba69e8f..90f4ba18 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -101,6 +101,7 @@ module Make (SPState : PState.S) = struct let result : Expr.t = match (le : Expr.t) with + | FuncApp _ -> failwith "TODO" | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) | Lit _ -> le | LVar lvar -> @@ -178,6 +179,7 @@ module Make (SPState : PState.S) = struct | Exists _ | ForAll _ -> Lit (Type BooleanType) | EList _ | LstSub _ | NOp (LstCat, _) -> Lit (Type ListType) | NOp (_, _) | ESet _ -> Lit (Type SetType) + | FuncApp _ -> failwith "TODO" | ConstructorApp (n, _) as c -> ( match Datatype_env.get_constructor_type n with | Some t -> Lit (Type t) diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index c0862f35..191af514 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -137,6 +137,7 @@ let rec normalise_list_expressions (le : Expr.t) : Expr.t = | Exists (bt, le) -> Exists (bt, f le) | ForAll (bt, le) -> ForAll (bt, f le) | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) + | FuncApp _ -> failwith "TODO" (* | LstSub(le1, le2, le3) -> (match f le1, f le2, f le3 with @@ -907,6 +908,7 @@ and reduce_lexpr_loop Constructors ------------------------- *) | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) + | FuncApp _ -> failwith "TODO" (* ------------------------- ForAll + Exists ------------------------- *) diff --git a/GillianCore/engine/FOLogic/smt.ml b/GillianCore/engine/FOLogic/smt.ml index 13abde44..8f09dffa 100644 --- a/GillianCore/engine/FOLogic/smt.ml +++ b/GillianCore/engine/FOLogic/smt.ml @@ -947,6 +947,7 @@ let rec encode_logical_expression | ForAll (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression ~mk_quant:forall ~gamma ~llen_lvars ~list_elem_vars bt e + | FuncApp _ -> failwith "TODO" | ConstructorApp (name, les) -> ( let param_typs = Datatype_env.get_constructor_field_types name in match param_typs with diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index f833315d..2d40f6db 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -171,6 +171,7 @@ module Infer_types_to_gamma = struct else (* Can't say for certain whether or not the constructor is typable *) true + | FuncApp _ -> failwith "TODO" | Exists (bt, le) | ForAll (bt, le) -> if not (tt = BooleanType) then false else @@ -519,6 +520,7 @@ module Type_lexpr = struct if all_typable then (Some ListType, true) else def_neg | LstSub (le1, le2, le3) -> type_lstsub gamma le1 le2 le3 | ConstructorApp (n, les) -> type_constructor gamma n les + | FuncApp _ -> failwith "TODO" in result diff --git a/GillianCore/engine/concrete_semantics/CExprEval.ml b/GillianCore/engine/concrete_semantics/CExprEval.ml index cdda0927..94c2c952 100644 --- a/GillianCore/engine/concrete_semantics/CExprEval.ml +++ b/GillianCore/engine/concrete_semantics/CExprEval.ml @@ -330,11 +330,17 @@ 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 _ | ForAll _ | ConstructorApp _ -> + | ALoc _ + | LVar _ + | ESet _ + | Exists _ + | ForAll _ + | ConstructorApp _ + | FuncApp _ -> raise (Exceptions.Impossible - "eval_expr concrete: aloc, lvar, set, exists, for all or \ - constructor") + "eval_expr concrete: aloc, lvar, set, exists, for all, \ + constructor or function application") with | TypeError msg -> raise (TypeError (msg ^ Fmt.str " in %a" Expr.pp e)) | EvaluationError msg -> diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index 9cdfe3ff..006015ee 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -255,6 +255,7 @@ module Make (SMemory : SMemory.S) : | ForAll (bt, e) -> ForAll (bt, f e) | Lit _ | LVar _ | ALoc _ -> expr | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) + | FuncApp _ -> failwith "TODO" in (* Perform reduction *) if no_reduce then result diff --git a/GillianCore/gil_parser/gil_parsing.ml b/GillianCore/gil_parser/gil_parsing.ml index 1f891eb4..748c00b3 100644 --- a/GillianCore/gil_parser/gil_parsing.ml +++ b/GillianCore/gil_parser/gil_parsing.ml @@ -294,6 +294,7 @@ module Make (Annot : Annot.S) = struct in Prog.make_indexed ~lemmas:ext_program.lemmas ~preds:ext_program.preds ~only_specs:ext_program.only_specs ~procs ~predecessors + ~funcs:(Hashtbl.create 1) (* TODO *) ~macros:ext_program.macros ~bi_specs:ext_program.bi_specs ~datatypes:ext_program.datatypes () diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index 9d65cde9..ee084293 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -1243,4 +1243,4 @@ let compile ~filepath WProg.{ context; predicates; lemmas; datatypes; _ } = ~lemmas:gil_lemmas ~preds:gil_preds ~procs:gil_procs ~proc_names ~bi_specs ~only_specs:(Hashtbl.create 1) ~macros:(Hashtbl.create 1) ~predecessors:(Hashtbl.create 1) () (* TODO *) - ~datatypes:gil_datatypes + ~datatypes:gil_datatypes ~funcs:(Hashtbl.create 1) From 9a4995a6c8c1ed58b64e42013182aed6b1c93622 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Mon, 28 Apr 2025 17:27:39 +0100 Subject: [PATCH 28/37] Compilation of WISL logical functions. --- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 35 +++++++++++++++++++++++--- wisl/lib/syntax/WType.ml | 19 ++++++++++++++ wisl/lib/syntax/WType.mli | 2 ++ 3 files changed, 53 insertions(+), 3 deletions(-) diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index ee084293..b5903f7f 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -241,7 +241,11 @@ let rec compile_lexpr ?(proc_name = "main") (lexpr : WLExpr.t) : ( List.concat gvars, List.concat asrtsl, Expr.ConstructorApp (n, comp_exprs) ) - | LFuncApp (_, _) -> failwith "TODO") + | LFuncApp (n, l) -> + let gvars, asrtsl, comp_exprs = + list_split_3 (List.map compile_lexpr l) + in + (List.concat gvars, List.concat asrtsl, Expr.FuncApp (n, comp_exprs))) (* TODO: compile_lformula should return also the list of created existentials *) let rec compile_lformula ?(proc_name = "main") formula : Asrt.t * Expr.t = @@ -987,6 +991,26 @@ let compile_pred filepath pred = pred_nounfold = pred.pred_nounfold; } +let compile_func + filepath + WFunc.{ func_name; func_params; func_definition; func_loc } = + let types = WType.infer_types_func func_params func_definition in + let get_wisl_type x = (x, WType.of_variable x types) in + let param_wisl_types = List.map (fun (x, _) -> get_wisl_type x) func_params in + let get_gil_type (x, t) = (x, Option.join (Option.map compile_type t)) in + let comp_func_params = List.map get_gil_type param_wisl_types in + let _, _, comp_func_def = compile_lexpr func_definition in + let comp_func_loc = Some (CodeLoc.to_location func_loc) in + Func. + { + func_name; + func_source_path = Some filepath; + func_loc = comp_func_loc; + func_num_params = List.length comp_func_params; + func_params = comp_func_params; + func_definition = comp_func_def; + } + let rec compile_proc filepath WProc.{ name; params; body; spec; return_expr; is_loop_body; _ } = @@ -1188,7 +1212,9 @@ let compile_datatype datatype_constructors = comp_constructors; } -let compile ~filepath WProg.{ context; predicates; lemmas; datatypes; _ } = +let compile + ~filepath + WProg.{ context; predicates; lemmas; datatypes; functions } = (* stuff useful to build hashtables *) let make_hashtbl get_name deflist = let hashtbl = Hashtbl.create (List.length deflist) in @@ -1200,6 +1226,7 @@ let compile ~filepath WProg.{ context; predicates; lemmas; datatypes; _ } = let get_proc_name proc = proc.Proc.proc_name in let get_pred_name pred = pred.Pred.pred_name in let get_lemma_name lemma = lemma.Lemma.lemma_name in + let get_func_name func = func.Func.func_name in let get_datatype_name datatype = datatype.Datatype.datatype_name in (* compile everything *) let comp_context = List.map (compile_proc filepath) context in @@ -1209,11 +1236,13 @@ let compile ~filepath WProg.{ context; predicates; lemmas; datatypes; _ } = (fun lemma -> compile_lemma filepath (preprocess_lemma lemma)) lemmas in + let comp_funcs = List.map (compile_func filepath) functions in let comp_datatypes = List.map (compile_datatype filepath) datatypes in (* build the hashtables *) let gil_procs = make_hashtbl get_proc_name (List.concat comp_context) in let gil_preds = make_hashtbl get_pred_name comp_preds in let gil_lemmas = make_hashtbl get_lemma_name comp_lemmas in + let gil_funcs = make_hashtbl get_func_name comp_funcs in let gil_datatypes = make_hashtbl get_datatype_name comp_datatypes in let proc_names = Hashtbl.fold (fun s _ l -> s :: l) gil_procs [] in let bi_specs = Hashtbl.create 1 in @@ -1243,4 +1272,4 @@ let compile ~filepath WProg.{ context; predicates; lemmas; datatypes; _ } = ~lemmas:gil_lemmas ~preds:gil_preds ~procs:gil_procs ~proc_names ~bi_specs ~only_specs:(Hashtbl.create 1) ~macros:(Hashtbl.create 1) ~predecessors:(Hashtbl.create 1) () (* TODO *) - ~datatypes:gil_datatypes ~funcs:(Hashtbl.create 1) + ~datatypes:gil_datatypes ~funcs:gil_funcs diff --git a/wisl/lib/syntax/WType.ml b/wisl/lib/syntax/WType.ml index 50ec68ef..430cd528 100644 --- a/wisl/lib/syntax/WType.ml +++ b/wisl/lib/syntax/WType.ml @@ -237,3 +237,22 @@ let infer_types_pred (params : (string * t option) list) assert_list = TypeMap.merge join_params_and_asserts infers_on_params infers_on_asserts in result + +let infer_types_func (params : (string * t option) list) func_def = + let join _ param_t inferred_t = + match (param_t, inferred_t) with + | Some param_t, Some inferred_t when param_t = inferred_t -> Some param_t + | Some param_t, None when param_t <> WAny -> Some param_t + | None, Some inferred_t when inferred_t <> WAny -> Some inferred_t + | _ -> None + in + let infers_on_params = + List.fold_left + (fun (map : 'a TypeMap.t) (x, ot) -> + match ot with + | None -> map + | Some t -> TypeMap.add (PVar x) t map) + TypeMap.empty params + in + let infer_on_func_def = infer_logic_expr TypeMap.empty func_def in + TypeMap.merge join infers_on_params infer_on_func_def diff --git a/wisl/lib/syntax/WType.mli b/wisl/lib/syntax/WType.mli index 75704d1d..3c3951b1 100644 --- a/wisl/lib/syntax/WType.mli +++ b/wisl/lib/syntax/WType.mli @@ -25,3 +25,5 @@ val of_variable : string -> t TypeMap.t -> t option val infer_types_pred : (string * t option) list -> WLAssert.t list -> t TypeMap.t + +val infer_types_func : (string * t option) list -> WLExpr.t -> t TypeMap.t From 5ceaff0bb1d6b44235a960f7679dd5a358f030bc Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Tue, 29 Apr 2025 17:25:48 +0100 Subject: [PATCH 29/37] Handling of FuncApp --- GillianCore/engine/Abstraction/MP.ml | 11 +++--- GillianCore/engine/Abstraction/Normaliser.ml | 8 ++-- GillianCore/engine/FOLogic/Reduction.ml | 7 +++- GillianCore/engine/FOLogic/typing.ml | 39 +++++++++++++++++-- .../engine/logical_env/function_env.ml | 14 +++++++ .../engine/logical_env/function_env.mli | 5 +++ .../engine/symbolic_semantics/SState.ml | 2 +- 7 files changed, 70 insertions(+), 16 deletions(-) create mode 100644 GillianCore/engine/logical_env/function_env.ml create mode 100644 GillianCore/engine/logical_env/function_env.mli diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index ffd33cdd..34555780 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -140,8 +140,8 @@ let rec missing_expr (kb : KB.t) (e : Expr.t) : KB.t list = (* The remaining cases proceed recursively *) | UnOp (_, e) -> f e | BinOp (e1, _, e2) -> join [ e1; e2 ] - | FuncApp _ -> failwith "TODO" - | NOp (_, le) | EList le | ESet le | ConstructorApp (_, le) -> join le + | NOp (_, le) | EList le | ESet le | ConstructorApp (_, le) | FuncApp (_, le) + -> join le | LstSub (e1, e2, e3) -> let result = join [ e1; e2; e3 ] in L.verbose (fun fmt -> @@ -171,9 +171,6 @@ let rec learn_expr (e : Expr.t) : outs = let f = learn_expr kb in match e with - | FuncApp _ -> failwith "TODO" - (* TODO: Constructors aren't invertible unless we have destructors *) - | ConstructorApp _ -> [] (* Literals, abstract locations, sublists, and sets are never invertible *) | Lit _ | LstSub _ | ESet _ -> [] (* Nothing is learned if the top-level expr is a program or a logical variable *) @@ -291,6 +288,10 @@ let rec learn_expr | BinOp _ -> [] (* Can we learn anything from Exists? *) | Exists _ | ForAll _ -> [] + (* TODO: Constructors aren't invertible unless we have destructors *) + | ConstructorApp _ -> [] + (* Function application isn't invertible *) + | FuncApp _ -> [] 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)); *) diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 90f4ba18..fded24d6 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -101,8 +101,6 @@ module Make (SPState : PState.S) = struct let result : Expr.t = match (le : Expr.t) with - | FuncApp _ -> failwith "TODO" - | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) | Lit _ -> le | LVar lvar -> Option.value ~default:(Expr.LVar lvar) (SESubst.get subst le) @@ -175,11 +173,11 @@ module Make (SPState : PState.S) = struct (Exceptions.Impossible "normalise_lexpr: program variable in normalised \ expression") - | BinOp (_, _, _) | UnOp (_, _) -> UnOp (TypeOf, nle1) + | BinOp (_, _, _) | UnOp (_, _) | FuncApp _ -> + UnOp (TypeOf, nle1) | Exists _ | ForAll _ -> Lit (Type BooleanType) | EList _ | LstSub _ | NOp (LstCat, _) -> Lit (Type ListType) | NOp (_, _) | ESet _ -> Lit (Type SetType) - | FuncApp _ -> failwith "TODO" | ConstructorApp (n, _) as c -> ( match Datatype_env.get_constructor_type n with | Some t -> Lit (Type t) @@ -233,6 +231,8 @@ module Make (SPState : PState.S) = struct | _, Exists _ -> Exists (bt, ne) | _, ForAll _ -> ForAll (bt, ne) | _, _ -> failwith "Impossible") + | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) + | FuncApp (n, les) -> FuncApp (n, List.map f les) in if not no_types then Typing.infer_types_expr gamma result; diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index 191af514..79d67444 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -137,7 +137,7 @@ let rec normalise_list_expressions (le : Expr.t) : Expr.t = | Exists (bt, le) -> Exists (bt, f le) | ForAll (bt, le) -> ForAll (bt, f le) | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) - | FuncApp _ -> failwith "TODO" + | FuncApp (n, les) -> FuncApp (n, List.map f les) (* | LstSub(le1, le2, le3) -> (match f le1, f le2, f le3 with @@ -908,7 +908,10 @@ and reduce_lexpr_loop Constructors ------------------------- *) | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) - | FuncApp _ -> failwith "TODO" + (* ------------------------- + Function Application + ------------------------- *) + | FuncApp (n, les) -> FuncApp (n, List.map f les) (* ------------------------- ForAll + Exists ------------------------- *) diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index 2d40f6db..e58d9a40 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -171,7 +171,24 @@ module Infer_types_to_gamma = struct else (* Can't say for certain whether or not the constructor is typable *) true - | FuncApp _ -> failwith "TODO" + | FuncApp (n, les) -> + if Function_env.is_initialised () then + let check_field le tt = + match tt with + | Some tt -> f le tt + | None -> true + in + let param_types = Function_env.get_function_param_types n in + match param_types with + | Some tts -> + if List.length tts <> List.length les then false + else + (* Only check param types, we don't check return type of function *) + List.for_all2 check_field les tts + | None -> false + else + (* Can't say for certain whether or not the constructor is typable *) + true | Exists (bt, le) | ForAll (bt, le) -> if not (tt = BooleanType) then false else @@ -478,10 +495,24 @@ module Type_lexpr = struct let _, ite = f gamma_copy e in if not ite then def_neg else infer_type gamma le BooleanType - and type_constructor gamma n les = + and type_constructor_app gamma n les = if Datatype_env.is_initialised () then let tts_opt = Datatype_env.get_constructor_field_types n in match tts_opt with + | Some tts -> + if typable_list gamma ?target_types:(Some tts) les then + (* TODO: We don't attempt to infer the type of function applications *) + (* How would we handle recursive functions? *) + (* Requires signifcant change to typing algorithm *) + (None, true) + else def_neg + | None -> def_neg + else (None, true) + + and type_func_app gamma n les = + if Function_env.is_initialised () then + let tts_opt = Function_env.get_function_param_types n in + match tts_opt with | Some tts -> if typable_list gamma ?target_types:(Some tts) les then def_pos (Datatype_env.get_constructor_type n) @@ -519,8 +550,8 @@ module Type_lexpr = struct let all_typable = typable_list ?target_type:(Some ListType) les in if all_typable then (Some ListType, true) else def_neg | LstSub (le1, le2, le3) -> type_lstsub gamma le1 le2 le3 - | ConstructorApp (n, les) -> type_constructor gamma n les - | FuncApp _ -> failwith "TODO" + | ConstructorApp (n, les) -> type_constructor_app gamma n les + | FuncApp (n, les) -> type_func_app gamma n les in result diff --git a/GillianCore/engine/logical_env/function_env.ml b/GillianCore/engine/logical_env/function_env.ml new file mode 100644 index 00000000..8cea74c8 --- /dev/null +++ b/GillianCore/engine/logical_env/function_env.ml @@ -0,0 +1,14 @@ +type t = (string, Func.t) Hashtbl.t + +let function_env : t option ref = ref None +let init tbl = function_env := Some tbl +let is_initialised () = Option.is_some !function_env + +let get_function_param_types fname = + let phi = !function_env in + let func = Option.map (fun phi -> Hashtbl.find_opt phi fname) phi in + let param_types = + Option.map (fun f -> f.Func.func_params) (Option.join func) + in + let types = Option.map (List.map snd) param_types in + types diff --git a/GillianCore/engine/logical_env/function_env.mli b/GillianCore/engine/logical_env/function_env.mli new file mode 100644 index 00000000..4b766586 --- /dev/null +++ b/GillianCore/engine/logical_env/function_env.mli @@ -0,0 +1,5 @@ +type t = (string, Func.t) Hashtbl.t + +val init : t -> unit +val is_initialised : unit -> bool +val get_function_param_types : string -> Type.t option list option diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index 006015ee..96e38634 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -255,7 +255,7 @@ module Make (SMemory : SMemory.S) : | ForAll (bt, e) -> ForAll (bt, f e) | Lit _ | LVar _ | ALoc _ -> expr | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) - | FuncApp _ -> failwith "TODO" + | FuncApp (n, les) -> FuncApp (n, List.map f les) in (* Perform reduction *) if no_reduce then result From 0bee009d3ceab5995098b2b12e0e5d306e98eab9 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Wed, 30 Apr 2025 18:33:03 +0100 Subject: [PATCH 30/37] Encoding of functions into SMT --- GillianCore/engine/Abstraction/MP.ml | 4 +- GillianCore/engine/Abstraction/Verifier.ml | 1 + GillianCore/engine/FOLogic/smt.ml | 82 ++++++++++++++++++- .../engine/logical_env/function_env.ml | 5 ++ .../engine/logical_env/function_env.mli | 1 + GillianCore/gil_parser/gil_parsing.ml | 5 +- wisl/examples/function.wisl | 10 +-- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 13 +-- 8 files changed, 103 insertions(+), 18 deletions(-) diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index 34555780..bddd2641 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -453,8 +453,8 @@ let rec simple_ins_formula (kb : KB.t) (pf : Expr.t) : KB.t list = | NOp _ | EList _ | ESet _ - | ConstructorApp _ -> [] - | FuncApp _ -> failwith "TODO" + | ConstructorApp _ + | FuncApp _ -> [] (** [ins_outs_formula kb pf] returns a list of possible ins-outs pairs for a given formula [pf] under a given knowledge base [kb] *) diff --git a/GillianCore/engine/Abstraction/Verifier.ml b/GillianCore/engine/Abstraction/Verifier.ml index 2e416c20..4174a286 100644 --- a/GillianCore/engine/Abstraction/Verifier.ml +++ b/GillianCore/engine/Abstraction/Verifier.ml @@ -941,6 +941,7 @@ struct let open ChangeTracker in (* Prepare datatype env *) let () = Datatype_env.init prog.datatypes in + let () = Function_env.init prog.funcs in let () = Smt.init () in if incremental && prev_results_exist () then ( diff --git a/GillianCore/engine/FOLogic/smt.ml b/GillianCore/engine/FOLogic/smt.ml index 8f09dffa..9761c5db 100644 --- a/GillianCore/engine/FOLogic/smt.ml +++ b/GillianCore/engine/FOLogic/smt.ml @@ -534,6 +534,7 @@ module Encoding = struct accessor (Ext_lit_operations.Gil_sing_elem.access expr) let simply_wrapped = make ~kind:Simple_wrapped + let extended_wrapped = make ~kind:Extended_wrapped (** Takes a value either natively encoded or simply wrapped and returns a value simply wrapped. @@ -947,11 +948,27 @@ let rec encode_logical_expression | ForAll (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression ~mk_quant:forall ~gamma ~llen_lvars ~list_elem_vars bt e - | FuncApp _ -> failwith "TODO" + | FuncApp (name, les) -> ( + let param_typs = Function_env.get_function_param_types name in + match param_typs with + | Some param_typs -> + let extend_wrap_or_native typopt = + match typopt with + | Some typ -> get_native_of_type ~typ + | None -> extend_wrap + in + let>-- args = List.map f les in + let args = List.map2 extend_wrap_or_native param_typs args in + let sexp = app_ name args in + extended_wrapped sexp + | None -> + let msg = "SMT - Undefined function: " ^ name in + raise (Failure msg)) | ConstructorApp (name, les) -> ( let param_typs = Datatype_env.get_constructor_field_types name in match param_typs with | Some param_typs -> + (* TODO: Should we be extend wrapping here? *) let simple_wrap_or_native typopt = match typopt with | Some typ -> get_native_of_type ~typ @@ -1003,7 +1020,8 @@ let lvars_only_in_llen (fs : Expr.Set.t) : SS.t = fs |> Expr.Set.iter (inspector#visit_expr ()); inspector#get_diff -let lvars_as_list_elements (assertions : Expr.Set.t) : SS.t = +let lvars_as_list_elements ?(exclude = SS.empty) (assertions : Expr.Set.t) : + SS.t = let collector = object (self) inherit [_] Visitors.reduce @@ -1044,7 +1062,7 @@ let lvars_as_list_elements (assertions : Expr.Set.t) : SS.t = in Expr.Set.fold (fun f acc -> - let new_lvars = collector#visit_expr (SS.empty, false) f in + let new_lvars = collector#visit_expr (exclude, false) f in SS.union new_lvars acc) assertions SS.empty @@ -1071,6 +1089,63 @@ let encode_assertions (fs : Expr.Set.t) (gamma : Type_env.t) : sexp list = let () = Hashtbl.replace encoding_cache fs encoded in encoded +let defn_funs_rec fs = + let mk_param_type (x, t) = list [ atom x; t ] in + let mk_param_types pts = list (List.map mk_param_type pts) in + let mk_decl (name, param_types, ret_type, _) = + list [ atom name; mk_param_types param_types; ret_type ] + in + + let decls = list (List.map mk_decl fs) in + let defns = list (List.map (fun (_, _, _, d) -> d) fs) in + app_ "define-funs-rec" [ decls; defns ] + +let encode_functions (fs : Func.t list) : sexp list = + let encode_function (f : Func.t) = + let name = f.func_name in + let param_types = + List.map + (fun (x, t) -> + match t with + | Some t -> (x, Encoding.native_sort_of_type t) + | None -> (x, t_gil_ext_literal)) + f.func_params + in + let ret_type = t_gil_ext_literal in + let gamma = Type_env.init () in + let () = + List.iter + (fun (x, t) -> + match t with + | Some t -> Type_env.update gamma x t + | None -> ()) + f.func_params + in + let function_def = Expr.Set.singleton f.func_definition in + let param_names = List.map fst param_types in + let param_names = SS.of_seq (List.to_seq param_names) in + let llen_lvars = lvars_only_in_llen function_def in + (* By excluding params, we ensure they are always encoded as + Extended GIL Literals in the encoded definition. + This allows us to make the assumption that if the type of a + function paramater is not known, then it is t_gil_ext_literal *) + let list_elem_vars = + lvars_as_list_elements ~exclude:param_names function_def + in + Printf.printf "%i" (SS.cardinal list_elem_vars); + let encoded_def = + Encoding.extend_wrap + @@ encode_logical_expression ~gamma ~llen_lvars ~list_elem_vars + f.func_definition + in + (name, param_types, ret_type, encoded_def) + in + [ defn_funs_rec (List.map encode_function fs) ] + +module Function_operations = struct + let init_decls fs = encode_functions fs +end + module Dump = struct let counter = ref 0 @@ -1122,6 +1197,7 @@ let init () = Type_operations.init_decls; Lit_operations.init_decls (Datatype_env.get_datatypes ()); Ext_lit_operations.init_decls; + Function_operations.init_decls (Function_env.get_functions ()); ] in let decls = List.concat init_decls in diff --git a/GillianCore/engine/logical_env/function_env.ml b/GillianCore/engine/logical_env/function_env.ml index 8cea74c8..550692a3 100644 --- a/GillianCore/engine/logical_env/function_env.ml +++ b/GillianCore/engine/logical_env/function_env.ml @@ -12,3 +12,8 @@ let get_function_param_types fname = in let types = Option.map (List.map snd) param_types in types + +let get_functions () = + let phi = !function_env in + Option.value ~default:[] + @@ Option.map (fun phi -> List.of_seq (Hashtbl.to_seq_values phi)) phi diff --git a/GillianCore/engine/logical_env/function_env.mli b/GillianCore/engine/logical_env/function_env.mli index 4b766586..403c84d3 100644 --- a/GillianCore/engine/logical_env/function_env.mli +++ b/GillianCore/engine/logical_env/function_env.mli @@ -3,3 +3,4 @@ type t = (string, Func.t) Hashtbl.t val init : t -> unit val is_initialised : unit -> bool val get_function_param_types : string -> Type.t option list option +val get_functions : unit -> Func.t list diff --git a/GillianCore/gil_parser/gil_parsing.ml b/GillianCore/gil_parser/gil_parsing.ml index 748c00b3..aeac7d36 100644 --- a/GillianCore/gil_parser/gil_parsing.ml +++ b/GillianCore/gil_parser/gil_parsing.ml @@ -294,9 +294,8 @@ module Make (Annot : Annot.S) = struct in Prog.make_indexed ~lemmas:ext_program.lemmas ~preds:ext_program.preds ~only_specs:ext_program.only_specs ~procs ~predecessors - ~funcs:(Hashtbl.create 1) (* TODO *) - ~macros:ext_program.macros ~bi_specs:ext_program.bi_specs - ~datatypes:ext_program.datatypes () + ~funcs:ext_program.funcs ~macros:ext_program.macros + ~bi_specs:ext_program.bi_specs ~datatypes:ext_program.datatypes () let parse_literal lexbuf = parse GIL_Parser.lit_target lexbuf let parse_expression lexbuf = parse GIL_Parser.top_level_expr_target lexbuf diff --git a/wisl/examples/function.wisl b/wisl/examples/function.wisl index 10ae8b6f..d82aae8d 100644 --- a/wisl/examples/function.wisl +++ b/wisl/examples/function.wisl @@ -1,10 +1,10 @@ -function inc(x : Int) { - x + 1 +function double(x : Int) { + x + x } { x == #x } -proc increment(x) { - y := x + 1; +proc times_two(x) { + y := x * 2; return y } -{ ret == inc(#x) } +{ ret == double(#x) } diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index b5903f7f..e1957584 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -149,10 +149,12 @@ let rec compile_expr ?(proc_name = "main") ?(is_loop_prefix = false) expr : (* compile_lexpr : WLExpr.t -> (string list * Asrt.t list * Expr.t) 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 ?(proc_name = "main") (lexpr : WLExpr.t) : - string list * Asrt.t * Expr.t = +let rec compile_lexpr + ?(proc_name = "main") + ?(is_func_body = false) + (lexpr : WLExpr.t) : string list * Asrt.t * Expr.t = let gen_str = Generators.gen_str proc_name in - let compile_lexpr = compile_lexpr ~proc_name in + let compile_lexpr = compile_lexpr ~proc_name ~is_func_body in let expr_pname_of_binop b = WBinOp.( match b with @@ -176,6 +178,7 @@ let rec compile_lexpr ?(proc_name = "main") (lexpr : WLExpr.t) : WLExpr.( match get lexpr with | LVal v -> ([], [], Expr.Lit (compile_val v)) + | PVar x when is_func_body -> ([], [], Expr.LVar x) | PVar x -> ([], [], Expr.PVar x) | LVar x -> ([], [], Expr.LVar x) | LBinOp (e1, WBinOp.NEQ, e2) -> @@ -185,7 +188,7 @@ let rec compile_lexpr ?(proc_name = "main") (lexpr : WLExpr.t) : 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 -> + | LBinOp (e1, b, e2) when is_internal_pred b && not is_func_body -> (* Operator corresponds to pointer arithmetics *) let lout = gen_str sgvar in let internal_pred = expr_pname_of_binop b in @@ -999,7 +1002,7 @@ let compile_func let param_wisl_types = List.map (fun (x, _) -> get_wisl_type x) func_params in let get_gil_type (x, t) = (x, Option.join (Option.map compile_type t)) in let comp_func_params = List.map get_gil_type param_wisl_types in - let _, _, comp_func_def = compile_lexpr func_definition in + let _, _, comp_func_def = compile_lexpr ~is_func_body:true func_definition in let comp_func_loc = Some (CodeLoc.to_location func_loc) in Func. { From 2e13fd095cf327570cb4e920864f68d76e1e59a7 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Wed, 30 Apr 2025 20:53:08 +0100 Subject: [PATCH 31/37] Implemented parsing of case statement in wisl --- GillianCore/engine/FOLogic/smt.ml | 1 - wisl/examples/SLL_adt.wisl | 21 +++++++++++++++++++ wisl/examples/function.wisl | 19 +++++++++++++++++ wisl/lib/ParserAndCompiler/WLexer.mll | 1 + wisl/lib/ParserAndCompiler/WParser.mly | 29 ++++++++++++++++++++++---- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 3 ++- wisl/lib/syntax/WCase.ml | 0 wisl/lib/syntax/WLExpr.ml | 17 +++++++++++++++ wisl/lib/syntax/WLExpr.mli | 2 ++ wisl/lib/syntax/WType.ml | 7 ++++++- 10 files changed, 93 insertions(+), 7 deletions(-) create mode 100644 wisl/lib/syntax/WCase.ml diff --git a/GillianCore/engine/FOLogic/smt.ml b/GillianCore/engine/FOLogic/smt.ml index 9761c5db..94109646 100644 --- a/GillianCore/engine/FOLogic/smt.ml +++ b/GillianCore/engine/FOLogic/smt.ml @@ -1132,7 +1132,6 @@ let encode_functions (fs : Func.t list) : sexp list = let list_elem_vars = lvars_as_list_elements ~exclude:param_names function_def in - Printf.printf "%i" (SS.cardinal list_elem_vars); let encoded_def = Encoding.extend_wrap @@ encode_logical_expression ~gamma ~llen_lvars ~list_elem_vars diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl index 0756982d..14cf91a5 100644 --- a/wisl/examples/SLL_adt.wisl +++ b/wisl/examples/SLL_adt.wisl @@ -3,6 +3,13 @@ datatype MyList { Cons(Any, MyList) } +function append(xs : MyList, x) { + case xs { + Nil -> 'Cons(x, 'Nil); + Cons(y, ys) -> 'Cons(y, append(ys, x)) + } +} + // // Standard over-approximating sll predicate with contents @@ -47,6 +54,20 @@ proc sll_prepend(x, k){ } { sll(ret, 'Cons(#k, #vs)) } +// 02. Appending a given value to a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #vs) } +proc SLL_append(x, k){ + if (x = null) { + x := SLL_allocate_node(k) + } else { + t := [x + 1]; + z := SLL_append(t, k); + [x + 1] := z + }; + return x +} +{ SLL(ret, append(#vs, #k)) } + // 05. Copying a given sll { (x == #x) * sll(#x, #vs) } proc sll_copy(x){ diff --git a/wisl/examples/function.wisl b/wisl/examples/function.wisl index d82aae8d..b2fff70d 100644 --- a/wisl/examples/function.wisl +++ b/wisl/examples/function.wisl @@ -2,9 +2,28 @@ function double(x : Int) { x + x } +function triple(x : Int) { + x + x + x +} + { x == #x } proc times_two(x) { y := x * 2; return y } { ret == double(#x) } + +{ x == #x } +proc times_three(x) { + y := x * 3; + return y +} +{ ret == triple(#x) } + +// This spec fails to verify +{ x == #x } +proc times_four(x) { + y := x * 4; + return y +} +{ ret == triple(#x) } diff --git a/wisl/lib/ParserAndCompiler/WLexer.mll b/wisl/lib/ParserAndCompiler/WLexer.mll index ad3c7932..61ded0d6 100644 --- a/wisl/lib/ParserAndCompiler/WLexer.mll +++ b/wisl/lib/ParserAndCompiler/WLexer.mll @@ -56,6 +56,7 @@ rule read = | "lemma" { LEMMA (curr lexbuf) } | "forall" { FORALL (curr lexbuf) } | "bind" { EXIST (curr lexbuf) } + | "case" { CASE (curr lexbuf) } (* types *) | "List" { TLIST (curr lexbuf) } | "Int" { TINT (curr lexbuf) } diff --git a/wisl/lib/ParserAndCompiler/WParser.mly b/wisl/lib/ParserAndCompiler/WParser.mly index a6fad0b3..798241f5 100644 --- a/wisl/lib/ParserAndCompiler/WParser.mly +++ b/wisl/lib/ParserAndCompiler/WParser.mly @@ -3,7 +3,7 @@ (* key words *) %token TRUE FALSE NULL WHILE IF ELSE SKIP FRESH NEW DELETE %token PROC FUNCTION RETURN PREDICATE LEMMA DATATYPE -%token INVARIANT PACKAGE FOLD UNFOLD NOUNFOLD APPLY ASSERT ASSUME ASSUME_TYPE EXIST FORALL +%token INVARIANT PACKAGE FOLD UNFOLD NOUNFOLD APPLY ASSERT ASSUME ASSUME_TYPE EXIST FORALL CASE %token STATEMENT WITH VARIANT PROOF (* punctuation *) @@ -126,6 +126,8 @@ %type constructor %type constructor_fields %type func_param +%type tuple_binders +%type logic_case %% prog: @@ -650,9 +652,12 @@ logic_expression: let loc = CodeLoc.merge lstart lend in let bare_lexpr = WLExpr.LConstructorApp (name, l) in WLExpr.make bare_lexpr loc } - -logic_constructor_app_params: - | LBRACE; lst = separated_list(COMMA, logic_expression); lend = RBRACE; { (lst, lend) } + | lstart = CASE; scrutinee = logic_expression; LCBRACE; cases = separated_list(SEMICOLON, logic_case); lend = RCBRACE + { + let loc = CodeLoc.merge lstart lend in + let bare_lexpr = WLExpr.LCases(scrutinee, cases) in + WLExpr.make bare_lexpr loc + } (* We also have lists in the logic *) logic_binop: @@ -670,6 +675,22 @@ logic_value_with_loc: let loc = CodeLoc.merge lstart lend in (loc, WVal.VList vl) } */ +logic_constructor_app_params: + | LBRACE; lst = separated_list(COMMA, logic_expression); lend = RBRACE; { (lst, lend) } + +logic_case: + | cname = IDENTIFIER; binders = option(tuple_binders); ARROW; expr = logic_expression + { + let binders = Option.value ~default:[] binders in + { WLExpr.constructor = snd cname; + binders = binders; + lexpr = expr } + } + +tuple_binders: + | LBRACE; xs = separated_list(COMMA, IDENTIFIER); RBRACE + { List.map snd xs } + (* ADT definitions *) diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index e1957584..35b3488d 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -248,7 +248,8 @@ let rec compile_lexpr let gvars, asrtsl, comp_exprs = list_split_3 (List.map compile_lexpr l) in - (List.concat gvars, List.concat asrtsl, Expr.FuncApp (n, comp_exprs))) + (List.concat gvars, List.concat asrtsl, Expr.FuncApp (n, comp_exprs)) + | LCases _ -> failwith "TODO") (* TODO: compile_lformula should return also the list of created existentials *) let rec compile_lformula ?(proc_name = "main") formula : Asrt.t * Expr.t = diff --git a/wisl/lib/syntax/WCase.ml b/wisl/lib/syntax/WCase.ml new file mode 100644 index 00000000..e69de29b diff --git a/wisl/lib/syntax/WLExpr.ml b/wisl/lib/syntax/WLExpr.ml index 8069fe0e..227c8184 100644 --- a/wisl/lib/syntax/WLExpr.ml +++ b/wisl/lib/syntax/WLExpr.ml @@ -11,7 +11,9 @@ type tt = | LESet of t list | LFuncApp of string * t list (* Function application *) | LConstructorApp of string * t list (* Constructor application *) + | LCases of t * case list +and case = { constructor : string; binders : string list; lexpr : t } and t = { wleid : int; wleloc : CodeLoc.t; wlenode : tt } let get le = le.wlenode @@ -82,6 +84,18 @@ let rec pp fmt lexpr = Format.fprintf fmt "@['%s" name; WPrettyUtils.pp_list ~pre:(format_of_string "(") ~suf:(format_of_string ")@]") ~empty:(format_of_string "@]") pp fmt lel + | LCases (le, cs) -> + Format.fprintf fmt "@[case %a {@," pp le; + List.iter + (fun { constructor; binders; lexpr } -> + Format.fprintf fmt " %s" constructor; + WPrettyUtils.pp_list ~pre:(format_of_string "(") + ~suf:(format_of_string ")") ~empty:(format_of_string "") + (fun fmt s -> Format.fprintf fmt "%s" s) + fmt binders; + Format.fprintf fmt " -> %a;@," pp lexpr) + cs; + Format.fprintf fmt "}@]" let str = Format.asprintf "%a" pp @@ -100,5 +114,8 @@ let rec substitution (subst : (string, tt) Hashtbl.t) (e : t) : t = | LESet le -> LESet (List.map f le) | LFuncApp (name, le) | LConstructorApp (name, le) -> LFuncApp (name, List.map f le) + | LCases (e, cs) -> + let cs = List.map (fun c -> { c with lexpr = f c.lexpr }) cs in + LCases (e, cs) in { wleid; wleloc; wlenode } diff --git a/wisl/lib/syntax/WLExpr.mli b/wisl/lib/syntax/WLExpr.mli index 9575f520..be562c66 100644 --- a/wisl/lib/syntax/WLExpr.mli +++ b/wisl/lib/syntax/WLExpr.mli @@ -9,7 +9,9 @@ type tt = | LESet of t list | LFuncApp of string * t list | LConstructorApp of string * t list + | LCases of t * case list +and case = { constructor : string; binders : string list; lexpr : t } and t val get : t -> tt diff --git a/wisl/lib/syntax/WType.ml b/wisl/lib/syntax/WType.ml index 430cd528..d1b113d5 100644 --- a/wisl/lib/syntax/WType.ml +++ b/wisl/lib/syntax/WType.ml @@ -135,9 +135,14 @@ let rec infer_logic_expr knownp lexpr = TypeMap.add bare_lexpr WList (List.fold_left infer_logic_expr knownp lel) | LESet lel -> TypeMap.add bare_lexpr WSet (List.fold_left infer_logic_expr knownp lel) - | LFuncApp (n, lel) | LConstructorApp (n, lel) -> + | LFuncApp (_, lel) -> List.fold_left infer_logic_expr knownp lel + | LConstructorApp (n, lel) -> TypeMap.add bare_lexpr (WDatatype n) (List.fold_left infer_logic_expr knownp lel) + | LCases (le, cs) -> + let lel = List.map (fun (c : case) -> c.lexpr) cs in + let inferred = infer_logic_expr knownp le in + List.fold_left infer_logic_expr inferred lel (** Single step of inference for that gets a TypeMap from a single assertion *) let rec infer_single_assert_step asser known = From 0acffa5ead39e18a5f514a6651470a5be46570dd Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Thu, 1 May 2025 23:05:41 +0100 Subject: [PATCH 32/37] Added support for cases statements --- GillianCore/GIL_Syntax/Expr.ml | 29 +++- GillianCore/GIL_Syntax/Gil_syntax.mli | 23 +++ GillianCore/GIL_Syntax/TypeDef__.ml | 1 + GillianCore/engine/Abstraction/MP.ml | 17 ++- GillianCore/engine/Abstraction/Normaliser.ml | 4 +- GillianCore/engine/FOLogic/Reduction.ml | 29 +++- GillianCore/engine/FOLogic/smt.ml | 144 +++++++++++++----- GillianCore/engine/FOLogic/typing.ml | 128 ++++++++++++++++ .../engine/concrete_semantics/CExprEval.ml | 5 +- .../engine/logical_env/datatype_env.ml | 12 +- .../engine/logical_env/datatype_env.mli | 1 + .../engine/symbolic_semantics/SState.ml | 2 + wisl/examples/SLL_adt.wisl | 53 ++++++- wisl/examples/temp.wisl | 27 ---- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 11 +- wisl/lib/syntax/WCase.ml | 0 16 files changed, 407 insertions(+), 79 deletions(-) delete mode 100644 wisl/examples/temp.wisl delete mode 100644 wisl/lib/syntax/WCase.ml diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index 6e3e1786..78ff7b78 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -18,6 +18,7 @@ type t = TypeDef__.expr = (** Universal quantification. *) | ConstructorApp of string * t list (** Datatype constructor *) | FuncApp of string * t list (** Function application *) + | Cases of t * (string * string list * t) list [@@deriving eq, ord] let to_yojson = TypeDef__.expr_to_yojson @@ -382,6 +383,15 @@ let rec map_opt | ConstructorApp (n, les) -> aux les (fun les -> ConstructorApp (n, les)) | FuncApp (n, les) -> aux les (fun les -> FuncApp (n, les)) + | Cases (e, cs) -> + let cs = + List_utils.flaky_map + (fun (c, bs, e) -> + let e = map_e e in + Option.map (fun e -> (c, bs, e)) e) + cs + in + Option.map (fun cs -> Cases (e, cs)) cs in Option.map f_after mapped_expr @@ -422,6 +432,22 @@ let rec pp fmt e = | ConstructorApp (n, ll) -> Fmt.pf fmt "'%s(%a)" n (Fmt.list ~sep:Fmt.comma pp) ll | FuncApp (n, ll) -> Fmt.pf fmt "%s(%a)" n (Fmt.list ~sep:Fmt.comma pp) ll + | Cases (scrutinee, branches) -> + Fmt.pf fmt "@[case %a {@," pp scrutinee; + List.iteri + (fun i (constructor, binders, expr) -> + Fmt.pf fmt " %s" constructor; + (match binders with + | [] -> () + | _ -> + Fmt.pf fmt "("; + Fmt.pf fmt "%a" (Fmt.list ~sep:(Fmt.any ", ") Fmt.string) binders; + Fmt.pf fmt ")"); + Fmt.pf fmt " -> %a" pp expr; + if i < List.length branches - 1 then Fmt.pf fmt ";@," + else Fmt.pf fmt "@,") + branches; + Fmt.pf fmt "}@]" let rec full_pp fmt e = match e with @@ -484,8 +510,7 @@ let rec is_concrete (le : t) : bool = | BinOp (e1, _, e2) -> loop [ e1; e2 ] | LstSub (e1, e2, e3) -> loop [ e1; e2; e3 ] | NOp (_, les) | EList les | ESet les -> loop les - | ConstructorApp (_, _) | FuncApp _ -> false -(* TODO: Pretty sure constructors / func app are not concrete, but double check *) + | ConstructorApp (_, _) | FuncApp _ | Cases _ -> false let is_concrete_zero_i : t -> bool = function | Lit (Int z) -> Z.equal Z.zero z diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 0eed802e..6dbc944f 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -253,6 +253,7 @@ module Expr : sig | ForAll of (string * Type.t option) list * t | ConstructorApp of string * t list | FuncApp of string * t list + | Cases of t * (string * string list * t) list [@@deriving yojson] (** {2: Helpers for building expressions} @@ -1192,6 +1193,12 @@ module Visitors : sig (string * (string * Expr.t) list) option -> 'f Cmd.t ; visit_Car : 'c -> UnOp.t -> UnOp.t + ; visit_Cases : + 'c -> + Expr.t -> + Expr.t -> + (string * string list * Expr.t) list -> + Expr.t ; visit_Cdr : 'c -> UnOp.t -> UnOp.t ; visit_Constant : 'c -> Literal.t -> Constant.t -> Literal.t ; visit_ConstructorApp : @@ -1456,6 +1463,10 @@ module Visitors : sig 'f Cmd.t method visit_Car : 'c -> UnOp.t -> UnOp.t + + method visit_Cases : + 'c -> Expr.t -> Expr.t -> (string * string list * Expr.t) list -> Expr.t + method visit_Cdr : 'c -> UnOp.t -> UnOp.t method visit_Constant : 'c -> Literal.t -> Constant.t -> Literal.t @@ -1757,6 +1768,8 @@ module Visitors : sig (string * (string * Expr.t) list) option -> 'f ; visit_Car : 'c -> 'f + ; visit_Cases : + 'c -> Expr.t -> (string * string list * Expr.t) list -> 'f ; visit_Cdr : 'c -> 'f ; visit_Constant : 'c -> Constant.t -> 'f ; visit_ConstructorApp : 'c -> string -> Expr.t list -> 'f @@ -1984,6 +1997,10 @@ module Visitors : sig 'f method visit_Car : 'c -> 'f + + method visit_Cases : + 'c -> Expr.t -> (string * string list * Expr.t) list -> 'f + method visit_Cdr : 'c -> 'f method visit_Constant : 'c -> Constant.t -> 'f method visit_ConstructorApp : 'c -> string -> Expr.t list -> 'f @@ -2213,6 +2230,8 @@ module Visitors : sig Cmd.logic_bindings_t option -> unit ; visit_Car : 'c -> unit + ; visit_Cases : + 'c -> Expr.t -> (string * string list * Expr.t) list -> unit ; visit_Cdr : 'c -> unit ; visit_Constant : 'c -> Constant.t -> unit ; visit_ConstructorApp : 'c -> string -> Expr.t list -> unit @@ -2439,6 +2458,10 @@ module Visitors : sig unit method visit_Car : 'c -> unit + + method visit_Cases : + 'c -> Expr.t -> (string * string list * Expr.t) list -> unit + method visit_Cdr : 'c -> unit method visit_Constant : 'c -> Constant.t -> unit method visit_ConstructorApp : 'c -> string -> Expr.t list -> unit diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index 8c9aeeb9..fb3a0b03 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -155,6 +155,7 @@ and expr = | ForAll of (string * typ option) list * expr | ConstructorApp of string * expr list | FuncApp of string * expr list + | Cases of expr * (string * string list * expr) list and assertion_atom = | Emp diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index bddd2641..595d1125 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -101,8 +101,7 @@ let minimise_matchables (kb : KB.t) : KB.t = let rec missing_expr (kb : KB.t) (e : Expr.t) : KB.t list = let f' = missing_expr in let f = missing_expr kb in - let join (le : Expr.t list) = - let mle = List.map f le in + let join' (mle : KB.t list list) = let cpmle = List_utils.list_product mle in let umle = List.map @@ -111,6 +110,10 @@ let rec missing_expr (kb : KB.t) (e : Expr.t) : KB.t list = in if umle = [] || List.mem KB.empty umle then [ KB.empty ] else umle in + let join (le : Expr.t list) = + let mle = List.map f le in + join' mle + in if KB.mem e kb then [ KB.empty ] else match e with @@ -149,6 +152,12 @@ let rec missing_expr (kb : KB.t) (e : Expr.t) : KB.t list = Fmt.(brackets (list ~sep:semi kb_pp)) result); result + | Cases (le, cs) -> + let kb' bs = + KB.add_seq (List.to_seq bs |> Seq.map (fun x -> Expr.LVar x)) kb + in + let mle = f le :: List.map (fun (_, bs, e) -> f' (kb' bs) e) cs in + join' mle | Exists (bt, e) | ForAll (bt, e) -> let kb' = KB.add_seq (List.to_seq bt |> Seq.map (fun (x, _) -> Expr.LVar x)) kb @@ -292,6 +301,7 @@ let rec learn_expr | ConstructorApp _ -> [] (* Function application isn't invertible *) | FuncApp _ -> [] + | Cases _ -> [] 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)); *) @@ -454,7 +464,8 @@ let rec simple_ins_formula (kb : KB.t) (pf : Expr.t) : KB.t list = | EList _ | ESet _ | ConstructorApp _ - | FuncApp _ -> [] + | FuncApp _ + | Cases _ -> [] (** [ins_outs_formula kb pf] returns a list of possible ins-outs pairs for a given formula [pf] under a given knowledge base [kb] *) diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index fded24d6..657e0607 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -173,7 +173,7 @@ module Make (SPState : PState.S) = struct (Exceptions.Impossible "normalise_lexpr: program variable in normalised \ expression") - | BinOp (_, _, _) | UnOp (_, _) | FuncApp _ -> + | BinOp (_, _, _) | UnOp (_, _) | FuncApp _ | Cases _ -> UnOp (TypeOf, nle1) | Exists _ | ForAll _ -> Lit (Type BooleanType) | EList _ | LstSub _ | NOp (LstCat, _) -> Lit (Type ListType) @@ -233,6 +233,8 @@ module Make (SPState : PState.S) = struct | _, _ -> failwith "Impossible") | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) | FuncApp (n, les) -> FuncApp (n, List.map f les) + | Cases (le, cs) -> + Cases (f le, List.map (fun (c, bs, le) -> (c, bs, f le)) cs) in if not no_types then Typing.infer_types_expr gamma result; diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index 79d67444..ddb30ae6 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -138,6 +138,8 @@ let rec normalise_list_expressions (le : Expr.t) : Expr.t = | ForAll (bt, le) -> ForAll (bt, f le) | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) | FuncApp (n, les) -> FuncApp (n, List.map f les) + | Cases (le, cs) -> + Cases (f le, List.map (fun (c, bs, le) -> (c, bs, f le)) cs) (* | LstSub(le1, le2, le3) -> (match f le1, f le2, f le3 with @@ -912,6 +914,31 @@ and reduce_lexpr_loop Function Application ------------------------- *) | FuncApp (n, les) -> FuncApp (n, List.map f les) + (* ------------------------- + Cases + ------------------------- *) + | Cases (ConstructorApp (c, les), cs) -> ( + let bles = + List.filter_map + (fun (c', bs, e) -> if c = c' then Some (bs, e) else None) + cs + in + match bles with + | [ (bs, e) ] when List.length bs = List.length les -> + let le = + List.fold_left2 + (fun acc b le -> + Expr.subst_expr_for_expr ~to_subst:(Expr.LVar b) + ~subst_with:le acc) + e bs les + in + f le + | _ -> raise (ReductionException (le, "No case match found"))) + | Cases (le, cs) -> + let le' = f le in + let f' = if not (Expr.equal le le') then f else Fun.id in + let cs' = List.map (fun (c, bs, e) -> (c, bs, f e)) cs in + f' (Cases (le', cs')) (* ------------------------- ForAll + Exists ------------------------- *) @@ -1799,7 +1826,7 @@ and reduce_lexpr_loop else Expr.false_ | BinOp (ConstructorApp _, Equal, rle) as le -> ( match rle with - | LVar _ | ConstructorApp _ -> le + | LVar _ | ConstructorApp _ | FuncApp _ | Cases _ -> le | _ -> Expr.false_) (* BinOps: Logic *) | BinOp (Lit (Bool true), And, e) diff --git a/GillianCore/engine/FOLogic/smt.ml b/GillianCore/engine/FOLogic/smt.ml index 94109646..45af80cf 100644 --- a/GillianCore/engine/FOLogic/smt.ml +++ b/GillianCore/engine/FOLogic/smt.ml @@ -342,11 +342,6 @@ module Lit_operations = struct module List = (val un "List" "listValue" (t_seq t_gil_literal) : Unary) module None = (val nul "None" : Nullary) - module Datatype = struct - let access (name : string) (x : sexp) = - atom (user_def_datatype_lit_param_name name) <| x - end - let init_decls user_def_datatypes = (* Reset variants tables on reinitialisation *) constructor_variants := Hashtbl.create Config.medium_tbl_size; @@ -595,7 +590,9 @@ module Encoding = struct | TypeType -> Type.access | BooleanType -> Bool.access | ListType -> List.access - | DatatypeType name -> Datatype.access name + | DatatypeType name -> + let (module U : Variant.Unary) = get_datatype_lit_variant name in + U.access | UndefinedType | NullType | EmptyType | NoneType | SetType -> Fmt.failwith "Cannot get native value of type %s" (Gil_syntax.Type.str typ) @@ -605,6 +602,13 @@ end let typeof_simple e = let open Type in + let datatype_guards = + Hashtbl.to_seq !Lit_operations.datatype_lit_variants + |> Seq.map (fun (dname, (module U : Variant.Unary)) -> + (U.recognize, DatatypeType dname)) + |> List.of_seq + in + let guards = Lit_operations. [ @@ -620,6 +624,7 @@ let typeof_simple e = (Type.recognize, TypeType); (List.recognize, ListType); ] + @ datatype_guards in List.fold_left (fun acc (guard, typ) -> ite (guard e) (encode_type typ) acc) @@ -839,46 +844,34 @@ let encode_unop ~llen_lvars ~e (op : UnOp.t) le = let () = L.print_to_all msg in raise (Failure msg) -let encode_quantified_expr +let encode_bound_expr ~(encode_expr : gamma:Type_env.t -> llen_lvars:SS.t -> list_elem_vars:SS.t -> 'a -> Encoding.t) - ~mk_quant ~gamma ~llen_lvars ~list_elem_vars - quantified_vars - (assertion : 'a) : Encoding.t = + bound_vars + (expr : 'a) = let open Encoding in - let- () = - match quantified_vars with - | [] -> - (* A quantified assertion with no quantified variables is just the assertion *) - Some (encode_expr ~gamma ~llen_lvars ~list_elem_vars assertion) - | _ -> None - in (* Start by updating gamma with the information provided by quantifier types. There's very few foralls, so it's ok to copy the gamma entirely *) let gamma = Type_env.copy gamma in let () = - quantified_vars + bound_vars |> List.iter (fun (x, typ) -> match typ with | None -> Type_env.remove gamma x | Some typ -> Type_env.update gamma x typ) in (* Not the same gamma now!*) - let encoded_assertion, consts, extra_asrts = - match encode_expr ~gamma ~llen_lvars ~list_elem_vars assertion with - | { kind = Native BooleanType; expr; consts; extra_asrts } -> - (expr, consts, extra_asrts) - | _ -> failwith "the thing inside forall is not boolean!" - in - let quantified_vars = - quantified_vars + let encoded = encode_expr ~gamma ~llen_lvars ~list_elem_vars expr in + (* Don't declare consts for quantified vars *) + let bound_vars = + bound_vars |> List.map (fun (x, t) -> let sort = match t with @@ -887,11 +880,43 @@ let encode_quantified_expr in (x, sort)) in - (* Don't declare consts for quantified vars *) let () = - consts + encoded.consts |> Hashtbl.filter_map_inplace (fun c () -> - if List.mem c quantified_vars then None else Some ()) + if List.mem c bound_vars then None else Some ()) + in + (bound_vars, encoded) + +let encode_quantified_expr + ~(encode_expr : + gamma:Type_env.t -> + llen_lvars:SS.t -> + list_elem_vars:SS.t -> + 'a -> + Encoding.t) + ~mk_quant + ~gamma + ~llen_lvars + ~list_elem_vars + quantified_vars + (assertion : 'a) : Encoding.t = + let open Encoding in + let- () = + match quantified_vars with + | [] -> + (* A quantified assertion with no quantified variables is just the assertion *) + Some (encode_expr ~gamma ~llen_lvars ~list_elem_vars assertion) + | _ -> None + in + let quantified_vars, encoded = + encode_bound_expr ~encode_expr ~gamma ~llen_lvars ~list_elem_vars + quantified_vars assertion + in + let encoded_assertion, consts, extra_asrts = + match encoded with + | { kind = Native BooleanType; expr; consts; extra_asrts } -> + (expr, consts, extra_asrts) + | _ -> failwith "the thing inside forall is not boolean!" in let expr = mk_quant quantified_vars encoded_assertion in native ~consts ~extra_asrts BooleanType expr @@ -964,11 +989,42 @@ let rec encode_logical_expression | None -> let msg = "SMT - Undefined function: " ^ name in raise (Failure msg)) + | Cases (le, cs) -> + (* Type checking should ensure that all constructors belong to the same datatype *) + let constructors_t = + match cs with + | (cname, _, _) :: _ -> Datatype_env.get_constructor_type_unsafe cname + | [] -> + let msg = "SMT - No cases given in case statement" in + raise (Failure msg) + in + let>- le = f le in + (* Convert to native *) + let le_native = get_native_of_type ~typ:constructors_t le in + (* Encode match cases *) + let cs, encs = + List.split + (List.map + (fun (c, bs, e) -> + let (module N : Variant.Nary) = + Lit_operations.get_constructor_variant c + in + let pat = PCon (c, bs) in + let ts = Datatype_env.get_constructor_field_types_unsafe c in + let bts = List.combine bs ts in + let _, encoded = + encode_bound_expr ~encode_expr:encode_logical_expression ~gamma + ~llen_lvars ~list_elem_vars bts e + in + ((pat, extend_wrap encoded), encoded)) + cs) + in + let>-- _ = encs in + extended_wrapped (match_datatype le_native cs) | ConstructorApp (name, les) -> ( let param_typs = Datatype_env.get_constructor_field_types name in match param_typs with | Some param_typs -> - (* TODO: Should we be extend wrapping here? *) let simple_wrap_or_native typopt = match typopt with | Some typ -> get_native_of_type ~typ @@ -1051,6 +1107,19 @@ let lvars_as_list_elements ?(exclude = SS.empty) (assertions : Expr.Set.t) : Containers.SS.union acc inner) Containers.SS.empty es + method! visit_ConstructorApp (exclude, _) _ les = + List.fold_left + (fun acc e -> + match e with + | Expr.LVar x -> + if not (Containers.SS.mem x exclude) then + Containers.SS.add x acc + else acc + | _ -> + let inner = self#visit_expr (exclude, true) e in + Containers.SS.union acc inner) + Containers.SS.empty les + method! visit_LVar (exclude, is_in_list) x = if is_in_list && not (Containers.SS.mem x exclude) then Containers.SS.singleton x @@ -1191,13 +1260,16 @@ let init () = (* Pop off initial declarations if necessary *) cmd (pop 2); cmd (push 1); + let type_init_decls = Type_operations.init_decls in + let lit_init_decls = + Lit_operations.init_decls (Datatype_env.get_datatypes ()) + in + let ext_lit_init_decls = Ext_lit_operations.init_decls in + let func_init_decls = + Function_operations.init_decls (Function_env.get_functions ()) + in let init_decls = - [ - Type_operations.init_decls; - Lit_operations.init_decls (Datatype_env.get_datatypes ()); - Ext_lit_operations.init_decls; - Function_operations.init_decls (Function_env.get_functions ()); - ] + [ type_init_decls; lit_init_decls; ext_lit_init_decls; func_init_decls ] in let decls = List.concat init_decls in let () = decls |> List.iter cmd in diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index e58d9a40..8a86e12e 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -189,6 +189,85 @@ module Infer_types_to_gamma = struct else (* Can't say for certain whether or not the constructor is typable *) true + | Cases (le, cs) -> + let scrutinee_type_check = + if Datatype_env.is_initialised () then + let constructors = List.map (fun (c, _, _) -> c) cs in + let constructor_types = + List.map Datatype_env.get_constructor_type constructors + in + let constructors_type = + match List.filter_map (fun t -> t) constructor_types with + | [] -> None (* No constructor type was 'Some' *) + | t :: ts -> + if + List.for_all (( = ) t) ts + && Stdlib.( = ) + (List.length constructor_types) + (List.length (t :: ts)) + then Some t (* All constructors have type t *) + else None (* Not all constructors have type t *) + in + (* We expect the scrutinee to have the same type as the constructors *) + (* against which it is being matched. *) + Option.fold ~none:false ~some:(f le) constructors_type + else + (* Can't type check scrutinee - we don't know types of constructors *) + (* Assume it type checks *) + true + in + + let case_type_check (c, bs, le) = + let gamma_copy = Type_env.copy gamma in + let new_gamma_copy = Type_env.copy new_gamma in + let binders_okay = + if Datatype_env.is_initialised () then + let binder_types = Datatype_env.get_constructor_field_types c in + match binder_types with + | None -> + (* Datatype env is initialised but can't find constructor *) + false + | Some ts -> + (* Update type info of binders *) + if List.length ts <> List.length bs then false + else + let () = + List.iter2 + (fun b t -> + let () = + match t with + | Some t -> Type_env.update gamma_copy b t + | None -> Type_env.remove gamma_copy b + in + Type_env.remove new_gamma_copy b) + bs ts + in + true + else + (* Type info not known about binders - simply remove them *) + let () = + List.iter + (fun b -> + let () = Type_env.remove gamma_copy b in + Type_env.remove new_gamma_copy b) + bs + in + true + in + let ret = + if binders_okay then + (* We expect le to have type tt *) + f' gamma_copy new_gamma_copy le tt + else false + in + (* We've updated our new_gamma_copy with a bunch of things. + We need to import everything except the bound variables to the new_gamma *) + Type_env.iter new_gamma_copy (fun x t -> + if not (List.exists (fun y -> String.equal x y) bs) then + Type_env.update new_gamma x t); + ret + in + scrutinee_type_check && List.for_all case_type_check cs | Exists (bt, le) | ForAll (bt, le) -> if not (tt = BooleanType) then false else @@ -520,6 +599,54 @@ module Type_lexpr = struct | None -> def_neg else (None, true) + and type_case gamma t_scrutinee (c, bs, le) = + if Datatype_env.is_initialised () then + let t_constructor = Datatype_env.get_constructor_type c in + let types_match = + match (t_scrutinee, t_constructor) with + | _, None -> false (* Constructor not found in datatype env *) + | Some t1, Some t2 when Type.equal t1 t2 -> true + | None, _ -> true + | _ -> false + in + if not types_match then def_neg + else + (* Set up gamma copy with the binders' type info *) + let gamma_copy = Type_env.copy gamma in + (* By this point we know c is in datatype env *) + let ts = Datatype_env.get_constructor_field_types_unsafe c in + let () = + List.iter2 + (fun b t -> + match t with + | Some t -> Type_env.update gamma_copy b t + | None -> Type_env.remove gamma_copy b) + bs ts + in + f gamma_copy le + else + let gamma_copy = Type_env.copy gamma in + let () = List.iter (fun b -> Type_env.remove gamma_copy b) bs in + f gamma_copy le + + and type_cases gamma le cs = + let topt, ite = f gamma le in + if not ite then def_neg + else + let cases = List.map (type_case gamma topt) cs in + if not (List.for_all (fun (_, ite) -> ite) cases) then def_neg + else + let known_case_types = List.filter_map (fun (topt, _) -> topt) cases in + let cases_type = + match known_case_types with + | [] -> None + | t :: ts when List.for_all (Type.equal t) ts -> Some t + | _ -> None + in + match cases_type with + | Some t -> infer_type gamma (Cases (le, cs)) t + | None -> (None, true) + (** This function returns a triple [(t_opt, b, fs)] where - [t_opt] is the type of [le] if we can find one - [b] indicates if the thing is typable @@ -552,6 +679,7 @@ module Type_lexpr = struct | LstSub (le1, le2, le3) -> type_lstsub gamma le1 le2 le3 | ConstructorApp (n, les) -> type_constructor_app gamma n les | FuncApp (n, les) -> type_func_app gamma n les + | Cases (le, cs) -> type_cases gamma le cs in result diff --git a/GillianCore/engine/concrete_semantics/CExprEval.ml b/GillianCore/engine/concrete_semantics/CExprEval.ml index 94c2c952..0f974c24 100644 --- a/GillianCore/engine/concrete_semantics/CExprEval.ml +++ b/GillianCore/engine/concrete_semantics/CExprEval.ml @@ -336,10 +336,11 @@ and evaluate_expr (store : CStore.t) (e : Expr.t) : CVal.M.t = | Exists _ | ForAll _ | ConstructorApp _ - | FuncApp _ -> + | FuncApp _ + | Cases _ -> raise (Exceptions.Impossible - "eval_expr concrete: aloc, lvar, set, exists, for all, \ + "eval_expr concrete: aloc, lvar, set, exists, for all, case, \ constructor or function application") with | TypeError msg -> raise (TypeError (msg ^ Fmt.str " in %a" Expr.pp e)) diff --git a/GillianCore/engine/logical_env/datatype_env.ml b/GillianCore/engine/logical_env/datatype_env.ml index 5e66b8de..b54efad4 100644 --- a/GillianCore/engine/logical_env/datatype_env.ml +++ b/GillianCore/engine/logical_env/datatype_env.ml @@ -62,7 +62,7 @@ let get_constructor_type_unsafe cname : Type.t = | None -> raise (Failure - ("Type_env.get_constructor_type_unsafe: constructor " ^ cname + ("Datatype_env.get_constructor_type_unsafe: constructor " ^ cname ^ " not found.")) let get_constructor_field_types cname : Type.t option list option = @@ -74,6 +74,16 @@ let get_constructor_field_types cname : Type.t option list option = (fun (c : Constructor.t) -> c.constructor_fields) (Option.join constructor) +let get_constructor_field_types_unsafe cname : Type.t option list = + let ts = get_constructor_field_types cname in + match ts with + | Some ts -> ts + | None -> + raise + (Failure + ("Datatype_env.get_constructor_field_types_unsafe: constructor " + ^ cname ^ " not found.")) + let get_datatypes () : Datatype.t list = let res = Option.map diff --git a/GillianCore/engine/logical_env/datatype_env.mli b/GillianCore/engine/logical_env/datatype_env.mli index 0eefa527..58d46846 100644 --- a/GillianCore/engine/logical_env/datatype_env.mli +++ b/GillianCore/engine/logical_env/datatype_env.mli @@ -6,4 +6,5 @@ val is_initialised : unit -> bool val get_constructor_type : string -> Type.t option val get_constructor_type_unsafe : string -> Type.t val get_constructor_field_types : string -> Type.t option list option +val get_constructor_field_types_unsafe : string -> Type.t option list val get_datatypes : unit -> Datatype.t list diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index 96e38634..26dd0d39 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -256,6 +256,8 @@ module Make (SMemory : SMemory.S) : | Lit _ | LVar _ | ALoc _ -> expr | ConstructorApp (n, les) -> ConstructorApp (n, List.map f les) | FuncApp (n, les) -> FuncApp (n, List.map f les) + | Cases (le, cs) -> + Cases (f le, List.map (fun (c, bs, le) -> (c, bs, f le)) cs) in (* Perform reduction *) if no_reduce then result diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl index 14cf91a5..904d508f 100644 --- a/wisl/examples/SLL_adt.wisl +++ b/wisl/examples/SLL_adt.wisl @@ -10,6 +10,19 @@ function append(xs : MyList, x) { } } +function length(xs : MyList) { + case xs { + Nil -> 0; + Cons(x, xs) -> 1 + length(xs) + } +} + +function double_length(xs : MyList) { + case xs { + Nil -> 0; + Cons(x, xs) -> 2 + length(xs) + } +} // // Standard over-approximating sll predicate with contents @@ -55,18 +68,48 @@ proc sll_prepend(x, k){ { sll(ret, 'Cons(#k, #vs)) } // 02. Appending a given value to a given SLL -{ (x == #x) * (k == #k) * SLL(#x, #vs) } -proc SLL_append(x, k){ +{ (x == #x) * (k == #k) * sll(#x, #vs) } +proc sll_append(x, k){ if (x = null) { - x := SLL_allocate_node(k) + x := sll_allocate_node(k) } else { t := [x + 1]; - z := SLL_append(t, k); + z := sll_append(t, k); [x + 1] := z }; return x } -{ SLL(ret, append(#vs, #k)) } +{ sll(ret, append(#vs, #k)) } + +// 06. Calculating the length of a given SLL +{ (x == #x) * sll(#x, #vs) } +proc sll_length(x) { + n := 0; + if (x = null){ + n := 0 + } else { + t := [x + 1]; + n := sll_length(t); + n := 1 + n + }; + return n +} +{ ret == length(#vs) } + +// This spec fails to verify +{ (x == #x) * sll(#x, #vs) } +proc sll_length_fails(x) { + n := 0; + if (x = null){ + n := 0 + } else { + t := [x + 1]; + n := sll_length(t); + n := 1 + n + }; + return n +} +{ ret == double_length(#vs) } // 05. Copying a given sll { (x == #x) * sll(#x, #vs) } diff --git a/wisl/examples/temp.wisl b/wisl/examples/temp.wisl deleted file mode 100644 index 8a8bebdd..00000000 --- a/wisl/examples/temp.wisl +++ /dev/null @@ -1,27 +0,0 @@ - -// Define a list ADT for use in specification language -datatype MyList { - Nil; - Cons(Any, MyList) -} - - -// -// Standard over-approximating SLL predicate with contents -// -predicate SLL(+x, vs) { - // Empty SLL - (x == null) * (vs == Nil); - // One SLL node and the rest - (x -b> #v, #next) * SLL(#next, #vs) * - (vs == Cons(#v, #vs)) -} - -// -// Pure predicate for list membership -// -predicate list_member(+vs, +v, r : Bool){ - (vs == Nil) * (r == false); - (vs == Cons(v, #rest)) * (r == true) * list_member(#rest, v, #mem); - (vs == Cons(#v, #rest)) * (! (#v == v)) * list_member(#rest, v, r) -} diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index 35b3488d..e2b73400 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -249,7 +249,16 @@ let rec compile_lexpr list_split_3 (List.map compile_lexpr l) in (List.concat gvars, List.concat asrtsl, Expr.FuncApp (n, comp_exprs)) - | LCases _ -> failwith "TODO") + | LCases (le, cs) -> + let compile_case { constructor; binders; lexpr } = + let gvars, asrtsl, comp_lexpr = compile_lexpr lexpr in + (gvars, asrtsl, (constructor, binders, comp_lexpr)) + in + let gvar, asrtl, comp_le = compile_lexpr le in + let gvars, asrtsl, comp_cs = list_split_3 (List.map compile_case cs) in + ( List.concat (gvar :: gvars), + List.concat (asrtl :: asrtsl), + Expr.Cases (comp_le, comp_cs) )) (* TODO: compile_lformula should return also the list of created existentials *) let rec compile_lformula ?(proc_name = "main") formula : Asrt.t * Expr.t = diff --git a/wisl/lib/syntax/WCase.ml b/wisl/lib/syntax/WCase.ml deleted file mode 100644 index e69de29b..00000000 From 94f646fc5f07d4840aec40423cf010aca7ace877 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Fri, 2 May 2025 13:47:14 +0100 Subject: [PATCH 33/37] WISL: function -> pure function; proc -> function --- wisl/examples/DLL_recursive.wisl | 2 +- wisl/examples/SLL_adt.wisl | 22 +-- wisl/examples/SLL_ex_complete.wisl | 38 ++-- wisl/examples/SLL_ex_ongoing.wisl | 20 +- wisl/examples/SLL_iterative.wisl | 4 +- wisl/examples/SLL_recursive.wisl | 10 +- wisl/examples/function.wisl | 10 +- wisl/examples/loop.wisl | 2 +- wisl/examples/tree.wisl | 2 +- wisl/lib/ParserAndCompiler/WAnnot.ml | 6 +- wisl/lib/ParserAndCompiler/WLexer.mll | 2 +- wisl/lib/ParserAndCompiler/WParser.mly | 144 +++++++-------- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 234 +++++++++++++----------- wisl/lib/debugging/wislLifter.ml | 119 ++++++------ wisl/lib/syntax/{WProc.ml => WFun.ml} | 7 +- wisl/lib/syntax/{WProc.mli => WFun.mli} | 4 +- wisl/lib/syntax/WFunc.ml | 6 - wisl/lib/syntax/WFunc.mli | 6 - wisl/lib/syntax/WLExpr.ml | 10 +- wisl/lib/syntax/WLExpr.mli | 2 +- wisl/lib/syntax/WProg.ml | 69 ++++--- wisl/lib/syntax/WProg.mli | 18 +- wisl/lib/syntax/WPureFun.ml | 6 + wisl/lib/syntax/WPureFun.mli | 6 + wisl/lib/syntax/WSpec.ml | 10 +- wisl/lib/syntax/WSpec.mli | 4 +- wisl/lib/syntax/WStmt.ml | 11 +- wisl/lib/syntax/WStmt.mli | 4 +- wisl/lib/syntax/WType.ml | 8 +- wisl/lib/syntax/WType.mli | 2 +- wisl/lib/utils/wBranchCase.ml | 8 +- wisl/lib/utils/wErrors.ml | 22 +-- wisl/lib/utils/wErrors.mli | 6 +- 33 files changed, 418 insertions(+), 406 deletions(-) rename wisl/lib/syntax/{WProc.ml => WFun.ml} (87%) rename wisl/lib/syntax/{WProc.mli => WFun.mli} (92%) delete mode 100644 wisl/lib/syntax/WFunc.ml delete mode 100644 wisl/lib/syntax/WFunc.mli create mode 100644 wisl/lib/syntax/WPureFun.ml create mode 100644 wisl/lib/syntax/WPureFun.mli diff --git a/wisl/examples/DLL_recursive.wisl b/wisl/examples/DLL_recursive.wisl index f9a5115f..e182f359 100644 --- a/wisl/examples/DLL_recursive.wisl +++ b/wisl/examples/DLL_recursive.wisl @@ -112,7 +112,7 @@ lemma dlseg_concat { // List concatenation { (x_a == #x_a) * (v_a == #v_a) * (x_b == #x_b) * (v_b == #v_b) * dlist(#x_a, #v_a, #alpha, #llena) * dlist(#x_b, #v_b, #beta, #llenb) } -proc concat(x_a, v_a, x_b, v_b) { +function concat(x_a, v_a, x_b, v_b) { r := new(2); if (x_a = null) { [r] := x_b; diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl index 904d508f..b07f4663 100644 --- a/wisl/examples/SLL_adt.wisl +++ b/wisl/examples/SLL_adt.wisl @@ -3,21 +3,21 @@ datatype MyList { Cons(Any, MyList) } -function append(xs : MyList, x) { +pure function append(xs : MyList, x) { case xs { Nil -> 'Cons(x, 'Nil); Cons(y, ys) -> 'Cons(y, append(ys, x)) } } -function length(xs : MyList) { +pure function length(xs : MyList) { case xs { Nil -> 0; Cons(x, xs) -> 1 + length(xs) } } -function double_length(xs : MyList) { +pure function double_length(xs : MyList) { case xs { Nil -> 0; Cons(x, xs) -> 2 + length(xs) @@ -37,7 +37,7 @@ predicate sll(+x, vs) { // 00. Allocating an sll node with the given value { v == #v } -proc sll_allocate_node(v){ +function sll_allocate_node(v){ t := new(2); [t] := v; return t @@ -46,7 +46,7 @@ proc sll_allocate_node(v){ // This incorrect spec should fail to verify { (v == #v) * (u == #u) } -proc sll_allocate_node_fails(u, v){ +function sll_allocate_node_fails(u, v){ t := new(2); [t] := v; return t @@ -60,7 +60,7 @@ proc sll_allocate_node_fails(u, v){ // 01. Prepending a given value to a given sll { (x == #x) * (k == #k) * sll(#x, #vs) } -proc sll_prepend(x, k){ +function sll_prepend(x, k){ z := sll_allocate_node(k); [z + 1] := x; return z @@ -69,7 +69,7 @@ proc sll_prepend(x, k){ // 02. Appending a given value to a given SLL { (x == #x) * (k == #k) * sll(#x, #vs) } -proc sll_append(x, k){ +function sll_append(x, k){ if (x = null) { x := sll_allocate_node(k) } else { @@ -83,7 +83,7 @@ proc sll_append(x, k){ // 06. Calculating the length of a given SLL { (x == #x) * sll(#x, #vs) } -proc sll_length(x) { +function sll_length(x) { n := 0; if (x = null){ n := 0 @@ -98,7 +98,7 @@ proc sll_length(x) { // This spec fails to verify { (x == #x) * sll(#x, #vs) } -proc sll_length_fails(x) { +function sll_length_fails(x) { n := 0; if (x = null){ n := 0 @@ -113,7 +113,7 @@ proc sll_length_fails(x) { // 05. Copying a given sll { (x == #x) * sll(#x, #vs) } -proc sll_copy(x){ +function sll_copy(x){ y := null; if (not (x = null)) { k := [x]; @@ -130,7 +130,7 @@ proc sll_copy(x){ // 10. Freeing a given sll { (x == #x) * sll(#x, #vs) } -proc sll_free(x){ +function sll_free(x){ if (x = null) { skip } else { diff --git a/wisl/examples/SLL_ex_complete.wisl b/wisl/examples/SLL_ex_complete.wisl index 4724de1b..0a2d7425 100644 --- a/wisl/examples/SLL_ex_complete.wisl +++ b/wisl/examples/SLL_ex_complete.wisl @@ -53,7 +53,7 @@ lemma list_member_concat { // 00. Allocating an SLL node with the given value { v == #v } -proc SLL_allocate_node(v){ +function SLL_allocate_node(v){ t := new(2); [t] := v; return t @@ -67,7 +67,7 @@ proc SLL_allocate_node(v){ // 01. Prepending a given value to a given SLL { (x == #x) * (k == #k) * SLL(#x, #vs) } -proc SLL_prepend(x, k){ +function SLL_prepend(x, k){ z := SLL_allocate_node(k); [z + 1] := x; return z @@ -76,7 +76,7 @@ proc SLL_prepend(x, k){ // 02. Appending a given value to a given SLL { (x == #x) * (k == #k) * SLL(#x, #vs) } -proc SLL_append(x, k){ +function SLL_append(x, k){ if (x = null) { x := SLL_allocate_node(k) } else { @@ -90,7 +90,7 @@ proc SLL_append(x, k){ // 03. Appending a given SLL node to a given SLL { (x == #x) * (y == #y) * SLL(#x, #vs) * SLL(#y, [#vy]) } -proc SLL_append_node(x, y) { +function SLL_append_node(x, y) { if (x = null) { x := y } else { @@ -104,7 +104,7 @@ proc SLL_append_node(x, y) { // 04. Concatenating two lists {(x == #x) * (y == #y) * SLL(#x, #vx) * SLL(#y, #vy) } -proc SLL_concat(x, y) { +function SLL_concat(x, y) { if (x = null){ x := y } else { @@ -118,7 +118,7 @@ proc SLL_concat(x, y) { // 05. Copying a given SLL { (x == #x) * SLL(#x, #vs) } -proc SLL_copy(x){ +function SLL_copy(x){ y := null; if (not (x = null)) { k := [x]; @@ -135,7 +135,7 @@ proc SLL_copy(x){ // 06. Calculating the length of a given SLL { (x == #x) * SLL(#x, #vs) } -proc SLL_length(x) { +function SLL_length(x) { n := 0; if (x = null){ n := 0 @@ -150,7 +150,7 @@ proc SLL_length(x) { // 07. Reversing a given SLL { (x == #x) * SLL(#x, #vs) } -proc SLL_reverse(x){ +function SLL_reverse(x){ if (not (x = null)) { t := [x + 1]; [x + 1] := null; @@ -165,7 +165,7 @@ proc SLL_reverse(x){ // 08. Checking if a given value is in a given SLL { (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #r) } -proc SLL_member(x, k){ +function SLL_member(x, k){ found := false; if (x = null){ skip @@ -184,7 +184,7 @@ proc SLL_member(x, k){ // 09. Removing a given value from a given SLL { (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #mem) } -proc SLL_remove(x, k) { +function SLL_remove(x, k) { if (x = null) { skip } else { @@ -205,7 +205,7 @@ proc SLL_remove(x, k) { // 10. Freeing a given SLL { (x == #x) * SLL(#x, #vs) } -proc SLL_free(x){ +function SLL_free(x){ if (x = null) { skip } else { @@ -284,7 +284,7 @@ lemma SLLseg_to_SLL { // 02. Appending a given value to a given SLL { (x == #x) * (k == #k) * SLL(#x, #vx) } -proc SLL_append_iter(x, k){ +function SLL_append_iter(x, k){ y := SLL_allocate_node(k); if (x = null) { x := y @@ -313,7 +313,7 @@ proc SLL_append_iter(x, k){ // 03. Appending a given node to a given SLL { (x == #x) * (y == #y) * SLL(#x, #vs) * SLL(#y, [#vy]) } -proc SLL_append_node_iter(x, y){ +function SLL_append_node_iter(x, y){ if (x = null) { x := y } else { @@ -341,7 +341,7 @@ proc SLL_append_node_iter(x, y){ // 04. Concatenating two lists {(x == #x) * (y == #y) * SLL(#x, #vx) * SLL(#y, #vy) } -proc SLL_concat_iter(x, y){ +function SLL_concat_iter(x, y){ if (x = null) { head := y } else { @@ -368,7 +368,7 @@ proc SLL_concat_iter(x, y){ // 05. Copying a given SLL { (x == #x) * SLL(#x, #alpha) } -proc SLL_copy_iter(x){ +function SLL_copy_iter(x){ y := null; if (x = null){ skip @@ -406,7 +406,7 @@ proc SLL_copy_iter(x){ // 06. Calculating the length of a given SLL { (x == #x) * SLL(x, #vx) } -proc SLL_length_iter(x) { +function SLL_length_iter(x) { y := x; n := 0; [[invariant {bind: n, y, #nvx, #nvy} @@ -427,7 +427,7 @@ proc SLL_length_iter(x) { // 07. Reversing a given SLL // { (x == #x) * SLL(#x, #vx) } -// proc SLL_reverse_iter(x) { +// function SLL_reverse_iter(x) { // y := null; // [[ invariant {bind: x, y, z, #nvx, #nvy} // SLL(x, #nvx) * SLL(y, #nvy) * (#vx == ((rev #nvy) @ #nvx)) ]]; @@ -443,7 +443,7 @@ proc SLL_length_iter(x) { // 08. Checking if a given value is in a given SLL { (x == #x) * (k == #k) * SLL(#x, #alpha) * list_member(#alpha, #k, #r) } -proc SLL_member_iter(x, k) { +function SLL_member_iter(x, k) { found := false; next := x; [[ invariant {bind: found, next, #beta, #gamma, #rg} @@ -472,7 +472,7 @@ proc SLL_member_iter(x, k) { // 10. Freeing a given SLL { (x == #x) * SLL(#x, #vs) } -proc SLL_free_iter(x) { +function SLL_free_iter(x) { [[ invariant {bind: x, #rvs} SLL(x, #rvs) ]]; while (not (x = null)) { y := x; diff --git a/wisl/examples/SLL_ex_ongoing.wisl b/wisl/examples/SLL_ex_ongoing.wisl index 49123f13..c9763792 100644 --- a/wisl/examples/SLL_ex_ongoing.wisl +++ b/wisl/examples/SLL_ex_ongoing.wisl @@ -219,7 +219,7 @@ lemma list_member_concat { // // 00. Allocating an SLL node with the given value // -proc SLL_allocate_node(v){ +function SLL_allocate_node(v){ t := new(2); [t] := v; return t @@ -247,7 +247,7 @@ predicate SLL_prepend_post(+def, +x, +xs, +k, +vs, +n, +retval) { // Specified algorithm { (x == #x) * (k == #k) * SLL_prepend_pre(#def, #x, #xs, #vs, #n) } -proc SLL_prepend(x, k){ +function SLL_prepend(x, k){ z := SLL_allocate_node(k); [z + 1] := x; return z @@ -280,7 +280,7 @@ predicate SLL_length_post(+def, +x, +retval) { // Specified algorithm { (x == #x) * SLL_length_pre(#def, #x, #var) } with variant: #var -proc SLL_length(x) { +function SLL_length(x) { if (x = null){ n := 0 } else { @@ -298,7 +298,7 @@ proc SLL_length(x) { // Specified algorithm { (x == #x) * SLL_len(x, #n) } -proc SLL_length_iter(x) { +function SLL_length_iter(x) { y := x; n := 0; [[ invariant {bind: n, y, #ny} @@ -336,7 +336,7 @@ predicate SLL_concat_post(+def, +x, +y, +xx, +xy, +vx, +vy, +nx, +ny, +retval) { // Specified algorithm {(x == #x) * (y == #y) * SLL_concat_pre(#def, #x, #y, #xx, #xy, #vx, #vy, #nx, #ny, #var) } with variant: #var -proc SLL_concat(x, y) { +function SLL_concat(x, y) { if (x = null){ x := y } else { @@ -354,7 +354,7 @@ proc SLL_concat(x, y) { // Specified algorithm {(x == #x) * (y == #y) * SLL_vals(#x, #vx) * SLL_vals(#y, #vy) } -proc SLL_concat_iter(x, y){ +function SLL_concat_iter(x, y){ if (x = null) { head := y } else { @@ -399,7 +399,7 @@ predicate SLL_reverse_post(+def, +x, +xs, +vs, +n, +retval) { // Specified algorithm { (x == #x) * SLL_reverse_pre(#def, #x, #xs, #vs, #n, #var) } with variant: #var -proc SLL_reverse(x){ +function SLL_reverse(x){ if (not (x = null)) { t := [x + 1]; [x + 1] := null; @@ -431,7 +431,7 @@ predicate nounfold SLL_member_post(+def, +x, +vs) { // Specified algorithm { (x == #x) * (k == #k) * SLL_member_pre(#def, #x, #vs, #var) * list_member(#vs, #k, #r) } with variant: #var -proc SLL_member(x, k){ +function SLL_member(x, k){ found := false; if (x = null){ skip @@ -452,7 +452,7 @@ proc SLL_member(x, k){ // 05i. List membership // { (x == #x) * (k == #k) * SLL_vals(#x, #vs) * list_member(#vs, #k, #r) } -proc SLL_member_iter(x, k) { +function SLL_member_iter(x, k) { found := false; next := x; [[ invariant {bind: found, next, #beta, #gamma, #rg} @@ -505,7 +505,7 @@ predicate SLL_free_post(+def, +x, +xs) { // Specified algorithm { (x == #x) * SLL_free_pre(#def, #x, #xs, #var) } with variant: #var -proc SLL_free(x){ +function SLL_free(x){ if (x = null) { skip } else { diff --git a/wisl/examples/SLL_iterative.wisl b/wisl/examples/SLL_iterative.wisl index c1c09602..19846a88 100644 --- a/wisl/examples/SLL_iterative.wisl +++ b/wisl/examples/SLL_iterative.wisl @@ -57,7 +57,7 @@ lemma lseg_append(x, y, alpha, yval, ynext) { { (#x == x) * list(#x, #alpha) } -proc llen(x) { +function llen(x) { y := x; n := 0; [[invariant {exists: #a1, #a2} lseg(#x, y, #a1) * list(y, #a2) * (#alpha == #a1@#a2) * (n == len #a1) ]]; @@ -76,7 +76,7 @@ proc llen(x) { { (x == #x) * (y == #y) * list(#x, #alpha) * list(#y, #beta) } -proc concat(x, y) { +function concat(x, y) { if (x = null) { x := y } else { diff --git a/wisl/examples/SLL_recursive.wisl b/wisl/examples/SLL_recursive.wisl index 6d12a48a..ae6a8f80 100644 --- a/wisl/examples/SLL_recursive.wisl +++ b/wisl/examples/SLL_recursive.wisl @@ -4,7 +4,7 @@ predicate list(+x, alpha) { } { (x == #x) * list(#x, #alpha) } -proc llen(x) { +function llen(x) { if (x = null) { n := 0 } else { @@ -17,7 +17,7 @@ proc llen(x) { { list(#x, #alpha) * (ret == len(#alpha)) } { (x == #x) * (y == #y) * list(#x, #alpha) * list(#y, #beta) } -proc concat(x, y) { +function concat(x, y) { if (x = null) { r := y } else { @@ -32,7 +32,7 @@ proc concat(x, y) { // { list(#x, #alpha) * (v == #v) } -// proc append(x, v) { +// function append(x, v) { // if (x = null) { // y := new(2); // [y] := v @@ -47,7 +47,7 @@ proc concat(x, y) { // { list(ret, #alpha@[#v]) } // { list(x, #alpha) * (x == #x) } -// proc copy(x) { +// function copy(x) { // if (x = null) { // ch := null // } else { @@ -63,7 +63,7 @@ proc concat(x, y) { // { list(#x, #alpha) * list(ret, #alpha) } // { list(x, #alpha) } -// proc dispose_list(x) { +// function dispose_list(x) { // if (x = null) { // skip // } else { diff --git a/wisl/examples/function.wisl b/wisl/examples/function.wisl index b2fff70d..4f87ad2f 100644 --- a/wisl/examples/function.wisl +++ b/wisl/examples/function.wisl @@ -1,20 +1,20 @@ -function double(x : Int) { +pure function double(x : Int) { x + x } -function triple(x : Int) { +pure function triple(x : Int) { x + x + x } { x == #x } -proc times_two(x) { +function times_two(x) { y := x * 2; return y } { ret == double(#x) } { x == #x } -proc times_three(x) { +function times_three(x) { y := x * 3; return y } @@ -22,7 +22,7 @@ proc times_three(x) { // This spec fails to verify { x == #x } -proc times_four(x) { +function times_four(x) { y := x * 4; return y } diff --git a/wisl/examples/loop.wisl b/wisl/examples/loop.wisl index 7d7e5bc7..b502d75c 100644 --- a/wisl/examples/loop.wisl +++ b/wisl/examples/loop.wisl @@ -44,7 +44,7 @@ lemma lseg_append(x, y, alpha, a, z) { } { (x == #x) * list(#x, #alpha) } -proc llen(x) { +function llen(x) { y := x; n := 0; [[ fold lseg(#x, y, []) ]]; diff --git a/wisl/examples/tree.wisl b/wisl/examples/tree.wisl index 89ac51e9..3312d655 100644 --- a/wisl/examples/tree.wisl +++ b/wisl/examples/tree.wisl @@ -4,7 +4,7 @@ predicate tree(+t) { } { (x == #x) * tree(#x) } -proc tree_dispose(x) { +function tree_dispose(x) { if (x != null) { y := [x+1]; z := [x+2]; diff --git a/wisl/lib/ParserAndCompiler/WAnnot.ml b/wisl/lib/ParserAndCompiler/WAnnot.ml index 542302c3..c7fa9c6c 100644 --- a/wisl/lib/ParserAndCompiler/WAnnot.ml +++ b/wisl/lib/ParserAndCompiler/WAnnot.ml @@ -1,7 +1,7 @@ type nest_kind = | LoopBody of string - (** This command nests its loop body an (abstracted) proc call *) - | ProcCall of string (** This command nests the body of a proc call *) + (** This command nests its loop body an (abstracted) function call *) + | FunCall of string (** This command nests the body of a function call *) [@@deriving yojson] (** How does this command map to a WISL statment? *) @@ -11,7 +11,7 @@ type stmt_kind = | Return of bool (** Same as [Normal], but specific to the return statement *) | Hidden (** A command that doesn't map to a particular WISL statement *) - | LoopPrefix (** A command in the prefix of a loop body proc *) + | LoopPrefix (** A command in the prefix of a loop body function *) [@@deriving yojson, show] type t = { diff --git a/wisl/lib/ParserAndCompiler/WLexer.mll b/wisl/lib/ParserAndCompiler/WLexer.mll index 61ded0d6..11c49e98 100644 --- a/wisl/lib/ParserAndCompiler/WLexer.mll +++ b/wisl/lib/ParserAndCompiler/WLexer.mll @@ -35,8 +35,8 @@ rule read = | "new" { NEW (curr lexbuf) } | "free" { DELETE (curr lexbuf) } | "dispose"{ DELETE (curr lexbuf) } + | "pure" { PURE (curr lexbuf) } | "function" { FUNCTION (curr lexbuf) } - | "proc" { PROC (curr lexbuf) } | "predicate" { PREDICATE (curr lexbuf) } | "datatype" { DATATYPE (curr lexbuf) } | "invariant" { INVARIANT (curr lexbuf) } diff --git a/wisl/lib/ParserAndCompiler/WParser.mly b/wisl/lib/ParserAndCompiler/WParser.mly index 798241f5..74b3d2d1 100644 --- a/wisl/lib/ParserAndCompiler/WParser.mly +++ b/wisl/lib/ParserAndCompiler/WParser.mly @@ -2,7 +2,7 @@ (* key words *) %token TRUE FALSE NULL WHILE IF ELSE SKIP FRESH NEW DELETE -%token PROC FUNCTION RETURN PREDICATE LEMMA DATATYPE +%token PURE FUNCTION RETURN PREDICATE LEMMA DATATYPE %token INVARIANT PACKAGE FOLD UNFOLD NOUNFOLD APPLY ASSERT ASSUME ASSUME_TYPE EXIST FORALL CASE %token STATEMENT WITH VARIANT PROOF @@ -97,43 +97,43 @@ %start prog %start assert_only -%type definitions -%type proc_with_specs -%type proc -%type predicate -%type lemma -%type datatype -%type func -%type var_list -%type statement_list_and_return -%type statement_list -%type expression -%type expr_list -%type logic_command -%type logic_assertion -%type value_with_loc -%type unop_with_loc -%type binop -%type variant_def -%type with_variant_def -%type proof_def -%type <(string * WType.t option) * bool> pred_param_ins -%type bindings_with_loc -%type logic_pure_formula -%type logic_expression -%type logic_binop -%type logic_value_with_loc -%type constructor -%type constructor_fields -%type func_param -%type tuple_binders -%type logic_case +%type definitions +%type fct_with_specs +%type fct +%type predicate +%type lemma +%type datatype +%type pure_function +%type var_list +%type statement_list_and_return +%type statement_list +%type expression +%type expr_list +%type logic_command +%type logic_assertion +%type value_with_loc +%type unop_with_loc +%type binop +%type variant_def +%type with_variant_def +%type proof_def +%type <(string * WType.t option) * bool> pred_param_ins +%type bindings_with_loc +%type logic_pure_formula +%type logic_expression +%type logic_binop +%type logic_value_with_loc +%type constructor +%type constructor_fields +%type pure_function_param +%type tuple_binders +%type logic_case %% prog: | defs = definitions; EOF { - let (fc, preds, lemmas, datatypes, funcs) = defs in - WProg.{ lemmas = lemmas; predicates = preds; context = fc; datatypes = datatypes; functions = funcs} } + let (fc, preds, lemmas, datatypes, pure_funcs) = defs in + WProg.{ lemmas = lemmas; predicates = preds; context = fc; datatypes = datatypes; pure_functions = pure_funcs} } assert_only: | la = logic_assertion; EOF { la } @@ -141,39 +141,39 @@ assert_only: definitions: | (* empty *) { ([], [], [], [], []) } | defs = definitions; p = predicate - { let (procs, preds, lemmas, datatypes, funcs) = defs in - (procs, p::preds, lemmas, datatypes, funcs) } + { let (fs, ps, ls, ds, pfs) = defs in + (fs, p::ps, ls, ds, pfs) } | defs = definitions; l = lemma - { let (procs, preds, lemmas, datatypes, funcs) = defs in - (procs, preds, l::lemmas, datatypes, funcs) } - | defs = definitions; p = proc_with_specs - { let (procs, preds, lemmas, datatypes, funcs) = defs in - (p::procs, preds, lemmas, datatypes, funcs) } + { let (fs, ps, ls, ds, pfs) = defs in + (fs, ps, l::ls, ds, pfs) } + | defs = definitions; f = fct_with_specs + { let (fs, ps, ls, ds, pfs) = defs in + (f::fs, ps, ls, ds, pfs) } | defs = definitions; d = datatype - { let (procs, preds, lemmas, datatypes, funcs) = defs in - (procs, preds, lemmas, d::datatypes, funcs) } - | defs = definitions; f = func - { let (procs, preds, lemmas, datatypes, funcs) = defs in - (procs, preds, lemmas, datatypes, f::funcs) } - -proc_with_specs: - | lstart = LCBRACE; pre = logic_assertion; RCBRACE; variant = option(with_variant_def); p = proc; LCBRACE; + { let (fs, ps, ls, ds, pfs) = defs in + (fs, ps, ls, d::ds, pfs) } + | defs = definitions; pf = pure_function + { let (fs, ps, ls, ds, pfs) = defs in + (fs, ps, ls, ds, pf::pfs) } + +fct_with_specs: + | lstart = LCBRACE; pre = logic_assertion; RCBRACE; variant = option(with_variant_def); f = fct; LCBRACE; post = logic_assertion; lend = RCBRACE { let loc = CodeLoc.merge lstart lend in - WProc.add_spec p pre post variant loc } - | p = proc { p } + WFun.add_spec f pre post variant loc } + | f = fct { f } -proc: - | lstart = PROC; lp = IDENTIFIER; LBRACE; params = var_list; RBRACE; (* block_start = *) LCBRACE; +fct: + | lstart = FUNCTION; lf = IDENTIFIER; LBRACE; params = var_list; RBRACE; (* block_start = *) LCBRACE; stmtsandret = statement_list_and_return; lend = RCBRACE; - { let (_, p) = lp in + { let (_, f) = lf in let (stmts, e) = stmtsandret in (* let block_loc = CodeLoc.merge block_start lend in let () = WStmt.check_consistency stmts block_loc in *) let floc = CodeLoc.merge lstart lend in let fid = Generators.gen_id () in - WProc.{ - name = p; + WFun.{ + name = f; params = params; body = stmts; return_expr = e; @@ -250,7 +250,7 @@ statement: | lx = IDENTIFIER; ASSIGN; lf = IDENTIFIER; LBRACE; params = expr_list; lend = RBRACE { let (lstart, x) = lx in let (_, f) = lf in - let bare_stmt = WStmt.ProcCall (x, f, params, None) in + let bare_stmt = WStmt.FunCall (x, f, params, None) in let loc = CodeLoc.merge lstart lend in WStmt.make bare_stmt loc } @@ -640,10 +640,10 @@ logic_expression: { let loc = CodeLoc.merge lstart lend in let bare_lexpr = WLExpr.LESet l in WLExpr.make bare_lexpr loc } - | lname = IDENTIFIER; LBRACE; l = separated_list(COMMA, logic_expression); lend = RBRACE - { let (lstart, name) = lname in + | lpf = IDENTIFIER; LBRACE; l = separated_list(COMMA, logic_expression); lend = RBRACE + { let (lstart, pf) = lpf in let loc = CodeLoc.merge lstart lend in - let bare_lexpr = WLExpr.LFuncApp (name, l) in + let bare_lexpr = WLExpr.LPureFunApp (pf, l) in WLExpr.make bare_lexpr loc } | lstart = QUOTE; lname = IDENTIFIER; llend = option(logic_constructor_app_params) @@ -738,22 +738,22 @@ constructor_fields: { (args, lend) } -(* Logical Functions *) +(* Pure Functions *) -func: - | lstart = FUNCTION; lfname = IDENTIFIER; LBRACE; func_params = separated_list(COMMA, func_param); - RBRACE; LCBRACE; func_definition=logic_expression; lend = RCBRACE +pure_function: + | lstart = PURE; FUNCTION; lpfname = IDENTIFIER; LBRACE; pure_fun_params = separated_list(COMMA, pure_function_param); + RBRACE; LCBRACE; pure_fun_definition=logic_expression; lend = RCBRACE { - let func_loc = CodeLoc.merge lstart lend in - let (_, func_name) = lfname in - WFunc.{ - func_name; - func_params; - func_definition; - func_loc; + let pure_fun_loc = CodeLoc.merge lstart lend in + let (_, pure_fun_name) = lpfname in + WPureFun.{ + pure_fun_name; + pure_fun_params; + pure_fun_definition; + pure_fun_loc; } } -func_param: +pure_function_param: | lx = IDENTIFIER; typ = option(preceded(COLON, type_target)) { let (_, x) = lx in (x, typ) } diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index e2b73400..eeb0e836 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -67,12 +67,12 @@ let rec compile_val v = | Str s -> Literal.String s | VList l -> Literal.LList (List.map compile_val l) -let rec compile_expr ?(proc_name = "main") ?(is_loop_prefix = false) expr : +let rec compile_expr ?(fname = "main") ?(is_loop_prefix = false) expr : (WAnnot.t * string option * string Cmd.t) list * Expr.t = - let gen_str = Generators.gen_str proc_name in - let compile_expr = compile_expr ~proc_name ~is_loop_prefix in + let gen_str = Generators.gen_str fname in + let compile_expr = compile_expr ~fname ~is_loop_prefix in let expr_of_string s = Expr.Lit (Literal.String s) in - let expr_pname_of_binop b = + let expr_fname_of_binop b = WBinOp.( match b with | PLUS -> expr_of_string internal_add @@ -83,10 +83,11 @@ let rec compile_expr ?(proc_name = "main") ?(is_loop_prefix = false) expr : | GREATERTHAN -> expr_of_string internal_gt | _ -> failwith - (Format.asprintf "Binop %a does not correspond to an internal proc" - WBinOp.pp b)) + (Format.asprintf + "Binop %a does not correspond to an internal function" WBinOp.pp + b)) in - let is_internal_proc = + let is_internal_func = WBinOp.( function | PLUS | MINUS | LESSEQUAL | LESSTHAN | GREATEREQUAL | GREATERTHAN -> true @@ -114,15 +115,15 @@ let rec compile_expr ?(proc_name = "main") ?(is_loop_prefix = false) expr : let cmdl2, comp_expr2 = compile_expr e2 in let expr = Expr.NOp (LstCat, [ comp_expr1; comp_expr2 ]) in (cmdl1 @ cmdl2, expr) - | BinOp (e1, b, e2) when is_internal_proc b -> + | BinOp (e1, b, e2) when is_internal_func b -> (* Operator corresponds to pointer arithmetics *) let call_var = gen_str gvar in - let internal_proc = expr_pname_of_binop b in + let internal_func = expr_fname_of_binop b in let cmdl1, comp_expr1 = compile_expr e1 in let cmdl2, comp_expr2 = compile_expr e2 in let call_i_plus = Cmd.Call - (call_var, internal_proc, [ comp_expr1; comp_expr2 ], None, None) + (call_var, internal_func, [ comp_expr1; comp_expr2 ], None, None) in ( cmdl1 @ cmdl2 @ [ @@ -150,11 +151,11 @@ let rec compile_expr ?(proc_name = "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 - ?(proc_name = "main") - ?(is_func_body = false) + ?(fname = "main") + ?(is_pure_fun_def = false) (lexpr : WLExpr.t) : string list * Asrt.t * Expr.t = - let gen_str = Generators.gen_str proc_name in - let compile_lexpr = compile_lexpr ~proc_name ~is_func_body in + let gen_str = Generators.gen_str fname in + let compile_lexpr = compile_lexpr ~fname ~is_pure_fun_def in let expr_pname_of_binop b = WBinOp.( match b with @@ -166,8 +167,9 @@ let rec compile_lexpr | GREATERTHAN -> internal_pred_gt | _ -> failwith - (Format.asprintf "Binop %a does not correspond to an internal proc" - WBinOp.pp b)) + (Format.asprintf + "Binop %a does not correspond to an internal function" WBinOp.pp + b)) in let is_internal_pred = WBinOp.( @@ -178,7 +180,7 @@ let rec compile_lexpr WLExpr.( match get lexpr with | LVal v -> ([], [], Expr.Lit (compile_val v)) - | PVar x when is_func_body -> ([], [], Expr.LVar x) + | PVar x when is_pure_fun_def -> ([], [], Expr.LVar x) | PVar x -> ([], [], Expr.PVar x) | LVar x -> ([], [], Expr.LVar x) | LBinOp (e1, WBinOp.NEQ, e2) -> @@ -188,8 +190,10 @@ let rec compile_lexpr 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 && not is_func_body -> + | LBinOp (e1, b, e2) when is_internal_pred b && not is_pure_fun_def -> (* Operator corresponds to pointer arithmetics *) + (* Functions are pure, so can't create global assertions *) + (* TODO: functions don't support pointer arithmetic *) let lout = gen_str sgvar in let internal_pred = expr_pname_of_binop b in let gvars1, asrtl1, comp_expr1 = compile_lexpr e1 in @@ -244,7 +248,7 @@ let rec compile_lexpr ( List.concat gvars, List.concat asrtsl, Expr.ConstructorApp (n, comp_exprs) ) - | LFuncApp (n, l) -> + | LPureFunApp (n, l) -> let gvars, asrtsl, comp_exprs = list_split_3 (List.map compile_lexpr l) in @@ -261,10 +265,10 @@ let rec compile_lexpr Expr.Cases (comp_le, comp_cs) )) (* TODO: compile_lformula should return also the list of created existentials *) -let rec compile_lformula ?(proc_name = "main") formula : Asrt.t * Expr.t = - let gen_str = Generators.gen_str proc_name in - let compile_lformula = compile_lformula ~proc_name in - let compile_lexpr = compile_lexpr ~proc_name in +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 -> ([], Expr.true_) @@ -310,11 +314,11 @@ let rec compile_lformula ?(proc_name = "main") formula : Asrt.t * Expr.t = (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 ?(proc_name = "main") asser : string list * Asrt.t = - let compile_lassert = compile_lassert ~proc_name in - let gen_str = Generators.gen_str proc_name in - let compile_lexpr = compile_lexpr ~proc_name in - let compile_lformula = compile_lformula ~proc_name in +let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = + let compile_lassert = compile_lassert ~fname in + let gen_str = Generators.gen_str fname in + let compile_lexpr = compile_lexpr ~fname in + let compile_lformula = compile_lformula ~fname in let gil_add e k = (* builds GIL expression that is e + k *) let k_e = Expr.int k in @@ -418,10 +422,10 @@ let rec compile_lassert ?(proc_name = "main") asser : string list * Asrt.t = let al, f = compile_lformula lf in ([], Asrt.Pure f :: al)) -let rec compile_lcmd ?(proc_name = "main") lcmd = - let compile_lassert = compile_lassert ~proc_name in - let compile_lcmd = compile_lcmd ~proc_name in - let compile_lexpr = compile_lexpr ~proc_name in +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 build_assert existentials lasrts = match lasrts with | [] -> None @@ -479,11 +483,11 @@ let rec compile_lcmd ?(proc_name = "main") lcmd = (None, LCmd.SL (SLCmd.SepAssert (comp_la, exs @ lb))) | Invariant _ -> failwith "Invariant is not before a loop." -let compile_inv_and_while ~proc_name ~while_stmt ~invariant = +let compile_inv_and_while ~proc_name:fname ~while_stmt ~invariant = (* FIXME: Variables that are in the invariant but not existential might be wrong. *) let loopretvar = "loopretvar__" in - let gen_str = Generators.gen_str proc_name in - let loop_proc_name = gen_str (proc_name ^ "_loop") in + let gen_str = Generators.gen_str fname in + let loop_fname = gen_str (fname ^ "_loop") in let while_loc = WStmt.get_loc while_stmt in let invariant_loc = WLCmd.get_loc invariant in let inv_asrt, inv_exs, inv_variant = @@ -534,7 +538,7 @@ let compile_inv_and_while ~proc_name ~while_stmt ~invariant = in Hashtbl.of_seq (List.to_seq (var_subst @ lvar_subst)) in - let loop_proc = + let loop_funct = let guard_loc = WExpr.get_loc guard in let post_guard = WLAssert.make @@ -575,15 +579,15 @@ let compile_inv_and_while ~proc_name ~while_stmt ~invariant = (* FIGURE OUT VARIANT *) variant = inv_variant; spid = Generators.gen_id (); - proc_name = loop_proc_name; - proc_params = vars; + fname = loop_fname; + fparams = vars; sploc = while_loc; existentials = None; } in let pvars = List.map (fun x -> WExpr.make (Var x) while_loc) vars in let rec_call = - WStmt.make (ProcCall (loopretvar, loop_proc_name, pvars, None)) while_loc + WStmt.make (FunCall (loopretvar, loop_fname, pvars, None)) while_loc in let allvars = WExpr.make (WExpr.List pvars) while_loc in let ret_not_rec = WStmt.make (VarAssign (loopretvar, allvars)) while_loc in @@ -592,9 +596,9 @@ let compile_inv_and_while ~proc_name ~while_stmt ~invariant = WStmt.make (If (guard, wcmds @ [ rec_call ], [ ret_not_rec ])) while_loc; ] in - WProc. + WFun. { - name = loop_proc_name; + name = loop_fname; params = vars; body; spec = Some spec; @@ -608,7 +612,7 @@ let compile_inv_and_while ~proc_name ~while_stmt ~invariant = let call_cmd = Cmd.Call ( retv, - Lit (String loop_proc_name), + Lit (String loop_fname), List.map (fun x -> Expr.PVar x) vars, None, None ) @@ -636,20 +640,19 @@ let compile_inv_and_while ~proc_name ~while_stmt ~invariant = | [] -> List.rev acc in let annot_call_while = - { annot_while with nest_kind = Some (LoopBody loop_proc_name) } + { annot_while with nest_kind = Some (LoopBody loop_fname) } in let lab_cmds = (annot_call_while, None, call_cmd) :: map_reassign_vars [] reassign_vars in - (lab_cmds, loop_proc) + (lab_cmds, loop_funct) -let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl - = +let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = (* create generator that works in the context of this function *) - let compile_expr = compile_expr ~proc_name in - let compile_lcmd = compile_lcmd ~proc_name in - let compile_list = compile_stmt_list ~proc_name in - let gen_str = Generators.gen_str proc_name in + let compile_expr = compile_expr ~fname in + let compile_lcmd = compile_lcmd ~fname in + let compile_list = compile_stmt_list ~fname in + let gen_str = Generators.gen_str fname in let gil_expr_of_str s = Expr.Lit (Literal.String s) in let get_or_create_lab cmdl pre = match cmdl with @@ -672,16 +675,18 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl | { snode = Logic invariant; _ } :: while_stmt :: rest when WLCmd.is_inv invariant && WStmt.is_while while_stmt && !Gillian.Utils.Config.current_exec_mode = Verification -> - let cmds, fct = compile_inv_and_while ~proc_name ~while_stmt ~invariant in - let comp_rest, new_procs = compile_list rest in - (cmds @ comp_rest, fct :: new_procs) + let cmds, fct = + compile_inv_and_while ~proc_name:fname ~while_stmt ~invariant + in + let comp_rest, new_functions = compile_list rest in + (cmds @ comp_rest, fct :: new_functions) | { snode = While _; _ } :: _ when !Gillian.Utils.Config.current_exec_mode = Verification -> failwith "While loop without invariant in Verification mode!" | { snode = While (e, sl); sid = sid_while; sloc } :: rest -> let looplab = gen_str loop_lab in let cmdle, guard = compile_expr e in - let comp_body, new_procs = compile_list sl in + let comp_body, new_functions = compile_list sl in let comp_body, bodlab = get_or_create_lab comp_body lbody_lab in let endlab = gen_str end_lab in let annot = @@ -699,19 +704,19 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl let backcmd_lab = (annot_hidden, None, backcmd) in let endcmd = Cmd.Skip in let endcmd_lab = (annot_hidden, Some endlab, endcmd) in - let comp_rest, new_procs_2 = compile_list rest in + let comp_rest, new_functions_2 = compile_list rest in ( [ headcmd_lab ] @ cmdle @ [ loopcmd_lab ] @ comp_body @ [ backcmd_lab; endcmd_lab ] @ comp_rest, - new_procs @ new_procs_2 ) + new_functions @ new_functions_2 ) (* Skip *) | { snode = Skip; sid; sloc } :: rest -> let cmd = Cmd.Skip in let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in - let comp_rest, new_procs = compile_list rest in - ((annot, None, cmd) :: comp_rest, new_procs) + let comp_rest, new_functions = compile_list rest in + ((annot, None, cmd) :: comp_rest, new_functions) (* Variable assignment *) | { snode = VarAssign (v, e); sid; sloc } :: rest -> let cmdle, comp_e = compile_expr e in @@ -719,16 +724,16 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in - let comp_rest, new_procs = compile_list rest in - (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_procs) + let comp_rest, new_functions = compile_list rest in + (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_functions) (* Fresh s-var *) | { snode = Fresh v; sid; sloc } :: rest -> let cmd = Cmd.Logic (LCmd.FreshSVar v) in let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in - let comp_rest, new_procs = compile_list rest in - ((annot, None, cmd) :: comp_rest, new_procs) + let comp_rest, new_functions = compile_list rest in + ((annot, None, cmd) :: comp_rest, new_functions) (* Object Deletion *) | { snode = Dispose e; sid; sloc } :: rest -> let cmdle, comp_e = compile_expr e in @@ -746,7 +751,7 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl let g_var = gen_str gvar in let failcmd = Cmd.Fail ("InvalidBlockPointer", [ comp_e ]) in let cmd = Cmd.LAction (g_var, dispose, [ nth comp_e 0 ]) in - let comp_rest, new_procs = compile_list rest in + let comp_rest, new_functions = compile_list rest in ( cmdle @ [ (annot, None, testcmd); @@ -754,7 +759,7 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl (annot_final, Some ctnlab, cmd); ] @ comp_rest, - new_procs ) + new_functions ) (* Delete e => ce := Ce(e); // (bunch of commands and then assign the result to e) v_get := [getcell](ce[0], ce[1]); @@ -791,8 +796,8 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl (annot_final, None, getvalcmd); ] in - let comp_rest, new_procs = compile_list rest in - (cmdle @ cmds @ comp_rest, new_procs) + let comp_rest, new_functions = compile_list rest in + (cmdle @ cmds @ comp_rest, new_functions) (* x := [e] => ce := Ce(e); // (bunch of commands and then assign the result to ce) @@ -816,10 +821,10 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl let setcmd = Cmd.LAction (v_set, setcell, [ nth e_v_get 0; nth e_v_get 1; comp_e2 ]) in - let comp_rest, new_procs = compile_list rest in + let comp_rest, new_functions = compile_list rest in ( cmdle1 @ cmdle2 @ ((get_annot, None, getcmd) :: (set_annot, None, setcmd) :: comp_rest), - new_procs ) + new_functions ) (* [e1] := e2 => ce1 := Ce(e1); ce2 := Ce(e2); @@ -838,13 +843,13 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl let newcmd = Cmd.LAction (x, alloc, [ Expr.Lit (Literal.Int (Z.of_int k)) ]) in - let comp_rest, new_procs = compile_list rest in - ((annot, None, newcmd) :: comp_rest, new_procs) + let comp_rest, new_functions = compile_list rest in + ((annot, None, newcmd) :: comp_rest, new_functions) (* x := new(k) => x := [alloc](k); // this is already a pointer *) (* Proc call *) - | { snode = ProcCall (x, fn, el, to_bind); sid; sloc } :: rest -> + | { snode = FunCall (x, fn, el, to_bind); sid; sloc } :: rest -> let expr_fn = gil_expr_of_str fn in let cmdles, params = List.split (List.map compile_expr el) in let bindings = @@ -856,10 +861,10 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl let cmd = Cmd.Call (x, expr_fn, params, None, bindings) in let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) - ~nest_kind:(ProcCall fn) () + ~nest_kind:(FunCall fn) () in - let comp_rest, new_procs = compile_list rest in - (List.concat cmdles @ [ (annot, None, cmd) ] @ comp_rest, new_procs) + let comp_rest, new_functions = compile_list rest in + (List.concat cmdles @ [ (annot, None, cmd) ] @ comp_rest, new_functions) (* If-Else bloc *) | { snode = If (e, sl1, sl2); sid; sloc } :: rest -> let annot = @@ -874,8 +879,8 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl { annot with stmt_kind; branch_kind } in let cmdle, guard = compile_expr e in - let comp_sl1, new_procs1 = compile_list sl1 in - let comp_sl2, new_procs2 = compile_list sl2 in + let comp_sl1, new_functions1 = compile_list sl1 in + let comp_sl2, new_functions2 = compile_list sl2 in let endlab = gen_str endif_lab in let comp_sl1, thenlab = get_or_create_lab comp_sl1 then_lab in let comp_sl2, elselab = get_or_create_lab comp_sl2 else_lab in @@ -885,12 +890,12 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl let gotoendcmd_lab = (annot_hidden, None, gotoendcmd) in let endcmd = Cmd.Skip in let endcmd_lab = (annot_hidden, Some endlab, endcmd) in - let comp_rest, new_procs3 = compile_list rest in + let comp_rest, new_functions3 = compile_list rest in ( cmdle @ (ifelsecmd_lab :: comp_sl1) @ (gotoendcmd_lab :: comp_sl2) @ [ endcmd_lab ] @ comp_rest, - new_procs1 @ new_procs2 @ new_procs3 ) + new_functions1 @ new_functions2 @ new_functions3 ) (* Logic commands *) | { snode = Logic lcmd; sid; sloc } :: rest -> let annot = @@ -905,24 +910,24 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl let cmds_with_annot = List.map (fun lcmdp -> (annot, None, Cmd.Logic lcmdp)) lcmds in - let comp_rest, new_procs = compile_list rest in - (cmds_with_annot @ comp_rest, new_procs) + let comp_rest, new_functions = compile_list rest in + (cmds_with_annot @ comp_rest, new_functions) | { snode = Assert e; sid; sloc } :: rest -> let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in let cmdle, comp_e = compile_expr e in let cmd = Cmd.Logic (Assert (BinOp (comp_e, Equal, Expr.true_))) in - let comp_rest, new_procs = compile_list rest in - (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_procs) + let comp_rest, new_functions = compile_list rest in + (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_functions) | { snode = Assume e; sid; sloc } :: rest -> let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in let cmdle, comp_e = compile_expr e in let cmd = Cmd.Logic (Assume (BinOp (comp_e, Equal, Expr.true_))) in - let comp_rest, new_procs = compile_list rest in - (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_procs) + let comp_rest, new_functions = compile_list rest in + (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_functions) | { snode = AssumeType (e, t); sid; sloc } :: rest -> let typ = WType.to_gil t in let annot = @@ -930,19 +935,19 @@ let rec compile_stmt_list ?(proc_name = "main") ?(is_loop_prefix = false) stmtl in let cmdle, comp_e = compile_expr e in let cmd = Cmd.Logic (AssumeType (comp_e, typ)) in - let comp_rest, new_procs = compile_list rest in - (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_procs) + let comp_rest, new_functions = compile_list rest in + (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_functions) let compile_spec - ?(proc_name = "main") - WSpec.{ pre; post; variant; proc_params; existentials; _ } = + ?(fname = "main") + WSpec.{ pre; post; variant; fparams; existentials; _ } = let comp_pre = - let _, comp_pre = compile_lassert ~proc_name pre in + let _, comp_pre = compile_lassert ~fname pre in let loc = WLAssert.get_loc pre |> CodeLoc.to_location in (comp_pre, Some loc) in let comp_post = - let _, comp_post = compile_lassert ~proc_name post in + let _, comp_post = compile_lassert ~fname post in let loc = WLAssert.get_loc post |> CodeLoc.to_location in (comp_post, Some loc) in @@ -966,7 +971,7 @@ let compile_spec Spec.s_init ~ss_label comp_pre [ comp_post ] comp_variant Flag.Normal true in - Spec.init proc_name proc_params [ single_spec ] false false true + Spec.init fname fparams [ single_spec ] false false true let compile_pred filepath pred = let WPred.{ pred_definitions; pred_params; pred_name; pred_ins; pred_loc; _ } @@ -1004,19 +1009,24 @@ let compile_pred filepath pred = pred_nounfold = pred.pred_nounfold; } -let compile_func +let compile_pure_fun filepath - WFunc.{ func_name; func_params; func_definition; func_loc } = - let types = WType.infer_types_func func_params func_definition in + WPureFun. + { pure_fun_name; pure_fun_params; pure_fun_definition; pure_fun_loc } = + let types = WType.infer_types_pure_fun pure_fun_params pure_fun_definition in let get_wisl_type x = (x, WType.of_variable x types) in - let param_wisl_types = List.map (fun (x, _) -> get_wisl_type x) func_params in + let param_wisl_types = + List.map (fun (x, _) -> get_wisl_type x) pure_fun_params + in let get_gil_type (x, t) = (x, Option.join (Option.map compile_type t)) in let comp_func_params = List.map get_gil_type param_wisl_types in - let _, _, comp_func_def = compile_lexpr ~is_func_body:true func_definition in - let comp_func_loc = Some (CodeLoc.to_location func_loc) in + let _, _, comp_func_def = + compile_lexpr ~is_pure_fun_def:true pure_fun_definition + in + let comp_func_loc = Some (CodeLoc.to_location pure_fun_loc) in Func. { - func_name; + func_name = pure_fun_name; func_source_path = Some filepath; func_loc = comp_func_loc; func_num_params = List.length comp_func_params; @@ -1024,14 +1034,16 @@ let compile_func func_definition = comp_func_def; } -let rec compile_proc +let rec compile_function filepath - WProc.{ name; params; body; spec; return_expr; is_loop_body; _ } = - let lbodylist, new_procs = - compile_stmt_list ~proc_name:name ~is_loop_prefix:is_loop_body body + WFun.{ name; params; body; spec; return_expr; is_loop_body; _ } = + let lbodylist, new_functions = + compile_stmt_list ~fname:name ~is_loop_prefix:is_loop_body body + in + let other_procs = + List.concat (List.map (compile_function filepath) new_functions) in - let other_procs = List.concat (List.map (compile_proc filepath) new_procs) in - let cmdle, comp_ret_expr = compile_expr ~proc_name:name return_expr in + let cmdle, comp_ret_expr = compile_expr ~fname:name return_expr in let ret_annot, final_ret_annot = WAnnot.make_multi ~origin_loc:(CodeLoc.to_location (WExpr.get_loc return_expr)) @@ -1048,7 +1060,7 @@ let rec compile_proc let retcmd = (final_ret_annot, None, Cmd.ReturnNormal) in let lbody_withret = lbodylist @ retassigncmds @ [ retcmd ] in let gil_body = Array.of_list lbody_withret in - let gil_spec = Option.map (compile_spec ~proc_name:name) spec in + let gil_spec = Option.map (compile_spec ~fname:name) spec in Proc. { proc_name = name; @@ -1133,9 +1145,9 @@ let compile_lemma lemma_conclusion; _; } = - let compile_lcmd = compile_lcmd ~proc_name:lemma_name in - let compile_lexpr = compile_lexpr ~proc_name:lemma_name in - let compile_lassert = compile_lassert ~proc_name:lemma_name in + let compile_lcmd = compile_lcmd ~fname:lemma_name in + let compile_lexpr = compile_lexpr ~fname:lemma_name in + let compile_lassert = compile_lassert ~fname:lemma_name in let compile_and_agregate_lcmd lcmd = let a_opt, clcmd = compile_lcmd lcmd in match a_opt with @@ -1227,7 +1239,7 @@ let compile_datatype let compile ~filepath - WProg.{ context; predicates; lemmas; datatypes; functions } = + WProg.{ context; predicates; lemmas; datatypes; pure_functions } = (* stuff useful to build hashtables *) let make_hashtbl get_name deflist = let hashtbl = Hashtbl.create (List.length deflist) in @@ -1242,14 +1254,14 @@ let compile let get_func_name func = func.Func.func_name in let get_datatype_name datatype = datatype.Datatype.datatype_name in (* compile everything *) - let comp_context = List.map (compile_proc filepath) context in + let comp_context = List.map (compile_function filepath) context in let comp_preds = List.map (compile_pred filepath) predicates in let comp_lemmas = List.map (fun lemma -> compile_lemma filepath (preprocess_lemma lemma)) lemmas in - let comp_funcs = List.map (compile_func filepath) functions in + let comp_funcs = List.map (compile_pure_fun filepath) pure_functions in let comp_datatypes = List.map (compile_datatype filepath) datatypes in (* build the hashtables *) let gil_procs = make_hashtbl get_proc_name (List.concat comp_context) in diff --git a/wisl/lib/debugging/wislLifter.ml b/wisl/lib/debugging/wislLifter.ml index 9b9c6b55..212e7d25 100644 --- a/wisl/lib/debugging/wislLifter.ml +++ b/wisl/lib/debugging/wislLifter.ml @@ -64,17 +64,18 @@ struct | `WLCmd lcmd -> Some (Fmt.str "%a" WLCmd.pp lcmd) | `WStmt stmt -> Some (Fmt.str "%a" WStmt.pp_head stmt) | `WLExpr le -> Some (Fmt.str "LEXpr: %a" WLExpr.pp le) - | `WProc f -> Some (Fmt.str "WProc: %s" f.name) + | `WFun f -> Some (Fmt.str "WFun: %s" f.name) | `None -> None | _ -> failwith "get_origin_node_str: Unknown Kind of Node" - let get_proc_call_name exec_data = + let get_fun_call_name exec_data = let cmd = CmdReport.(exec_data.cmd_report.cmd) in match cmd with | Cmd.Call (_, name_expr, _, _, _) -> ( match name_expr with | Expr.Lit (Literal.String name) -> Some name - | _ -> failwith "get_proc_call_name: proc name wasn't a literal expr!") + | _ -> + failwith "get_fun_call_name: function name wasn't a literal expr!") | _ -> None type cmd_data = { @@ -87,7 +88,7 @@ struct loc : string * int; prev : (id * Branch_case.t option) option; callers : id list; - proc_return_label : (string * int) option; + func_return_label : (string * int) option; } [@@deriving yojson] @@ -168,10 +169,10 @@ struct = let- () = match (nest_kind, ends) with - | Some (ProcCall _), [ (Unknown, bdata) ] -> - Some (Ok [ (ProcExitPlaceholder, bdata) ]) - | Some (ProcCall _), _ -> - Some (Error "Unexpected branching in cmd with ProcCall nest!") + | Some (FunCall _), [ (Unknown, bdata) ] -> + Some (Ok [ (FuncExitPlaceholder, bdata) ]) + | Some (FunCall _), _ -> + Some (Error "Unexpected branching in cmd with FunCall nest!") | _ -> None in let counts = Hashtbl.create 0 in @@ -202,8 +203,8 @@ struct | Return _ -> true | _ -> false - let is_loop_end ~is_loop_proc ~proc_name exec_data = - is_loop_proc && get_proc_call_name exec_data = Some proc_name + let is_loop_end ~is_loop_func ~proc_name exec_data = + is_loop_func && get_fun_call_name exec_data = Some proc_name let finish ~exec_data partial = let ({ prev; all_ids; ends; nest_kind; matches; errors; has_return; _ } @@ -334,7 +335,7 @@ struct ~id ~tl_ast ~annot - ~is_loop_proc + ~is_loop_func ~proc_name ~exec_data (partial : partial_data) = @@ -344,7 +345,7 @@ struct match get_origin_node_str tl_ast (Some origin_id) with | Some display -> Ok (display, false) | None -> - if is_loop_end ~is_loop_proc ~proc_name exec_data then + if is_loop_end ~is_loop_func ~proc_name exec_data then Ok ("", true) else Error "Couldn't get display!" in @@ -395,19 +396,19 @@ struct let update_submap ~prog ~(annot : Annot.t) partial = match (partial.nest_kind, annot.nest_kind) with - | None, Some (ProcCall fn) -> + | None, Some (FunCall fn) -> let () = if not (is_fcall_using_spec fn prog) then - partial.nest_kind <- Some (ProcCall fn) + partial.nest_kind <- Some (FunCall fn) in Ok () | None, nest -> partial.nest_kind <- nest; Ok () - | Some _, (None | Some (ProcCall _)) -> Ok () + | Some _, (None | Some (FunCall _)) -> Ok () | Some _, Some _ -> Error "HORROR - multiple submaps!" - let f ~tl_ast ~prog ~prev_id ~is_loop_proc ~proc_name exec_data partial = + let f ~tl_ast ~prog ~prev_id ~is_loop_func ~proc_name exec_data partial = let { id; cmd_report; errors; matches; _ } = exec_data in let annot = CmdReport.(cmd_report.annot) in let** branch_kind, branch_case = @@ -415,7 +416,7 @@ struct in let** () = update_paths ~exec_data ~branch_case ~branch_kind partial in let** () = - update_canonical_cmd_info ~id ~tl_ast ~annot ~exec_data ~is_loop_proc + update_canonical_cmd_info ~id ~tl_ast ~annot ~exec_data ~is_loop_func ~proc_name partial in let** () = update_submap ~prog ~annot partial in @@ -456,7 +457,7 @@ struct ~tl_ast ~prog ~get_prev - ~is_loop_proc + ~is_loop_func ~proc_name ~prev_id exec_data = @@ -466,7 +467,7 @@ struct in Hashtbl.replace partials exec_data.id partial; let result = - update ~tl_ast ~prog ~prev_id ~is_loop_proc ~proc_name exec_data partial + update ~tl_ast ~prog ~prev_id ~is_loop_func ~proc_name exec_data partial |> Result_utils.or_else (fun e -> failwith ~exec_data ~partial ~partials e) in @@ -486,10 +487,10 @@ struct tl_ast : tl_ast; [@to_yojson fun _ -> `Null] partial_cmds : Partial_cmds.t; map : map; - mutable is_loop_proc : bool; + mutable is_loop_func : bool; prog : (annot, int) Prog.t; [@to_yojson fun _ -> `Null] - proc_return_map : (id, string * int ref) Hashtbl.t; - mutable proc_return_count : int; + func_return_map : (id, string * int ref) Hashtbl.t; + mutable func_return_count : int; } [@@deriving to_yojson] @@ -531,11 +532,11 @@ struct ]) ("WislLifter.insert_new_cmd: " ^ msg) - let new_proc_return_label caller_id state = - state.proc_return_count <- state.proc_return_count + 1; - let label = int_to_letters state.proc_return_count in + let new_function_return_label caller_id state = + state.func_return_count <- state.func_return_count + 1; + let label = int_to_letters state.func_return_count in let count = ref 0 in - Hashtbl.add state.proc_return_map caller_id (label, count); + Hashtbl.add state.func_return_map caller_id (label, count); (label, count) let update_caller_branches ~caller_id ~cont_id (label, ix) state = @@ -544,8 +545,8 @@ struct let new_next = match node.next with | Some (Branch nexts) -> - let nexts = List.remove_assoc ProcExitPlaceholder nexts in - let case = Case (ProcExit label, ix) in + let nexts = List.remove_assoc FuncExitPlaceholder nexts in + let case = Case (FuncExit label, ix) in let bdata = (cont_id, None) in let nexts = nexts @ [ (case, (None, bdata)) ] in Ok (Some (Branch nexts)) @@ -571,16 +572,16 @@ struct Fmt.error "update_caller_branches - caller %a not found" pp_id caller_id - let resolve_proc_branches ~state finished_partial = + let resolve_func_branches ~state finished_partial = let Partial_cmds.{ all_ids; next_kind; callers; has_return; _ } = finished_partial in match (next_kind, has_return, callers) with | Zero, true, caller_id :: _ -> let label, count = - match Hashtbl.find_opt state.proc_return_map caller_id with + match Hashtbl.find_opt state.func_return_map caller_id with | Some (label, count) -> (label, count) - | None -> new_proc_return_label caller_id state + | None -> new_function_return_label caller_id state in incr count; let label = (label, !count) in @@ -589,7 +590,7 @@ struct Ok (Some label) | _ -> Ok None - let make_new_cmd ~proc_return_label finished_partial = + let make_new_cmd ~func_return_label finished_partial = let Partial_cmds. { all_ids; @@ -616,7 +617,7 @@ struct submap; prev; callers; - proc_return_label; + func_return_label; loc; } in @@ -711,7 +712,7 @@ struct let- () = insert_to_empty_map ~state ~prev ~stack_direction new_cmd in match (stack_direction, prev) with | _, None -> Error "inserting to non-empty map with no prev!" - | Some In, Some (parent_id, Some ProcExitPlaceholder) + | Some In, Some (parent_id, Some FuncExitPlaceholder) | Some In, Some (parent_id, None) -> let new_cmd = new_cmd |> with_prev None in let++ () = insert_as_submap ~state ~parent_id new_cmd.data.id in @@ -723,12 +724,12 @@ struct new_cmd | Some (Out prev_id), Some (inner_prev_id, _) -> let** case = - let proc_return_label = - (get_exn state.map inner_prev_id).data.proc_return_label + let func_return_label = + (get_exn state.map inner_prev_id).data.func_return_label in - match proc_return_label with - | Some (label, ix) -> Ok (Case (ProcExit label, ix)) - | None -> Error "stepping out without proc return label!" + match func_return_label with + | Some (label, ix) -> Ok (Case (FuncExit label, ix)) + | None -> Error "stepping out without function return label!" in let new_cmd = new_cmd |> with_prev (Some (prev_id, Some case)) in let++ () = insert_as_next ~state ~prev_id ~case new_cmd.data.id in @@ -739,10 +740,10 @@ struct let Partial_cmds.{ id; all_ids; prev; stack_direction; _ } = finished_partial in - let** proc_return_label = - resolve_proc_branches ~state finished_partial + let** func_return_label = + resolve_func_branches ~state finished_partial in - let new_cmd = make_new_cmd ~proc_return_label finished_partial in + let new_cmd = make_new_cmd ~func_return_label finished_partial in let** new_cmd = insert_cmd ~state ~prev ~stack_direction new_cmd in let () = insert state.map ~id ~all_ids new_cmd in let () = @@ -756,9 +757,9 @@ struct let insert_new_cmd = Insert_new_cmd.f module Init_or_handle = struct - (** Loop body procs have some boilerplate we want to ignore. + (** Loop body functions have some boilerplate we want to ignore. This would normally be [Hidden], but we want to only consider - the true case of the proc *) + the true case of the function *) let handle_loop_prefix exec_data = let { cmd_report; id; _ } = exec_data in let annot = CmdReport.(cmd_report.annot) in @@ -799,19 +800,19 @@ struct let f ~state ?prev_id ?gil_case (exec_data : exec_data) = let- () = let+ id, case = handle_loop_prefix exec_data in - state.is_loop_proc <- true; + state.is_loop_func <- true; Either.Left (id, case) in let gil_case = Option_utils.coalesce gil_case exec_data.cmd_report.branch_case in - let { tl_ast; partial_cmds = partials; is_loop_proc; proc_name; prog; _ } + let { tl_ast; partial_cmds = partials; is_loop_func; proc_name; prog; _ } = state in match let get_prev = get_prev ~state ~gil_case ~prev_id in - Partial_cmds.handle ~partials ~tl_ast ~prog ~get_prev ~is_loop_proc + Partial_cmds.handle ~partials ~tl_ast ~prog ~get_prev ~is_loop_func ~proc_name ~prev_id exec_data with | Finished finished -> @@ -980,10 +981,10 @@ struct (* If a FinalCmd is in a function call, get the caller ID and the relevant branch case for stepping forward, while checking that it actually exists. *) - let get_next_from_end state { callers; proc_return_label; _ } = + let get_next_from_end state { callers; func_return_label; _ } = let* caller_id = List_utils.hd_opt callers in - let* label, ix = proc_return_label in - let case = Case (ProcExit label, ix) in + let* label, ix = func_return_label in + let case = Case (FuncExit label, ix) in let* _ = match (get_exn state.map caller_id).next with | Some (Branch nexts) -> List.assoc_opt case nexts @@ -996,8 +997,8 @@ struct match (node.next, case, node.data.submap) with | (None | Some (Single _)), Some _, _ -> failwith "HORROR - tried to step case for non-branch cmd" - | ( Some (Branch [ (ProcExitPlaceholder, _) ]), - Some ProcExitPlaceholder, + | ( Some (Branch [ (FuncExitPlaceholder, _) ]), + Some FuncExitPlaceholder, Submap submap_id ) -> Either.left submap_id | Some (Single (None, _)), None, _ -> let id = List.hd (List.rev node.data.all_ids) in @@ -1101,7 +1102,7 @@ struct (* Bodge: step in if on func exit placeholder *) let- () = match (case, cmd.data.submap) with - | Some ProcExitPlaceholder, Submap submap_id -> + | Some FuncExitPlaceholder, Submap submap_id -> Some (submap_id, Debugger_utils.Step) | _ -> None in @@ -1124,8 +1125,8 @@ struct let () = match (node.next, node.data.submap) with | Some (Branch nexts), (NoSubmap | Proc _) -> - if List.mem_assoc ProcExitPlaceholder nexts then - step state id (Some ProcExitPlaceholder) |> ignore + if List.mem_assoc FuncExitPlaceholder nexts then + step state id (Some FuncExitPlaceholder) |> ignore | _ -> () in let node = get_exn state.map id in @@ -1140,7 +1141,7 @@ struct let node = get_exn state.map id in (* Failsafe in case of error paths in submap *) match node.next with - | Some (Branch [ (ProcExitPlaceholder, _) ]) -> (id, Debugger_utils.Step) + | Some (Branch [ (FuncExitPlaceholder, _) ]) -> (id, Debugger_utils.Step) | _ -> step_branch state id None let step_back state id = @@ -1202,10 +1203,10 @@ struct tl_ast; partial_cmds; map = Exec_map.make (); - is_loop_proc = false; + is_loop_func = false; prog; - proc_return_map = Hashtbl.create 0; - proc_return_count = 0; + func_return_map = Hashtbl.create 0; + func_return_count = 0; } in let finish_init () = diff --git a/wisl/lib/syntax/WProc.ml b/wisl/lib/syntax/WFun.ml similarity index 87% rename from wisl/lib/syntax/WProc.ml rename to wisl/lib/syntax/WFun.ml index 262b64c9..14344356 100644 --- a/wisl/lib/syntax/WProc.ml +++ b/wisl/lib/syntax/WFun.ml @@ -20,14 +20,14 @@ let add_spec f pre post variant loc = let spec = WSpec.make pre post variant f.name f.params loc in { f with spec = Some spec; floc = loc } -let procs_called f = WStmt.procs_called_by_list f.body +let functions_called f = WStmt.functions_called_by_list f.body let has_spec f = Option.is_some f.spec let get_by_id id f = let stmt_list_visitor = list_visitor_builder WStmt.get_by_id id in let aux_spec = Option.fold ~some:(WSpec.get_by_id id) ~none:`None in let expr_getter = WExpr.get_by_id id in - let self_or_none = if f.fid = id then `WProc f else `None in + let self_or_none = if f.fid = id then `WFun f else `None in let return_getter (ret_exp : WExpr.t) = if WExpr.get_id ret_exp = id then `Return ret_exp else `None in @@ -42,7 +42,8 @@ let pp fmt f = match f.spec with | None -> Format.fprintf fmt - "@[@[proc %s(%a)@] {@,%a;@,@[return@ %a@]@]@\n}" f.name + "@[@[function %s(%a)@] {@,%a;@,@[return@ %a@]@]@\n}" + f.name (WPrettyUtils.pp_list Format.pp_print_string) f.params pp_list_stmt f.body WExpr.pp f.return_expr | Some spec -> diff --git a/wisl/lib/syntax/WProc.mli b/wisl/lib/syntax/WFun.mli similarity index 92% rename from wisl/lib/syntax/WProc.mli rename to wisl/lib/syntax/WFun.mli index 104b1c62..8ea4ea7a 100644 --- a/wisl/lib/syntax/WProc.mli +++ b/wisl/lib/syntax/WFun.mli @@ -17,7 +17,7 @@ val get_spec : t -> WSpec.t option val add_spec : t -> WLAssert.t -> WLAssert.t -> WLExpr.t option -> CodeLoc.t -> t -val procs_called : t -> string list +val functions_called : t -> string list val has_spec : t -> bool val get_by_id : @@ -26,7 +26,7 @@ val get_by_id : [> `None | `Return of WExpr.t | `WExpr of WExpr.t - | `WProc of t + | `WFun of t | `WLAssert of WLAssert.t | `WLCmd of WLCmd.t | `WLExpr of WLExpr.t diff --git a/wisl/lib/syntax/WFunc.ml b/wisl/lib/syntax/WFunc.ml deleted file mode 100644 index d98c404a..00000000 --- a/wisl/lib/syntax/WFunc.ml +++ /dev/null @@ -1,6 +0,0 @@ -type t = { - func_name : string; - func_params : (string * WType.t option) list; - func_definition : WLExpr.t; - func_loc : CodeLoc.t; -} diff --git a/wisl/lib/syntax/WFunc.mli b/wisl/lib/syntax/WFunc.mli deleted file mode 100644 index d98c404a..00000000 --- a/wisl/lib/syntax/WFunc.mli +++ /dev/null @@ -1,6 +0,0 @@ -type t = { - func_name : string; - func_params : (string * WType.t option) list; - func_definition : WLExpr.t; - func_loc : CodeLoc.t; -} diff --git a/wisl/lib/syntax/WLExpr.ml b/wisl/lib/syntax/WLExpr.ml index 227c8184..6d973ff7 100644 --- a/wisl/lib/syntax/WLExpr.ml +++ b/wisl/lib/syntax/WLExpr.ml @@ -9,7 +9,7 @@ type tt = | LLSub of t * t * t | LEList of t list | LESet of t list - | LFuncApp of string * t list (* Function application *) + | LPureFunApp of string * t list (* Pure function application *) | LConstructorApp of string * t list (* Constructor application *) | LCases of t * case list @@ -52,7 +52,7 @@ let rec get_by_id id lexpr = | LUnOp (_, lep) -> getter lep | LEList lel -> list_visitor lel | LESet lel -> list_visitor lel - | LFuncApp (_, lel) | LConstructorApp (_, lel) -> list_visitor lel + | LPureFunApp (_, lel) | LConstructorApp (_, lel) -> list_visitor lel | _ -> `None in let self_or_none = if get_id lexpr = id then `WLExpr lexpr else `None in @@ -76,7 +76,7 @@ let rec pp fmt lexpr = | LESet lel -> WPrettyUtils.pp_list ~pre:(format_of_string "@[-{") ~suf:(format_of_string "}-@]") pp fmt lel - | LFuncApp (name, lel) -> + | LPureFunApp (name, lel) -> Format.fprintf fmt "@[%s" name; WPrettyUtils.pp_list ~pre:(format_of_string "(") ~suf:(format_of_string ")@]") ~empty:(format_of_string "@]") pp fmt lel @@ -112,8 +112,8 @@ let rec substitution (subst : (string, tt) Hashtbl.t) (e : t) : t = | LLSub (e1, e2, e3) -> LLSub (f e1, f e2, f e3) | LEList le -> LEList (List.map f le) | LESet le -> LESet (List.map f le) - | LFuncApp (name, le) | LConstructorApp (name, le) -> - LFuncApp (name, List.map f le) + | LPureFunApp (name, le) | LConstructorApp (name, le) -> + LPureFunApp (name, List.map f le) | LCases (e, cs) -> let cs = List.map (fun c -> { c with lexpr = f c.lexpr }) cs in LCases (e, cs) diff --git a/wisl/lib/syntax/WLExpr.mli b/wisl/lib/syntax/WLExpr.mli index be562c66..59af814e 100644 --- a/wisl/lib/syntax/WLExpr.mli +++ b/wisl/lib/syntax/WLExpr.mli @@ -7,7 +7,7 @@ type tt = | LLSub of t * t * t | LEList of t list | LESet of t list - | LFuncApp of string * t list + | LPureFunApp of string * t list | LConstructorApp of string * t list | LCases of t * case list diff --git a/wisl/lib/syntax/WProg.ml b/wisl/lib/syntax/WProg.ml index 0d8bebb9..b78705cb 100644 --- a/wisl/lib/syntax/WProg.ml +++ b/wisl/lib/syntax/WProg.ml @@ -1,18 +1,18 @@ open VisitorUtils type t = { - context : WProc.t list; + context : WFun.t list; predicates : WPred.t list; lemmas : WLemma.t list; datatypes : WDatatype.t list; - functions : WFunc.t list; + pure_functions : WPureFun.t list; } let get_context p = p.context let pp_context = WPrettyUtils.pp_list ~sep:(format_of_string "@,@,") - ~suf:(format_of_string "@]@.") WProc.pp + ~suf:(format_of_string "@]@.") WFun.pp let pp fmt = function | prog -> Format.fprintf fmt "%a" pp_context prog.context @@ -21,32 +21,32 @@ module StringSet = Set.Make (String) module StringMap = Map.Make (String) let never_called_during_symb prog = - let pmap = + let fmap = List.fold_left - (fun map p -> StringMap.add (WProc.get_name p) p map) + (fun map f -> StringMap.add (WFun.get_name f) f map) StringMap.empty prog.context in - let allp = StringSet.of_list (List.map WProc.get_name prog.context) in + let allf = StringSet.of_list (List.map WFun.get_name prog.context) in let has_spec pname = - let p = StringMap.find pname pmap in - WProc.has_spec p + let f = StringMap.find pname fmap in + WFun.has_spec f in - let have_spec = StringSet.filter has_spec allp in + let have_spec = StringSet.filter has_spec allf in let rec find_fixed_point compare f a = let b = f a in if compare a b = 0 then b else find_fixed_point compare f b in - let fold_proc pname set = - let p = StringMap.find_opt pname pmap in + let fold_fun fname set = + let f = StringMap.find_opt fname fmap in StringSet.union set - (StringSet.of_list (Option.fold ~some:WProc.procs_called ~none:[] p)) + (StringSet.of_list (Option.fold ~some:WFun.functions_called ~none:[] f)) in - let step set = StringSet.fold fold_proc set set in + let step set = StringSet.fold fold_fun set set in let called = find_fixed_point StringSet.compare step have_spec in - let not_called_names = StringSet.diff allp called in + let not_called_names = StringSet.diff allf called in let not_called = List.map - (fun x -> StringMap.find x pmap) + (fun x -> StringMap.find x fmap) (StringSet.elements not_called_names) in not_called @@ -58,40 +58,39 @@ let get_pred prog name = in aux prog.predicates -let get_proc prog name = +let get_fun prog name = let rec aux = function | [] -> None - | p :: r -> if String.equal (WProc.get_name p) name then Some p else aux r + | p :: r -> if String.equal (WFun.get_name p) name then Some p else aux r in aux prog.context -let get_by_id ?(proc_name = None) prog id = +let get_by_id ?(fname = None) prog id = match id with | None -> `None | Some id -> ( - let aux_proc = list_visitor_builder WProc.get_by_id id in - let aux_pred = list_visitor_builder WPred.get_by_id id in - let aux_lemma = list_visitor_builder WLemma.get_by_id id in - let proc_getter = WProc.get_by_id id in - match proc_name with + let aux_f = list_visitor_builder WFun.get_by_id id in + let aux_p = list_visitor_builder WPred.get_by_id id in + let aux_l = list_visitor_builder WLemma.get_by_id id in + let fun_getter = WFun.get_by_id id in + match fname with | None -> - aux_proc prog.context - |>> (aux_pred, prog.predicates) - |>> (aux_lemma, prog.lemmas) - | Some p -> ( - match List.find_opt (fun pp -> pp.WProc.name = p) prog.context with + aux_f prog.context |>> (aux_p, prog.predicates) + |>> (aux_l, prog.lemmas) + | Some f -> ( + match List.find_opt (fun ff -> ff.WFun.name = f) prog.context with | None -> `None - | Some ff -> proc_getter ff)) + | Some ff -> fun_getter ff)) -let get_proc_name_of_element prog id = - let is_in_proc p = - match WProc.get_by_id id p with +let get_function_name_of_element prog id = + let is_in_function f = + match WFun.get_by_id id f with | `None -> false | _ -> true in - let rec find_p l = + let rec find_f l = match l with - | p :: r -> if is_in_proc p then WProc.get_name p else find_p r + | f :: r -> if is_in_function f then WFun.get_name f else find_f r | _ -> "" in - find_p prog.context + find_f prog.context diff --git a/wisl/lib/syntax/WProg.mli b/wisl/lib/syntax/WProg.mli index ac8b5dcb..ac32cf07 100644 --- a/wisl/lib/syntax/WProg.mli +++ b/wisl/lib/syntax/WProg.mli @@ -1,21 +1,21 @@ type t = { - context : WProc.t list; + context : WFun.t list; predicates : WPred.t list; lemmas : WLemma.t list; datatypes : WDatatype.t list; - functions : WFunc.t list; + pure_functions : WPureFun.t list; } -val get_context : t -> WProc.t list +val get_context : t -> WFun.t list val get_by_id : - ?proc_name:string option -> + ?fname:string option -> t -> int option -> [> `None | `Return of WExpr.t | `WExpr of WExpr.t - | `WProc of WProc.t + | `WFun of WFun.t | `WLAssert of WLAssert.t | `WLCmd of WLCmd.t | `WLExpr of WLExpr.t @@ -26,8 +26,8 @@ val get_by_id : | `WStmt of WStmt.t ] val get_pred : t -> string -> WPred.t option -val get_proc : t -> string -> WProc.t option -val never_called_during_symb : t -> WProc.t list -val pp_context : Format.formatter -> WProc.t list -> unit +val get_fun : t -> string -> WFun.t option +val never_called_during_symb : t -> WFun.t list +val pp_context : Format.formatter -> WFun.t list -> unit val pp : Format.formatter -> t -> unit -val get_proc_name_of_element : t -> int -> string +val get_function_name_of_element : t -> int -> string diff --git a/wisl/lib/syntax/WPureFun.ml b/wisl/lib/syntax/WPureFun.ml new file mode 100644 index 00000000..4d95649b --- /dev/null +++ b/wisl/lib/syntax/WPureFun.ml @@ -0,0 +1,6 @@ +type t = { + pure_fun_name : string; + pure_fun_params : (string * WType.t option) list; + pure_fun_definition : WLExpr.t; + pure_fun_loc : CodeLoc.t; +} diff --git a/wisl/lib/syntax/WPureFun.mli b/wisl/lib/syntax/WPureFun.mli new file mode 100644 index 00000000..4d95649b --- /dev/null +++ b/wisl/lib/syntax/WPureFun.mli @@ -0,0 +1,6 @@ +type t = { + pure_fun_name : string; + pure_fun_params : (string * WType.t option) list; + pure_fun_definition : WLExpr.t; + pure_fun_loc : CodeLoc.t; +} diff --git a/wisl/lib/syntax/WSpec.ml b/wisl/lib/syntax/WSpec.ml index 7c700a69..71214181 100644 --- a/wisl/lib/syntax/WSpec.ml +++ b/wisl/lib/syntax/WSpec.ml @@ -6,9 +6,9 @@ type t = { variant : WLExpr.t option; existentials : (string * string list) option; spid : int; - proc_name : string; + fname : string; (* name of the function *) - proc_params : string list; + fparams : string list; (* parameters of the function *) sploc : CodeLoc.t; } @@ -23,14 +23,14 @@ let get_by_id id spec = let self_or_none = if get_id spec = id then `WSpec spec else `None in self_or_none |>> (lassert_getter, spec.pre) |>> (lassert_getter, spec.post) -let make ?existentials pre post variant proc_name proc_params loc = +let make ?existentials pre post variant fname fparams loc = { pre; post; variant; spid = Generators.gen_id (); sploc = loc; - proc_name; - proc_params; + fname; + fparams; existentials; } diff --git a/wisl/lib/syntax/WSpec.mli b/wisl/lib/syntax/WSpec.mli index be9ec065..4a60c441 100644 --- a/wisl/lib/syntax/WSpec.mli +++ b/wisl/lib/syntax/WSpec.mli @@ -4,8 +4,8 @@ type t = { variant : WLExpr.t option; (** Variant *) existentials : (string * string list) option; (** Existentials in the spec *) spid : int; (** Unique identifier of AST el *) - proc_name : string; (** Name of the function the spec is attached to *) - proc_params : string list; + fname : string; (** Name of the function the spec is attached to *) + fparams : string list; (** Parameters of the function the spec is attached to *) sploc : CodeLoc.t; (** Code location of the spec *) } diff --git a/wisl/lib/syntax/WStmt.ml b/wisl/lib/syntax/WStmt.ml index e5c29065..f3e63499 100644 --- a/wisl/lib/syntax/WStmt.ml +++ b/wisl/lib/syntax/WStmt.ml @@ -8,7 +8,7 @@ type tt = | Dispose of WExpr.t | Lookup of string * WExpr.t (* x := [e] *) | Update of WExpr.t * WExpr.t (* [e] := [e] *) - | ProcCall of string * string * WExpr.t list * (string * string list) option + | FunCall of string * string * WExpr.t list * (string * string list) option (* The last bit is only for internal use *) | While of WExpr.t * t list | If of WExpr.t * t list * t list @@ -40,7 +40,7 @@ and pp fmt stmt = | Lookup (v, e) -> Format.fprintf fmt "@[%s := [%a]@]" v WExpr.pp e | Update (e1, e2) -> Format.fprintf fmt "@[[%a] := %a@]" WExpr.pp e1 WExpr.pp e2 - | ProcCall (v, f, el, _) -> + | FunCall (v, f, el, _) -> Format.fprintf fmt "@[%s := %s(%a)@]" v f (WPrettyUtils.pp_list WExpr.pp) el @@ -78,11 +78,10 @@ let is_unfold s = | Logic lcmd when WLCmd.is_unfold lcmd -> true | _ -> false -let procs_called_by_list sl = +let functions_called_by_list sl = let rec aux already = function | [] -> already - | { snode = ProcCall (_, proc_name, _, _); _ } :: r -> - aux (proc_name :: already) r + | { snode = FunCall (_, fname, _, _); _ } :: r -> aux (fname :: already) r | { snode = While (_, slp); _ } :: r -> aux (aux already slp @ already) r | { snode = If (_, slp1, slp2); _ } :: r -> aux (aux already slp1 @ aux already slp2 @ already) r @@ -104,7 +103,7 @@ let rec get_by_id id stmt = | Assume e | AssumeType (e, _) -> expr_getter e | Update (e1, e2) -> expr_getter e1 |>> (expr_getter, e2) - | ProcCall (_, _, el, _) -> expr_list_visitor el + | FunCall (_, _, el, _) -> expr_list_visitor el | While (e, sl) -> expr_getter e |>> (list_visitor, sl) | If (e, sl1, sl2) -> expr_getter e |>> (list_visitor, sl1) |>> (list_visitor, sl2) diff --git a/wisl/lib/syntax/WStmt.mli b/wisl/lib/syntax/WStmt.mli index 79baa3c6..be905165 100644 --- a/wisl/lib/syntax/WStmt.mli +++ b/wisl/lib/syntax/WStmt.mli @@ -6,7 +6,7 @@ type tt = | Dispose of WExpr.t (** free(e) *) | Lookup of string * WExpr.t (** x := [e] *) | Update of WExpr.t * WExpr.t (** [e] := [e] *) - | ProcCall of string * string * WExpr.t list * (string * string list) option + | FunCall of string * string * WExpr.t list * (string * string list) option (** x := f(e1, ..., en), last bit should be ignored *) | While of WExpr.t * t list (** while (e) \{ s \} *) | If of WExpr.t * t list * t list (** if (e) \{ s \} else \{ s \} *) @@ -39,6 +39,6 @@ val get_by_id : | `WLFormula of WLFormula.t | `WStmt of t ] -val procs_called_by_list : t list -> string list +val functions_called_by_list : t list -> string list (* val check_consistency : t list -> CodeLoc.t -> unit *) diff --git a/wisl/lib/syntax/WType.ml b/wisl/lib/syntax/WType.ml index d1b113d5..529c4103 100644 --- a/wisl/lib/syntax/WType.ml +++ b/wisl/lib/syntax/WType.ml @@ -135,7 +135,7 @@ let rec infer_logic_expr knownp lexpr = TypeMap.add bare_lexpr WList (List.fold_left infer_logic_expr knownp lel) | LESet lel -> TypeMap.add bare_lexpr WSet (List.fold_left infer_logic_expr knownp lel) - | LFuncApp (_, lel) -> List.fold_left infer_logic_expr knownp lel + | LPureFunApp (_, lel) -> List.fold_left infer_logic_expr knownp lel | LConstructorApp (n, lel) -> TypeMap.add bare_lexpr (WDatatype n) (List.fold_left infer_logic_expr knownp lel) @@ -243,7 +243,7 @@ let infer_types_pred (params : (string * t option) list) assert_list = in result -let infer_types_func (params : (string * t option) list) func_def = +let infer_types_pure_fun (params : (string * t option) list) pure_fun_def = let join _ param_t inferred_t = match (param_t, inferred_t) with | Some param_t, Some inferred_t when param_t = inferred_t -> Some param_t @@ -259,5 +259,5 @@ let infer_types_func (params : (string * t option) list) func_def = | Some t -> TypeMap.add (PVar x) t map) TypeMap.empty params in - let infer_on_func_def = infer_logic_expr TypeMap.empty func_def in - TypeMap.merge join infers_on_params infer_on_func_def + let infer_on_def = infer_logic_expr TypeMap.empty pure_fun_def in + TypeMap.merge join infers_on_params infer_on_def diff --git a/wisl/lib/syntax/WType.mli b/wisl/lib/syntax/WType.mli index 3c3951b1..1ba7dd84 100644 --- a/wisl/lib/syntax/WType.mli +++ b/wisl/lib/syntax/WType.mli @@ -26,4 +26,4 @@ val of_variable : string -> t TypeMap.t -> t option val infer_types_pred : (string * t option) list -> WLAssert.t list -> t TypeMap.t -val infer_types_func : (string * t option) list -> WLExpr.t -> t TypeMap.t +val infer_types_pure_fun : (string * t option) list -> WLExpr.t -> t TypeMap.t diff --git a/wisl/lib/utils/wBranchCase.ml b/wisl/lib/utils/wBranchCase.ml index 55def35c..d8b80279 100644 --- a/wisl/lib/utils/wBranchCase.ml +++ b/wisl/lib/utils/wBranchCase.ml @@ -1,15 +1,15 @@ type kind = IfElseKind | WhileLoopKind [@@deriving yojson] -type case = IfElse of bool | WhileLoop of bool | ProcExit of string | Unknown +type case = IfElse of bool | WhileLoop of bool | FuncExit of string | Unknown [@@deriving yojson] -type t = Case of case * int | ProcExitPlaceholder [@@deriving yojson] +type t = Case of case * int | FuncExitPlaceholder [@@deriving yojson] let pp fmt = function | Case (Unknown, i) -> Fmt.pf fmt "%d" i | Case ((IfElse b | WhileLoop b), -1) -> Fmt.pf fmt "%B" b | Case ((IfElse b | WhileLoop b), i) -> Fmt.pf fmt "%B - %d" b i - | Case (ProcExit label, i) -> Fmt.pf fmt "%s-%d" label i - | ProcExitPlaceholder -> Fmt.pf fmt "" + | Case (FuncExit label, i) -> Fmt.pf fmt "%s-%d" label i + | FuncExitPlaceholder -> Fmt.pf fmt "" let display = Fmt.str "%a" pp diff --git a/wisl/lib/utils/wErrors.ml b/wisl/lib/utils/wErrors.ml index 3eab32b8..2bb07843 100644 --- a/wisl/lib/utils/wErrors.ml +++ b/wisl/lib/utils/wErrors.ml @@ -16,7 +16,7 @@ type t = { code : string; severity : severity; related_information : related_info_t list; - proc_name : string; + function_name : string; } type res_t = (unit, t) result @@ -28,8 +28,8 @@ type error_code_t = | SyntaxError | MissingResource | UnconsistentStmtBloc - | ProcNotVerified - | UndefinedProc + | FunctionNotVerified + | UndefinedFunction | UndefinedLemma | MissingInvariant @@ -40,8 +40,8 @@ let str_error_code = function | SyntaxError -> "SyntaxError" | MissingResource -> "MissingResource" | UnconsistentStmtBloc -> "UnconsistentStmtBloc" - | ProcNotVerified -> "ProcNotVerified" - | UndefinedProc -> "UndefinedProc" + | FunctionNotVerified -> "FunctionNotVerified" + | UndefinedFunction -> "UndefinedFunction" | UndefinedLemma -> "UndefinedLemma" | MissingInvariant -> "MissingInvariant" @@ -53,21 +53,21 @@ let get_errors results = in get_errors' [] results -let build_consistency_error message range proc_name = +let build_consistency_error message range function_name = let code = str_error_code UnconsistentStmtBloc in let severity = SevError in let related_information = [] in - { message; range; code; severity; related_information; proc_name } + { message; range; code; severity; related_information; function_name } -let build_warning_not_called range proc_name = - let code = str_error_code ProcNotVerified in +let build_warning_not_called range function_name = + let code = str_error_code FunctionNotVerified in let message = "This function is never verified because it has no specification and is \ never called from a function that is verified" in let severity = SevWarning in let related_information = [] in - { code; message; severity; related_information; range; proc_name } + { code; message; severity; related_information; range; function_name } let build_warning_invariant range = let code = str_error_code MissingInvariant in @@ -77,7 +77,7 @@ let build_warning_invariant range = in let severity = SevWarning in let related_information = [] in - { code; message; severity; related_information; range; proc_name = "" } + { code; message; severity; related_information; range; function_name = "" } let build_err_string error_code id loc message = Format.sprintf "%s;%i;%s;%s" diff --git a/wisl/lib/utils/wErrors.mli b/wisl/lib/utils/wErrors.mli index 33d9573d..f4fba6a0 100644 --- a/wisl/lib/utils/wErrors.mli +++ b/wisl/lib/utils/wErrors.mli @@ -9,7 +9,7 @@ type t = { code : string; severity : severity; related_information : related_info_t list; - proc_name : string; + function_name : string; } type error_code_t = @@ -19,8 +19,8 @@ type error_code_t = | SyntaxError | MissingResource | UnconsistentStmtBloc - | ProcNotVerified - | UndefinedProc + | FunctionNotVerified + | UndefinedFunction | UndefinedLemma | MissingInvariant From 98e2a1c5fadcf063fb0a502c735111e121c19df1 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Fri, 2 May 2025 13:54:38 +0100 Subject: [PATCH 34/37] Minor refactoring in WISL --- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 2 +- wisl/lib/syntax/WFun.ml | 2 +- wisl/lib/syntax/WProg.ml | 4 ++-- wisl/lib/utils/wErrors.ml | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index eeb0e836..998fef57 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -848,7 +848,7 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = (* x := new(k) => x := [alloc](k); // this is already a pointer *) - (* Proc call *) + (* Function call *) | { snode = FunCall (x, fn, el, to_bind); sid; sloc } :: rest -> let expr_fn = gil_expr_of_str fn in let cmdles, params = List.split (List.map compile_expr el) in diff --git a/wisl/lib/syntax/WFun.ml b/wisl/lib/syntax/WFun.ml index 14344356..0e846de4 100644 --- a/wisl/lib/syntax/WFun.ml +++ b/wisl/lib/syntax/WFun.ml @@ -48,7 +48,7 @@ let pp fmt f = f.params pp_list_stmt f.body WExpr.pp f.return_expr | Some spec -> Format.fprintf fmt - "@[{ %a }@]@[@[proc %s(%a)@] {@,\ + "@[{ %a }@]@[@[function %s(%a)@] {@,\ %a;@,\ @[return@ %a@]@]@\n\ }@\n\ diff --git a/wisl/lib/syntax/WProg.ml b/wisl/lib/syntax/WProg.ml index b78705cb..35711572 100644 --- a/wisl/lib/syntax/WProg.ml +++ b/wisl/lib/syntax/WProg.ml @@ -27,8 +27,8 @@ let never_called_during_symb prog = StringMap.empty prog.context in let allf = StringSet.of_list (List.map WFun.get_name prog.context) in - let has_spec pname = - let f = StringMap.find pname fmap in + let has_spec fname = + let f = StringMap.find fname fmap in WFun.has_spec f in let have_spec = StringSet.filter has_spec allf in diff --git a/wisl/lib/utils/wErrors.ml b/wisl/lib/utils/wErrors.ml index 2bb07843..569dd1e9 100644 --- a/wisl/lib/utils/wErrors.ml +++ b/wisl/lib/utils/wErrors.ml @@ -41,7 +41,7 @@ let str_error_code = function | MissingResource -> "MissingResource" | UnconsistentStmtBloc -> "UnconsistentStmtBloc" | FunctionNotVerified -> "FunctionNotVerified" - | UndefinedFunction -> "UndefinedFunction" + | UndefinedFunction -> "UndefinedFonction" | UndefinedLemma -> "UndefinedLemma" | MissingInvariant -> "MissingInvariant" From a919b0d9bb5515edaaa55894c478f0cc8d6232f1 Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Fri, 2 May 2025 19:14:12 +0100 Subject: [PATCH 35/37] Fixed parsing issues --- wisl/examples/SLL_adt.wisl | 84 +++++++++++++------------- wisl/lib/ParserAndCompiler/WParser.mly | 31 +++++----- 2 files changed, 56 insertions(+), 59 deletions(-) diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl index b07f4663..07ed3d9d 100644 --- a/wisl/examples/SLL_adt.wisl +++ b/wisl/examples/SLL_adt.wisl @@ -25,71 +25,71 @@ pure function double_length(xs : MyList) { } // -// Standard over-approximating sll predicate with contents +// Standard over-approximating SLL predicate with contents // -predicate sll(+x, vs) { - // Empty sll +predicate SLL(+x, vs) { + // Empty SLL (x == null) * (vs == 'Nil); - // One sll node and the rest - (x -b> #v, #next) * sll(#next, #vs) * + // One SLL node and the rest + (x -b> #v, #next) * SLL(#next, #vs) * (vs == 'Cons(#v, #vs)) } -// 00. Allocating an sll node with the given value +// 00. Allocating an SLL node with the given value { v == #v } -function sll_allocate_node(v){ +function SLL_allocate_node(v){ t := new(2); [t] := v; return t } -{ sll(ret, 'Cons(#v, 'Nil)) } +{ SLL(ret, 'Cons(#v, 'Nil)) } // This incorrect spec should fail to verify { (v == #v) * (u == #u) } -function sll_allocate_node_fails(u, v){ +function SLL_allocate_node_fails(u, v){ t := new(2); [t] := v; return t } -{ sll(ret, 'Cons(#u, 'Nil)) } +{ SLL(ret, 'Cons(#u, 'Nil)) } // -// RECURSIVE sll MANIPULATION +// RECURSIVE SLL MANIPULATION // -// 01. Prepending a given value to a given sll -{ (x == #x) * (k == #k) * sll(#x, #vs) } -function sll_prepend(x, k){ - z := sll_allocate_node(k); +// 01. Prepending a given value to a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #vs) } +function SLL_prepend(x, k){ + z := SLL_allocate_node(k); [z + 1] := x; return z } -{ sll(ret, 'Cons(#k, #vs)) } +{ SLL(ret, 'Cons(#k, #vs)) } // 02. Appending a given value to a given SLL -{ (x == #x) * (k == #k) * sll(#x, #vs) } -function sll_append(x, k){ - if (x = null) { - x := sll_allocate_node(k) +{ (x == #x) * (k == #k) * SLL(#x, #vs) } +function SLL_append(x, k){ + if (x == null) { + x := SLL_allocate_node(k) } else { t := [x + 1]; - z := sll_append(t, k); + z := SLL_append(t, k); [x + 1] := z }; return x } -{ sll(ret, append(#vs, #k)) } +{ SLL(ret, append(#vs, #k)) } // 06. Calculating the length of a given SLL -{ (x == #x) * sll(#x, #vs) } -function sll_length(x) { +{ (x == #x) * SLL(#x, #vs) } +function SLL_length(x) { n := 0; - if (x = null){ + if (x == null){ n := 0 } else { t := [x + 1]; - n := sll_length(t); + n := SLL_length(t); n := 1 + n }; return n @@ -97,45 +97,45 @@ function sll_length(x) { { ret == length(#vs) } // This spec fails to verify -{ (x == #x) * sll(#x, #vs) } -function sll_length_fails(x) { +{ (x == #x) * SLL(#x, #vs) } +function SLL_length_fails(x) { n := 0; - if (x = null){ + if (x == null){ n := 0 } else { t := [x + 1]; - n := sll_length(t); + n := SLL_length(t); n := 1 + n }; return n } { ret == double_length(#vs) } -// 05. Copying a given sll -{ (x == #x) * sll(#x, #vs) } -function sll_copy(x){ +// 05. Copying a given SLL +{ (x == #x) * SLL(#x, #vs) } +function SLL_copy(x){ y := null; - if (not (x = null)) { + if (x != null) { k := [x]; - y := sll_allocate_node(k); + y := SLL_allocate_node(k); t := [x + 1]; - z := sll_copy(t); + z := SLL_copy(t); [y + 1] := z } else { skip }; return y } -{ sll(#x, #vs) * sll(ret, #vs) } +{ SLL(#x, #vs) * SLL(ret, #vs) } -// 10. Freeing a given sll -{ (x == #x) * sll(#x, #vs) } -function sll_free(x){ - if (x = null) { +// 10. Freeing a given SLL +{ (x == #x) * SLL(#x, #vs) } +function SLL_free(x){ + if (x != null) { skip } else { t := [x + 1]; - z := sll_free(t); + z := SLL_free(t); free(x) }; return null diff --git a/wisl/lib/ParserAndCompiler/WParser.mly b/wisl/lib/ParserAndCompiler/WParser.mly index 080d12de..a4b82e3c 100644 --- a/wisl/lib/ParserAndCompiler/WParser.mly +++ b/wisl/lib/ParserAndCompiler/WParser.mly @@ -102,6 +102,7 @@ %type expression %type expr_list %type logic_command +%type logic_assertion_top_level %type logic_assertion %type value_with_loc %type unop_with_loc @@ -128,7 +129,7 @@ prog: prog, configs } assert_only: - | la = logic_assertion; EOF { la } + | la = logic_assertion_top_level; EOF { la } definitions: | (* empty *) { ([], [], [], [], [], []) } @@ -159,8 +160,8 @@ config: id, value, loc } fct_with_specs: - | lstart = LCBRACE; pre = logic_assertion; RCBRACE; variant = option(with_variant_def); f = fct; LCBRACE; - post = logic_assertion; lend = RCBRACE + | lstart = LCBRACE; pre = logic_assertion_top_level; RCBRACE; variant = option(with_variant_def); f = fct; LCBRACE; + post = logic_assertion_top_level; lend = RCBRACE { let loc = CodeLoc.merge lstart lend in WFun.add_spec f pre post variant loc } | f = fct { f } @@ -372,7 +373,7 @@ lemma: | lstart = LEMMA; lname = IDENTIFIER; LCBRACE; STATEMENT; COLON; FORALL lemma_params = var_list; DOT; - lemma_hypothesis = logic_assertion; VDASH; lemma_conclusion = logic_assertion; + lemma_hypothesis = logic_assertion_top_level; VDASH; lemma_conclusion = logic_assertion_top_level; lemma_variant = option(variant_def); lemma_proof = option(proof_def); lend = RCBRACE @@ -402,7 +403,7 @@ proof_def: predicate: | lstart = PREDICATE; pred_nounfold = option(NOUNFOLD); lpname = IDENTIFIER; LBRACE; params_ins = separated_list(COMMA, pred_param_ins); RBRACE; LCBRACE; - pred_definitions = separated_nonempty_list(SEMICOLON, logic_assertion); + pred_definitions = separated_nonempty_list(SEMICOLON, logic_assertion_top_level); lend = RCBRACE; { let (_, pred_name) = lpname in let (pred_params, ins) : (string * WType.t option) list * bool list = List.split params_ins in @@ -470,13 +471,13 @@ logic_command: { let bare_lcmd = WLCmd.LogicIf (g, thencmds, []) in let loc = CodeLoc.merge lstart lend in WLCmd.make bare_lcmd loc } - | lstart = ASSERT; lbopt = option(bindings_with_loc); a = logic_assertion; + | lstart = ASSERT; lbopt = option(bindings_with_loc); a = logic_assertion_top_level; { let lend = WLAssert.get_loc a in let (_, b) = Option.value ~default:(lstart, []) lbopt in let loc = CodeLoc.merge lstart lend in let bare_lcmd = WLCmd.Assert (a, b) in WLCmd.make bare_lcmd loc } - | lstart = INVARIANT; lbopt = option(bindings_with_loc); a = logic_assertion; variant = option(with_variant_def); + | lstart = INVARIANT; lbopt = option(bindings_with_loc); a = logic_assertion_top_level; variant = option(with_variant_def); { let lend = WLAssert.get_loc a in let (_, b) = Option.value ~default:(lstart, []) lbopt in let loc = CodeLoc.merge lstart lend in @@ -504,6 +505,12 @@ wand: ((lname, largs), (rname, rargs), loc) } +logic_assertion_top_level: + | formula = logic_expression; + { let bare_assert = WLAssert.LPure formula in + let loc = WLExpr.get_loc formula in + WLAssert.make bare_assert loc } + | la = logic_assertion; { la } logic_assertion: | lstart = LBRACE; la = logic_assertion; lend = RBRACE; @@ -554,16 +561,6 @@ logic_assertion: { let bare_assert = WLAssert.LPure formula in let loc = CodeLoc.merge lstart lend in WLAssert.make bare_assert loc } - | loc = TRUE - { let bare_lexpr = WLExpr.LVal (WVal.Bool true) in - let lexpr = WLExpr.make bare_lexpr loc in - let bare_assert = WLAssert.LPure lexpr in - WLAssert.make bare_assert loc } - | loc = FALSE - { let bare_lexpr = WLExpr.LVal (WVal.Bool false) in - let lexpr = WLExpr.make bare_lexpr loc in - let bare_assert = WLAssert.LPure lexpr in - WLAssert.make bare_assert loc } From ef14bf7c32ad1cdaff4ae4ee80e7b4ac3c72066c Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Sun, 4 May 2025 01:15:44 +0100 Subject: [PATCH 36/37] Fixed bugs. --- GillianCore/engine/Abstraction/MP.ml | 22 ++- GillianCore/engine/FOLogic/smt.ml | 22 ++- .../engine/general_semantics/eSubst.ml | 44 +++-- wisl/examples/SLL_adt.wisl | 180 ++++++++++++++++-- wisl/lib/syntax/WLExpr.ml | 4 +- 5 files changed, 238 insertions(+), 34 deletions(-) diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index 595d1125..c7641ffb 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -297,8 +297,26 @@ let rec learn_expr | BinOp _ -> [] (* Can we learn anything from Exists? *) | Exists _ | ForAll _ -> [] - (* TODO: Constructors aren't invertible unless we have destructors *) - | ConstructorApp _ -> [] + | ConstructorApp (cname, le) -> + let num_fields = List.length le in + let param_str = Printf.sprintf "param-%d" in + let base_expr_nth_field n = + let case = + (cname, List.init num_fields param_str, Expr.LVar (param_str n)) + in + Expr.Cases (base_expr, [ case ]) + in + let le_with_base_exprs = + List.mapi (fun i e -> (e, base_expr_nth_field i)) le + in + L.( + verbose (fun m -> + m "List of expressions: %a" + Fmt.( + brackets + (list ~sep:semi (parens (pair ~sep:comma Expr.pp Expr.pp)))) + le_with_base_exprs)); + learn_expr_list kb le_with_base_exprs (* Function application isn't invertible *) | FuncApp _ -> [] | Cases _ -> [] diff --git a/GillianCore/engine/FOLogic/smt.ml b/GillianCore/engine/FOLogic/smt.ml index b1a6126c..bae76434 100644 --- a/GillianCore/engine/FOLogic/smt.ml +++ b/GillianCore/engine/FOLogic/smt.ml @@ -1028,8 +1028,9 @@ let rec encode_logical_expression ((pat, extend_wrap encoded), encoded)) cs) in + let fallback = (PVar "_", extend_wrap undefined_encoding) in let>-- _ = encs in - extended_wrapped (match_datatype le_native cs) + extended_wrapped (match_datatype le_native (cs @ [ fallback ])) | ConstructorApp (name, les) -> ( let param_typs = Datatype_env.get_constructor_field_types name in match param_typs with @@ -1129,6 +1130,24 @@ let lvars_as_list_elements ?(exclude = SS.empty) (assertions : Expr.Set.t) : Containers.SS.union acc inner) Containers.SS.empty les + method! visit_Cases (exclude, is_in_list) le cs = + let cases = + List.fold_left + (fun acc (_, bs, e) -> + (* Treat binders as though they are in a list *) + let binders = + bs + |> List.filter (fun b -> not (Containers.SS.mem b exclude)) + |> List.to_seq + in + let binders = Containers.SS.add_seq binders acc in + let inner = self#visit_expr (exclude, is_in_list) e in + Containers.SS.union binders inner) + Containers.SS.empty cs + in + let scrutinee = self#visit_expr (exclude, is_in_list) le in + Containers.SS.union scrutinee cases + method! visit_LVar (exclude, is_in_list) x = if is_in_list && not (Containers.SS.mem x exclude) then Containers.SS.singleton x @@ -1184,6 +1203,7 @@ let encode_functions (fs : Func.t list) : sexp list = let param_types = List.map (fun (x, t) -> + let x = sanitize_identifier x in match t with | Some t -> (x, Encoding.native_sort_of_type t) | None -> (x, t_gil_ext_literal)) diff --git a/GillianCore/engine/general_semantics/eSubst.ml b/GillianCore/engine/general_semantics/eSubst.ml index 73db6e83..b788dd50 100644 --- a/GillianCore/engine/general_semantics/eSubst.ml +++ b/GillianCore/engine/general_semantics/eSubst.ml @@ -455,6 +455,18 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct @return Expression resulting from the substitution. No fresh locations are created. *) let rec subst_in_expr_opt (subst : t) (le : Expr.t) : Expr.t option = + let subst_in_bound_expr bs e = + (* We use Hashtbl.add so that we can later remove the binding and recover the old one! *) + List.iter + (fun x -> + let lvar = Expr.LVar x in + let lvar_e = Option.get (Val.from_expr lvar) in + Hashtbl.add subst lvar lvar_e) + bs; + let e' = subst_in_expr_opt subst e in + List.iter (fun x -> Hashtbl.remove subst (Expr.LVar x)) bs; + e' + in let f_before (le : Expr.t) = match (le : Expr.t) with | LVar _ | ALoc _ | PVar _ -> @@ -462,29 +474,25 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct | (UnOp (LstLen, PVar _) | UnOp (LstLen, LVar _)) when mem subst le -> (Option.map Val.to_expr (get subst le), false) | Exists (bt, e) -> - (* We use Hashtbl.add so that we can later remove the binding and recover the old one! *) - List.iter - (fun (x, _) -> - let lvar = Expr.LVar x in - let lvar_e = Option.get (Val.from_expr lvar) in - Hashtbl.add subst lvar lvar_e) - bt; - let e' = subst_in_expr_opt subst e in - List.iter (fun (x, _) -> Hashtbl.remove subst (Expr.LVar x)) bt; + let e' = subst_in_bound_expr (List.map fst bt) e in let result = Option.map (fun e' -> Expr.Exists (bt, e')) e' in (result, false) | ForAll (bt, e) -> - (* We use Hashtbl.add so that we can later remove the binding and recover the old one! *) - List.iter - (fun (x, _) -> - let lvar = Expr.LVar x in - let lvar_e = Option.get (Val.from_expr lvar) in - Hashtbl.add subst lvar lvar_e) - bt; - let e' = subst_in_expr_opt subst e in - List.iter (fun (x, _) -> Hashtbl.remove subst (Expr.LVar x)) bt; + let e' = subst_in_bound_expr (List.map fst bt) e in let result = Option.map (fun e' -> Expr.ForAll (bt, e')) e' in (result, false) + | Cases (le, cs) -> ( + let cs = + List_utils.flaky_map + (fun (c, bs, e) -> + let e' = subst_in_bound_expr bs e in + Option.map (fun e' -> (c, bs, e')) e') + cs + in + let le = subst_in_expr_opt subst le in + match (cs, le) with + | Some cs, Some le -> (Some (Expr.Cases (le, cs)), false) + | _ -> (None, false)) | _ -> (Some le, true) in Expr.map_opt f_before None le diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl index 07ed3d9d..ab070c65 100644 --- a/wisl/examples/SLL_adt.wisl +++ b/wisl/examples/SLL_adt.wisl @@ -17,6 +17,13 @@ pure function length(xs : MyList) { } } +pure function concatenate(xs : MyList, ys : MyList) { + case xs { + Nil -> ys; + Cons(x, xs) -> 'Cons(x, concatenate(xs, ys)) + } +} + pure function double_length(xs : MyList) { case xs { Nil -> 0; @@ -24,6 +31,35 @@ pure function double_length(xs : MyList) { } } +pure function reverse(xs : MyList) { + case xs { + Nil -> 'Nil; + Cons(x, xs) -> append(reverse(xs), x) + } +} + +pure function list_member(xs : MyList, x) { + case xs { + Nil -> false; + Cons(y, ys) -> (y == x) || list_member(ys, x) + } +} + +// +// Lemma: List membership concat +// +lemma list_member_concat { + statement: + forall vs1, vs2, v. + (list_member(vs1, v) == #r1) * (list_member(vs2, v) == #r2) |- (list_member(concatenate(vs1, vs2), v) == (#r1 || #r2)) + + proof: + if (vs1 != 'Nil) { + assert {bind: #nv1, #nvs1, #nr1} ('Cons(#nv1, #nvs1) == vs1) * (list_member(#nvs1, v) == #nr1); + apply list_member_concat(#nvs1, vs2, v) + } +} + // // Standard over-approximating SLL predicate with contents // @@ -81,6 +117,51 @@ function SLL_append(x, k){ } { SLL(ret, append(#vs, #k)) } +// 03. Appending a given SLL node to a given SLL +{ (x == #x) * (y == #y) * SLL(#x, #vs) * SLL(#y, 'Cons(#vy, 'Nil)) } +function SLL_append_node(x, y) { + if (x == null) { + x := y + } else { + t := [x + 1]; + z := SLL_append_node(t, y); + [x + 1] := z + }; + return x +} +{ SLL(ret, append(#vs, #vy)) } + +// 04. Concatenating two lists +{(x == #x) * (y == #y) * SLL(#x, #vx) * SLL(#y, #vy) } +function SLL_concat(x, y) { + if (x == null){ + x := y + } else { + t := [x + 1]; + z := SLL_concat(t, y); + [x + 1] := z + }; + return x +} +{ SLL(ret, concatenate(#vx, #vy)) } + +// 05. Copying a given SLL +{ (x == #x) * SLL(#x, #vs) } +function SLL_copy(x){ + y := null; + if (x != null) { + k := [x]; + y := SLL_allocate_node(k); + t := [x + 1]; + z := SLL_copy(t); + [y + 1] := z + } else { + skip + }; + return y +} +{ SLL(#x, #vs) * SLL(ret, #vs) } + // 06. Calculating the length of a given SLL { (x == #x) * SLL(#x, #vs) } function SLL_length(x) { @@ -111,27 +192,104 @@ function SLL_length_fails(x) { } { ret == double_length(#vs) } -// 05. Copying a given SLL -{ (x == #x) * SLL(#x, #vs) } -function SLL_copy(x){ - y := null; +// 07. Reversing a given SLL +{ (x == #x) * SLL(#x, #vs) } +function SLL_reverse(x){ if (x != null) { - k := [x]; - y := SLL_allocate_node(k); t := [x + 1]; - z := SLL_copy(t); - [y + 1] := z + [x + 1] := null; + z := SLL_reverse(t); + y := SLL_append_node(z, x) } else { - skip + y := null }; return y } -{ SLL(#x, #vs) * SLL(ret, #vs) } +{ SLL(ret, reverse(#vs)) } + +// 08. Checking if a given value is in a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #vs) } +function SLL_member(x, k){ + found := false; + if (x == null){ + skip + } else { + v := [x]; + if (v == k){ + found := true + } else { + t := [x + 1]; + found := SLL_member(t, k) + } + }; + return found +} +{ SLL(#x, #vs) * (ret == list_member(#vs, #k)) } + +// 09. Removing a given value from a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #vs) } +function SLL_remove(x, k) { + if (x == null) { + skip + } else { + v := [x]; + next := [x + 1]; + if (v == k){ + free(x); + x := SLL_remove(next, k) + } else { + z := SLL_remove(next, k); + [x + 1] := z + } + }; + return x +} +{ SLL(ret, #nvs) * (list_member(#nvs, #k) == false) } + +// This spec should fail +{ (x == #x) * (k == #k) * SLL(#x, #vs) } +function SLL_remove_fails_1(x, k) { + if (x == null) { + skip + } else { + v := [x]; + next := [x + 1]; + if (v == k){ + free(x); + x := SLL_remove(next, k) + } else { + z := SLL_remove(next, k); + [x + 1] := z + } + }; + return x +} +{ SLL(ret, #nvs) * (list_member(#nvs, #k) == true) } + +// So should this one +{ (x == #x) * (k == #k) * SLL(#x, #vs) } +function SLL_remove_fails_2(x, k) { + if (x == null) { + skip + } else { + v := [x]; + next := [x + 1]; + if (v == k){ + z := SLL_remove(next, k); + [x + 1] := z + } else { + z := SLL_remove(next, k); + [x + 1] := z + } + }; + return x +} +{ SLL(ret, #nvs) * (list_member(#nvs, #k) == false) } // 10. Freeing a given SLL { (x == #x) * SLL(#x, #vs) } function SLL_free(x){ - if (x != null) { + if (x == null) { skip } else { t := [x + 1]; diff --git a/wisl/lib/syntax/WLExpr.ml b/wisl/lib/syntax/WLExpr.ml index a622c8b4..54323f06 100644 --- a/wisl/lib/syntax/WLExpr.ml +++ b/wisl/lib/syntax/WLExpr.ml @@ -124,8 +124,8 @@ let rec substitution (subst : (string, tt) Hashtbl.t) (e : t) : t = | LLSub (e1, e2, e3) -> LLSub (f e1, f e2, f e3) | LEList le -> LEList (List.map f le) | LESet le -> LESet (List.map f le) - | LPureFunApp (name, le) | LConstructorApp (name, le) -> - LPureFunApp (name, List.map f le) + | LPureFunApp (name, le) -> LPureFunApp (name, List.map f le) + | LConstructorApp (name, le) -> LConstructorApp (name, List.map f le) | LCases (e, cs) -> let cs = List.map (fun c -> { c with lexpr = f c.lexpr }) cs in LCases (e, cs) From a75d37e52837bc74f132474536afd57086ba2def Mon Sep 17 00:00:00 2001 From: Shiva Tamil Kumaran Date: Sun, 4 May 2025 23:48:08 +0100 Subject: [PATCH 37/37] Fixed bug in SMT encoding --- GillianCore/engine/FOLogic/smt.ml | 398 +++++++++++++++++++++--------- wisl/examples/SLL_adt.wisl | 16 ++ 2 files changed, 299 insertions(+), 115 deletions(-) diff --git a/GillianCore/engine/FOLogic/smt.ml b/GillianCore/engine/FOLogic/smt.ml index bae76434..de0838fe 100644 --- a/GillianCore/engine/FOLogic/smt.ml +++ b/GillianCore/engine/FOLogic/smt.ml @@ -528,14 +528,28 @@ module Encoding = struct in { enc' with consts; extra_asrts } - let get_native ~accessor { expr; kind; _ } = + let get_native + ~accessor + ~recognizer + ~typ + ({ expr; kind; extra_asrts; _ } as enc) : t = (* No additional check is performed on native type, it should be already type checked *) - match kind with - | Native _ -> expr - | Simple_wrapped -> accessor expr - | Extended_wrapped -> - accessor (Ext_lit_operations.Gil_sing_elem.access expr) + let expr, guards = + match kind with + | Native _ -> (expr, []) + | Simple_wrapped -> (accessor expr, [ recognizer expr ]) + | Extended_wrapped -> + let simply_wrapped = Ext_lit_operations.Gil_sing_elem.access expr in + ( accessor simply_wrapped, + [ + recognizer simply_wrapped; + Ext_lit_operations.Gil_sing_elem.recognize expr; + ] ) + in + let extra_asrts = guards @ extra_asrts in + let kind = Native typ in + { enc with expr; extra_asrts; kind } let simply_wrapped = make ~kind:Simple_wrapped let extended_wrapped = make ~kind:Extended_wrapped @@ -543,10 +557,10 @@ module Encoding = struct (** Takes a value either natively encoded or simply wrapped and returns a value simply wrapped. Careful: do not use wrap with a a set, as they cannot be simply wrapped *) - let simple_wrap { expr; kind; _ } = + let simple_wrap ({ expr; kind; extra_asrts; _ } as enc) = let open Lit_operations in match kind with - | Simple_wrapped -> expr + | Simple_wrapped -> enc | Native typ -> let construct = match typ with @@ -566,47 +580,74 @@ module Encoding = struct Fmt.failwith "Cannot simple-wrap value of type %s" (Gil_syntax.Type.str typ) in - construct expr - | Extended_wrapped -> Ext_lit_operations.Gil_sing_elem.access expr - - let extend_wrap e = - match e.kind with - | Extended_wrapped -> e.expr - | Native SetType -> Ext_lit_operations.Gil_set.construct (simple_wrap e) - | _ -> Ext_lit_operations.Gil_sing_elem.construct (simple_wrap e) - - let get_num = get_native ~accessor:Lit_operations.Num.access - let get_int = get_native ~accessor:Lit_operations.Int.access - let get_bool = get_native ~accessor:Lit_operations.Bool.access - let get_list = get_native ~accessor:Lit_operations.List.access + { enc with expr = construct expr; kind = Simple_wrapped } + | Extended_wrapped -> + let guard = Ext_lit_operations.Gil_sing_elem.recognize expr in + let extra_asrts = guard :: extra_asrts in + let expr = Ext_lit_operations.Gil_sing_elem.access expr in + { enc with extra_asrts; expr; kind = Simple_wrapped } - let get_set { kind; expr; _ } = + let extend_wrap ({ expr; kind; _ } as enc) = + match kind with + | Extended_wrapped -> enc + | Native SetType -> + let expr = Ext_lit_operations.Gil_set.construct expr in + { enc with expr; kind = Extended_wrapped } + | _ -> + let ({ expr; _ } as enc) = simple_wrap enc in + let expr = Ext_lit_operations.Gil_sing_elem.construct expr in + { enc with expr; kind = Extended_wrapped } + + let get_num = + get_native ~accessor:Lit_operations.Num.access + ~recognizer:Lit_operations.Num.recognize ~typ:NumberType + + let get_int = + get_native ~accessor:Lit_operations.Int.access + ~recognizer:Lit_operations.Int.recognize ~typ:IntType + + let get_bool = + get_native ~accessor:Lit_operations.Bool.access + ~recognizer:Lit_operations.Bool.recognize ~typ:BooleanType + + let get_list = + get_native ~accessor:Lit_operations.List.access + ~recognizer:Lit_operations.List.recognize ~typ:ListType + + let get_set ({ kind; expr; extra_asrts; _ } as enc) : t = match kind with - | Native SetType -> expr - | Extended_wrapped -> Ext_lit_operations.Gil_set.access expr + | Native SetType -> enc + | Extended_wrapped -> + let guard = Ext_lit_operations.Gil_set.recognize expr in + let extra_asrts = guard :: extra_asrts in + let expr = Ext_lit_operations.Gil_set.access expr in + let kind = Native SetType in + { enc with extra_asrts; expr; kind } | _ -> failwith "wrong encoding of set" - let get_string = get_native ~accessor:Lit_operations.String.access + let get_string = + get_native ~accessor:Lit_operations.String.access + ~recognizer:Lit_operations.String.recognize ~typ:StringType let get_native_of_type ~(typ : Type.t) = let open Lit_operations in - let accessor = + let accessor, recognizer = match typ with - | IntType -> Int.access - | NumberType -> Num.access - | StringType -> String.access - | ObjectType -> Loc.access - | TypeType -> Type.access - | BooleanType -> Bool.access - | ListType -> List.access + | IntType -> (Int.access, Int.recognize) + | NumberType -> (Num.access, Num.recognize) + | StringType -> (String.access, String.recognize) + | ObjectType -> (Loc.access, Loc.recognize) + | TypeType -> (Type.access, Type.recognize) + | BooleanType -> (Bool.access, Bool.recognize) + | ListType -> (List.access, List.recognize) | DatatypeType name -> let (module U : Variant.Unary) = get_datatype_lit_variant name in - U.access + (U.access, U.recognize) | UndefinedType | NullType | EmptyType | NoneType | SetType -> Fmt.failwith "Cannot get native value of type %s" (Gil_syntax.Type.str typ) in - get_native ~accessor + get_native ~accessor ~recognizer ~typ end let typeof_simple e = @@ -700,7 +741,8 @@ let rec encode_lit (lit : Literal.t) : Encoding.t = | Loc l -> encode_string l >- ObjectType | Type t -> encode_type t >- TypeType | LList lits -> - let args = List.map (fun lit -> simple_wrap (encode_lit lit)) lits in + let>-- args = List.map (fun lit -> simple_wrap (encode_lit lit)) lits in + let args = List.map (fun arg -> arg.expr) args in list args >- ListType | Constant _ -> raise (Exceptions.Unsupported "Z3 encoding: constants") with Failure msg -> @@ -710,23 +752,24 @@ let encode_equality (p1 : Encoding.t) (p2 : Encoding.t) : Encoding.t = let open Encoding in let>- _ = p1 in let>- _ = p2 in - let res = - match (p1.kind, p2.kind) with - | Native t1, Native t2 when Type.equal t1 t2 -> - if Type.equal t1 BooleanType then - if is_true p1.expr then p2.expr - else if is_true p2.expr then p1.expr - else eq p1.expr p2.expr - else eq p1.expr p2.expr - | Simple_wrapped, Simple_wrapped | Extended_wrapped, Extended_wrapped -> - eq p1.expr p2.expr - | Native _, Native _ -> failwith "incompatible equality, type error!" - | Simple_wrapped, Native _ | Native _, Simple_wrapped -> - eq (simple_wrap p1) (simple_wrap p2) - | Extended_wrapped, _ | _, Extended_wrapped -> - eq (extend_wrap p1) (extend_wrap p2) - in - res >- BooleanType + match (p1.kind, p2.kind) with + | Native t1, Native t2 when Type.equal t1 t2 -> + if Type.equal t1 BooleanType then + if is_true p1.expr then p2.expr >- BooleanType + else if is_true p2.expr then p1.expr >- BooleanType + else eq p1.expr p2.expr >- BooleanType + else eq p1.expr p2.expr >- BooleanType + | Simple_wrapped, Simple_wrapped | Extended_wrapped, Extended_wrapped -> + eq p1.expr p2.expr >- BooleanType + | Native _, Native _ -> failwith "incompatible equality, type error!" + | Simple_wrapped, Native _ | Native _, Simple_wrapped -> + let>- p1 = simple_wrap p1 in + let>- p2 = simple_wrap p2 in + eq p1.expr p2.expr >- BooleanType + | Extended_wrapped, _ | _, Extended_wrapped -> + let>- p1 = extend_wrap p1 in + let>- p2 = extend_wrap p2 in + eq p1.expr p2.expr >- BooleanType let encode_binop (op : BinOp.t) (p1 : Encoding.t) (p2 : Encoding.t) : Encoding.t = @@ -739,37 +782,96 @@ let encode_binop (op : BinOp.t) (p1 : Encoding.t) (p2 : Encoding.t) : Encoding.t It is expected that values of unknown type are already wrapped into their constructors. *) match op with - | IPlus -> num_add (get_int p1) (get_int p2) >- IntType - | IMinus -> num_sub (get_int p1) (get_int p2) >- IntType - | ITimes -> num_mul (get_int p1) (get_int p2) >- IntType - | IDiv -> num_div (get_int p1) (get_int p2) >- IntType - | IMod -> num_mod (get_int p1) (get_int p2) >- IntType - | ILessThan -> num_lt (get_int p1) (get_int p2) >- BooleanType - | ILessThanEqual -> num_leq (get_int p1) (get_int p2) >- BooleanType - | FPlus -> num_add (get_num p1) (get_num p2) >- NumberType - | FMinus -> num_sub (get_num p1) (get_num p2) >- NumberType - | FTimes -> num_mul (get_num p1) (get_num p2) >- NumberType - | FDiv -> num_div (get_num p1) (get_num p2) >- NumberType - | FLessThan -> num_lt (get_num p1) (get_num p2) >- BooleanType - | FLessThanEqual -> num_leq (get_num p1) (get_num p2) >- BooleanType + | IPlus -> + let>- p1 = get_int p1 in + let>- p2 = get_int p2 in + num_add p1.expr p2.expr >- IntType + | IMinus -> + let>- p1 = get_int p1 in + let>- p2 = get_int p2 in + num_sub p1.expr p2.expr >- IntType + | ITimes -> + let>- p1 = get_int p1 in + let>- p2 = get_int p2 in + num_mul p1.expr p2.expr >- IntType + | IDiv -> + let>- p1 = get_int p1 in + let>- p2 = get_int p2 in + num_div p1.expr p2.expr >- IntType + | IMod -> + let>- p1 = get_int p1 in + let>- p2 = get_int p2 in + num_mod p1.expr p2.expr >- IntType + | ILessThan -> + let>- p1 = get_int p1 in + let>- p2 = get_int p2 in + num_lt p1.expr p2.expr >- IntType + | ILessThanEqual -> + let>- p1 = get_int p1 in + let>- p2 = get_int p2 in + num_leq p1.expr p2.expr >- IntType + | FPlus -> + let>- p1 = get_num p1 in + let>- p2 = get_num p2 in + num_add p1.expr p2.expr >- NumberType + | FMinus -> + let>- p1 = get_num p1 in + let>- p2 = get_num p2 in + num_sub p1.expr p2.expr >- NumberType + | FTimes -> + let>- p1 = get_num p1 in + let>- p2 = get_num p2 in + num_mul p1.expr p2.expr >- NumberType + | FDiv -> + let>- p1 = get_num p1 in + let>- p2 = get_num p2 in + num_div p1.expr p2.expr >- NumberType + | FLessThan -> + let>- p1 = get_num p1 in + let>- p2 = get_num p2 in + num_lt p1.expr p2.expr >- NumberType + | FLessThanEqual -> + let>- p1 = get_num p1 in + let>- p2 = get_num p2 in + num_leq p1.expr p2.expr >- NumberType | Equal -> encode_equality p1 p2 - | 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 + | Or -> + let>- p1 = get_bool p1 in + let>- p2 = get_bool p2 in + bool_or p1.expr p2.expr >- BooleanType + | Impl -> + let>- p1 = get_bool p1 in + let>- p2 = get_bool p2 in + bool_implies p1.expr p2.expr >- BooleanType + | And -> + let>- p1 = get_bool p1 in + let>- p2 = get_bool p2 in + bool_and p1.expr p2.expr >- 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 - | SetSub -> set_subset Z3 (get_set p1) (get_set p2) >- BooleanType - | LstNth -> seq_nth (get_list p1) (get_int p2) |> simply_wrapped + let>- p1 = simple_wrap p1 in + let>- p2 = get_set p2 in + set_member Z3 p1.expr p2.expr >- BooleanType + | SetDiff -> + let>- p1 = get_set p1 in + let>- p2 = get_set p2 in + set_difference Z3 p1.expr p2.expr >- SetType + | SetSub -> + let>- p1 = get_set p1 in + let>- p2 = get_set p2 in + set_subset Z3 p1.expr p2.expr >- BooleanType + | LstNth -> + let>- p1 = get_list p1 in + let>- p2 = get_list p2 in + seq_nth p1.expr p2.expr |> simply_wrapped | LstRepeat -> - let x = simple_wrap p1 in - let n = get_int p2 in - RepeatCache.get x n + let>- x = simple_wrap p1 in + let>- n = get_int p2 in + RepeatCache.get x.expr n.expr | StrNth -> - let str' = get_string p1 in - let index' = get_num p2 in - let res = Axiomatised_operations.snth $$ [ str'; index' ] in + let>- str' = get_string p1 in + let>- index' = get_num p2 in + let res = Axiomatised_operations.snth $$ [ str'.expr; index'.expr ] in res >- StringType | FMod | StrLess @@ -802,31 +904,58 @@ let encode_unop ~llen_lvars ~e (op : UnOp.t) le = let open Axiomatised_operations in let>- _ = le in match op with - | IUnaryMinus -> num_neg (get_int le) >- IntType - | FUnaryMinus -> num_neg (get_num le) >- NumberType + | IUnaryMinus -> + let>- le = get_int le in + num_neg le.expr >- IntType + | FUnaryMinus -> + let>- le = get_num le in + num_neg le.expr >- NumberType | LstLen -> (* If we only use an LVar as an argument to llen, then encode it as an uninterpreted function. *) + let>- le = get_list le in let enc = match e with - | Expr.LVar l when SS.mem l llen_lvars -> llen <| get_list le - | _ -> seq_len (get_list le) + | Expr.LVar l when SS.mem l llen_lvars -> llen <| le.expr + | _ -> seq_len le.expr in enc >- IntType - | StrLen -> slen <| get_string le >- NumberType - | ToStringOp -> Axiomatised_operations.num2str <| get_num le >- StringType - | ToNumberOp -> Axiomatised_operations.str2num <| get_string le >- NumberType - | ToIntOp -> Axiomatised_operations.num2int <| get_num le >- NumberType - | Not -> bool_not (get_bool le) >- BooleanType + | StrLen -> + let>- le = get_string le in + slen <| le.expr >- NumberType + | ToStringOp -> + let>- le = get_num le in + Axiomatised_operations.num2str <| le.expr >- StringType + | ToNumberOp -> + let>- le = get_string le in + Axiomatised_operations.str2num <| le.expr >- NumberType + | ToIntOp -> + let>- le = get_num le in + Axiomatised_operations.num2int <| le.expr >- NumberType + | Not -> + let>- le = get_bool le in + bool_not le.expr >- BooleanType | Cdr -> - let list = get_list le in - seq_extract list (int_k 1) (seq_len list) >- ListType - | Car -> seq_nth (get_list le) (int_k 0) |> simply_wrapped + let>- list = get_list le in + seq_extract list.expr (int_k 1) (seq_len list.expr) >- ListType + | Car -> + let>- list = get_list le in + seq_nth list.expr (int_k 0) |> simply_wrapped | TypeOf -> typeof_expression le >- TypeType - | ToUint32Op -> get_num le |> real_to_int |> int_to_real >- NumberType - | 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 + | ToUint32Op -> + let>- le = get_num le in + le.expr |> real_to_int |> int_to_real >- NumberType + | LstRev -> + let>- list = get_list le in + Axiomatised_operations.lrev <| list.expr >- ListType + | NumToInt -> + let>- le = get_num le in + le.expr |> real_to_int >- IntType + | IntToNum -> + let>- le = get_int le in + le.expr |> int_to_real >- NumberType + | IsInt -> + let>- le = get_num le in + num_divisible le.expr 1 >- BooleanType | BitwiseNot | M_isNaN | M_abs @@ -878,6 +1007,20 @@ let encode_bound_expr in (* Not the same gamma now!*) let encoded = encode_expr ~gamma ~llen_lvars ~list_elem_vars expr in + + (* Extra asrts could contain these bound variables - separate these *) + let rec atoms (sexp : sexp) = + match sexp with + | Atom s -> SS.singleton s + | List lst -> List.fold_left SS.union SS.empty (List.map atoms lst) + in + let bs = SS.of_list (List.map fst bound_vars) in + let contains_bound_vars asrt = not (SS.disjoint bs (atoms asrt)) in + let bound_asrts, extra_asrts = + List.partition contains_bound_vars encoded.extra_asrts + in + let encoded = { encoded with extra_asrts } in + (* Don't declare consts for quantified vars *) let bound_vars = bound_vars @@ -894,7 +1037,7 @@ let encode_bound_expr |> Hashtbl.filter_map_inplace (fun c () -> if List.mem c bound_vars then None else Some ()) in - (bound_vars, encoded) + (bound_vars, bound_asrts, encoded) let encode_quantified_expr ~(encode_expr : @@ -917,7 +1060,7 @@ let encode_quantified_expr Some (encode_expr ~gamma ~llen_lvars ~list_elem_vars assertion) | _ -> None in - let quantified_vars, encoded = + let quantified_vars, bound_asrts, encoded = encode_bound_expr ~encode_expr ~gamma ~llen_lvars ~list_elem_vars quantified_vars assertion in @@ -927,6 +1070,7 @@ let encode_quantified_expr (expr, consts, extra_asrts) | _ -> failwith "the thing inside forall is not boolean!" in + let encoded_assertion = bool_ands (encoded_assertion :: bound_asrts) in let expr = mk_quant quantified_vars encoded_assertion in native ~consts ~extra_asrts BooleanType expr @@ -955,27 +1099,37 @@ let rec encode_logical_expression | BinOp (le1, op, le2) -> encode_binop op (f le1) (f le2) | NOp (SetUnion, les) -> let>-- les = List.map f les in - les |> List.map get_set |> set_union' Z3 >- SetType + let>-- sets = List.map get_set les in + let sets = List.map (fun set -> set.expr) sets in + set_union' Z3 sets >- SetType | NOp (SetInter, les) -> let>-- les = List.map f les in - les |> List.map get_set |> set_intersection' Z3 >- SetType + let>-- sets = List.map get_set les in + let sets = List.map (fun set -> set.expr) sets in + set_intersection' Z3 sets >- SetType | NOp (LstCat, les) -> let>-- les = List.map f les in - les |> List.map get_list |> seq_concat >- ListType + let>-- lists = List.map get_list les in + let lists = List.map (fun list -> list.expr) lists in + seq_concat lists >- ListType | EList les -> let>-- args = List.map f les in - args |> List.map simple_wrap |> seq_of ~typ:t_gil_literal_list >- ListType + let>-- args = List.map simple_wrap args in + let args = List.map (fun arg -> arg.expr) args in + seq_of ~typ:t_gil_literal_list args >- ListType | ESet les -> let>-- args = List.map f les in - args |> List.map simple_wrap |> set_of >- SetType + let>-- args = List.map simple_wrap args in + let args = List.map (fun arg -> arg.expr) args in + set_of args >- SetType | LstSub (lst, start, len) -> let>- lst = f lst in let>- start = f start in let>- len = f len in - let lst = get_list lst in - let start = get_int start in - let len = get_int len in - seq_extract lst start len >- ListType + let>- lst = get_list lst in + let>- start = get_int start in + let>- len = get_int len in + seq_extract lst.expr start.expr len.expr >- ListType | Exists (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression ~mk_quant:exists ~gamma ~llen_lvars ~list_elem_vars bt e @@ -992,7 +1146,8 @@ let rec encode_logical_expression | None -> extend_wrap in let>-- args = List.map f les in - let args = List.map2 extend_wrap_or_native param_typs args in + let>-- args = List.map2 extend_wrap_or_native param_typs args in + let args = List.map (fun arg -> arg.expr) args in let sexp = app_ name args in extended_wrapped sexp | None -> @@ -1009,7 +1164,7 @@ let rec encode_logical_expression in let>- le = f le in (* Convert to native *) - let le_native = get_native_of_type ~typ:constructors_t le in + let>- le_native = get_native_of_type ~typ:constructors_t le in (* Encode match cases *) let cs, encs = List.split @@ -1021,16 +1176,20 @@ let rec encode_logical_expression let pat = PCon (c, bs) in let ts = Datatype_env.get_constructor_field_types_unsafe c in let bts = List.combine bs ts in - let _, encoded = + (* TODO: How to handle extra asrts involving bound vars?? *) + (* Using ite and mapping to undefined values when extra asrts are false causes queries to time out *) + let _, _, encoded = encode_bound_expr ~encode_expr:encode_logical_expression ~gamma ~llen_lvars ~list_elem_vars bts e in - ((pat, extend_wrap encoded), encoded)) + let encoded = extend_wrap encoded in + let encoded_expr = encoded.expr in + ((pat, encoded_expr), encoded)) cs) in - let fallback = (PVar "_", extend_wrap undefined_encoding) in + let fallback = (PVar "_", (extend_wrap undefined_encoding).expr) in let>-- _ = encs in - extended_wrapped (match_datatype le_native (cs @ [ fallback ])) + extended_wrapped (match_datatype le_native.expr (cs @ [ fallback ])) | ConstructorApp (name, les) -> ( let param_typs = Datatype_env.get_constructor_field_types name in match param_typs with @@ -1041,10 +1200,11 @@ let rec encode_logical_expression | None -> simple_wrap in let>-- args = List.map f les in - let args = List.map2 simple_wrap_or_native param_typs args in + let>-- args = List.map2 simple_wrap_or_native param_typs args in let (module V : Variant.Nary) = Lit_operations.get_constructor_variant name in + let args = List.map (fun arg -> arg.expr) args in let sexp = V.construct args in sexp >- Datatype_env.get_constructor_type_unsafe name | None -> @@ -1235,7 +1395,15 @@ let encode_functions (fs : Func.t list) : sexp list = @@ encode_logical_expression ~gamma ~llen_lvars ~list_elem_vars f.func_definition in - (name, param_types, ret_type, encoded_def) + let func_body = + if List.length encoded_def.extra_asrts == 0 then encoded_def.expr + else + ite + (bool_ands encoded_def.extra_asrts) + encoded_def.expr + (Encoding.extend_wrap Encoding.undefined_encoding).expr + in + (name, param_types, ret_type, func_body) in [ defn_funs_rec (List.map encode_function fs) ] diff --git a/wisl/examples/SLL_adt.wisl b/wisl/examples/SLL_adt.wisl index ab070c65..7ff75bf2 100644 --- a/wisl/examples/SLL_adt.wisl +++ b/wisl/examples/SLL_adt.wisl @@ -45,6 +45,22 @@ pure function list_member(xs : MyList, x) { } } +// +// Lemma: List membership append +// +lemma list_member_append { + statement: + forall vs, v, r, w. + (list_member(vs, v) == r) |- (list_member(append(vs, w), v) == (r || (w == v))) + + proof: + if (w == v) {} else {}; // FIXME: THIS IS HORRIFIC + if (vs != 'Nil) { + assert {bind: #nv, #nvs, #nr} (vs == 'Cons(#nv, #nvs)) * (list_member(#nvs, #v) == #nr); + apply list_member_append(#nvs, v, #nr, w) + } +} + // // Lemma: List membership concat //