From d279d9256a97ade940b6c2d52e02e1ea4bb97331 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Wed, 14 Jun 2023 19:02:28 +0200 Subject: [PATCH 01/26] =?UTF-8?q?Analyseur=20syntaxique=20pour=20l'extensi?= =?UTF-8?q?on=20de=20domaines=20de=20r=C3=A8gles.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/utils/strMap.ml | 1 + src/mlang/utils/strMap.mli | 1 + src/mlang/utils/strSet.ml | 1 + src/mlang/utils/strSet.mli | 1 + src/mlang/utils/strSetMap.ml | 1 + src/mlang/utils/strSetMap.mli | 1 + src/mlang/utils/strSetSet.ml | 1 + src/mlang/utils/strSetSet.mli | 1 + 8 files changed, 8 insertions(+) create mode 100644 src/mlang/utils/strMap.ml create mode 100644 src/mlang/utils/strMap.mli create mode 100644 src/mlang/utils/strSet.ml create mode 100644 src/mlang/utils/strSet.mli create mode 100644 src/mlang/utils/strSetMap.ml create mode 100644 src/mlang/utils/strSetMap.mli create mode 100644 src/mlang/utils/strSetSet.ml create mode 100644 src/mlang/utils/strSetSet.mli diff --git a/src/mlang/utils/strMap.ml b/src/mlang/utils/strMap.ml new file mode 100644 index 000000000..99d658088 --- /dev/null +++ b/src/mlang/utils/strMap.ml @@ -0,0 +1 @@ +include Map.Make (String) diff --git a/src/mlang/utils/strMap.mli b/src/mlang/utils/strMap.mli new file mode 100644 index 000000000..e6228cc68 --- /dev/null +++ b/src/mlang/utils/strMap.mli @@ -0,0 +1 @@ +include Map.S with type key = String.t diff --git a/src/mlang/utils/strSet.ml b/src/mlang/utils/strSet.ml new file mode 100644 index 000000000..9896b93e8 --- /dev/null +++ b/src/mlang/utils/strSet.ml @@ -0,0 +1 @@ +include Set.Make (String) diff --git a/src/mlang/utils/strSet.mli b/src/mlang/utils/strSet.mli new file mode 100644 index 000000000..a17713181 --- /dev/null +++ b/src/mlang/utils/strSet.mli @@ -0,0 +1 @@ +include Set.S with type elt = String.t diff --git a/src/mlang/utils/strSetMap.ml b/src/mlang/utils/strSetMap.ml new file mode 100644 index 000000000..e6405c6d1 --- /dev/null +++ b/src/mlang/utils/strSetMap.ml @@ -0,0 +1 @@ +include Map.Make (StrSet) diff --git a/src/mlang/utils/strSetMap.mli b/src/mlang/utils/strSetMap.mli new file mode 100644 index 000000000..5161fec6e --- /dev/null +++ b/src/mlang/utils/strSetMap.mli @@ -0,0 +1 @@ +include Map.S with type key = StrSet.t diff --git a/src/mlang/utils/strSetSet.ml b/src/mlang/utils/strSetSet.ml new file mode 100644 index 000000000..16ec13c53 --- /dev/null +++ b/src/mlang/utils/strSetSet.ml @@ -0,0 +1 @@ +include Set.Make (StrSet) diff --git a/src/mlang/utils/strSetSet.mli b/src/mlang/utils/strSetSet.mli new file mode 100644 index 000000000..d93e22d41 --- /dev/null +++ b/src/mlang/utils/strSetSet.mli @@ -0,0 +1 @@ +include Set.S with type elt = StrSet.t From 83b9fa05a9c33b402fa55ab2e7760753e6146554 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Wed, 14 Jun 2023 19:15:23 +0200 Subject: [PATCH 02/26] =?UTF-8?q?Suite=20du=20pr=C3=A9c=C3=A9dent=20commit?= =?UTF-8?q?...?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/m_frontend/format_mast.ml | 23 +++++ src/mlang/m_frontend/format_mast.mli | 5 + src/mlang/m_frontend/mast.ml | 8 ++ src/mlang/m_frontend/mast_to_mir.ml | 131 ++++++++++++++++++++++++++- src/mlang/m_frontend/mlexer.mll | 8 ++ src/mlang/m_frontend/mparser.mly | 52 +++++++++++ src/mlang/m_ir/mir.ml | 10 ++ src/mlang/m_ir/mir.mli | 10 ++ 8 files changed, 245 insertions(+), 2 deletions(-) diff --git a/src/mlang/m_frontend/format_mast.ml b/src/mlang/m_frontend/format_mast.ml index 778ee7629..fe251a84e 100644 --- a/src/mlang/m_frontend/format_mast.ml +++ b/src/mlang/m_frontend/format_mast.ml @@ -323,6 +323,28 @@ let format_error_ fmt (e : error_) = (pp_unmark Format.pp_print_string)) e.error_descr +let format_specialize_domain fmt (dl : string Pos.marked list Pos.marked list) = + match dl with + | [] -> () + | _ -> + Format.fprintf fmt " :@ specialise %a" + (pp_print_list_comma + (pp_unmark (pp_print_list_space (pp_unmark Format.pp_print_string)))) + dl + +let format_domain_attribute attr fmt b = + if b then Format.fprintf fmt " :@ %s" attr + +let format_rule_domain fmt (rd : rule_domain_decl) = + Format.fprintf fmt "%a%a%a%a" + (pp_print_list_comma + (pp_unmark (pp_print_list_space (pp_unmark Format.pp_print_string)))) + rd.rdom_names format_specialize_domain rd.rdom_parents + (format_domain_attribute "calculable") + rd.rdom_computable + (format_domain_attribute "par_defaut") + rd.rdom_by_default + let format_source_file_item fmt (i : source_file_item) = match i with | Application app -> @@ -338,6 +360,7 @@ let format_source_file_item fmt (i : source_file_item) = | Error e -> format_error_ fmt e | Output o -> Format.fprintf fmt "sortie(%a);" format_variable_name (Pos.unmark o) + | RuleDomDecl rd -> Format.fprintf fmt "rule domain %a;" format_rule_domain rd let format_source_file fmt (f : source_file) = pp_print_list_endline (pp_unmark format_source_file_item) fmt f diff --git a/src/mlang/m_frontend/format_mast.mli b/src/mlang/m_frontend/format_mast.mli index 4abf28dea..1100a1e56 100644 --- a/src/mlang/m_frontend/format_mast.mli +++ b/src/mlang/m_frontend/format_mast.mli @@ -24,6 +24,8 @@ val format_value_typ : Format.formatter -> Mast.value_typ -> unit val format_variable : Format.formatter -> Mast.variable -> unit +val format_rule_domain : Format.formatter -> Mast.rule_domain_decl -> unit + val format_source_file : Format.formatter -> Mast.source_file -> unit val pp_print_list_endline : @@ -32,6 +34,9 @@ val pp_print_list_endline : val pp_print_list_comma : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit +val pp_print_list_space : + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit + val pp_unmark : ('a -> 'b -> 'c) -> 'a -> 'b Pos.marked -> 'c val format_chain_tag : Format.formatter -> Mast.chain_tag -> unit diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index c8c5cafc3..d0ebc8f55 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -330,6 +330,13 @@ type rule = { (** A rule can contain many variable definitions *) } +type rule_domain_decl = { + rdom_names : string Pos.marked list Pos.marked list; + rdom_parents : string Pos.marked list Pos.marked list; + rdom_computable : bool; + rdom_by_default : bool; +} + (**{2 Variable declaration}*) (** The M language has prototypes for declaring variables with types and various @@ -437,6 +444,7 @@ type source_file_item = | Error of error_ (** Declares an error *) | Output of variable_name Pos.marked (** Declares an output variable *) | Function (** Declares a function, unused *) + | RuleDomDecl of rule_domain_decl (* TODO: parse something here *) diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 7e3ae5b19..b3bbed1a9 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -1167,6 +1167,127 @@ let add_var_def (var_data : Mir.variable_data Mir.VariableMap.t) in Mir.VariableMap.add var_lvalue vdata var_data +let get_rule_domains (p : Mast.program) : Mir.rule_domain StrSetMap.t = + let sl_to_ss sl = + let fold ss s = StrSet.add (Pos.unmark s) ss in + List.fold_left fold StrSet.empty (Pos.unmark sl) + in + let sll_to_sss sll = + let fold sss sl = StrSetSet.add (sl_to_ss sl) sss in + List.fold_left fold StrSetSet.empty sll + in + let fold_items (domains, synonyms, by_default) marked_item = + match Pos.unmark marked_item with + | Mast.RuleDomDecl decl -> + let rdom_names = sll_to_sss decl.rdom_names in + let rdom_id = StrSetSet.min_elt rdom_names in + let domain = + Mir. + { + rdom_id; + rdom_names; + rdom_computable = decl.rdom_computable; + rdom_by_default = decl.rdom_by_default; + rdom_min = sll_to_sss decl.rdom_parents; + rdom_max = StrSetSet.empty; + } + in + let domains = StrSetMap.add rdom_id domain domains in + let fold syn sl = + let name = sl_to_ss sl in + if StrSetMap.mem name syn then + let msg = "there is already a domain with this name" in + Errors.raise_spanned_error msg (Pos.get_position sl) + else StrSetMap.add name rdom_id syn + in + let synonyms = List.fold_left fold synonyms decl.rdom_names in + let by_default = + if decl.rdom_by_default then + match by_default with + | None -> Some rdom_id + | _ -> + let msg = "there is already a default rule domain" in + Errors.raise_spanned_error msg (Pos.get_position marked_item) + else by_default + in + (domains, synonyms, by_default) + | _ -> (domains, synonyms, by_default) + in + let fold_sources doms source = List.fold_left fold_items doms source in + let domains, synonyms, by_default = + List.fold_left fold_sources (StrSetMap.empty, StrSetMap.empty, None) p + in + let get_dom id dom = StrSetMap.find (StrSetMap.find id synonyms) dom in + let domains = + let rec set_min id dom (visiting, visited, doms) = + if StrSetSet.mem id visited then (visiting, visited, doms) + else if StrSetSet.mem id visiting then + Errors.raise_error "there is a loop in the rule domain hierarchy" + else + let visiting = StrSetSet.add id visiting in + let visiting, visited, doms = + let parentMap = + let fold parentId map = + let parentDom = get_dom parentId doms in + let parentId = parentDom.Mir.rdom_id in + StrSetMap.add parentId parentDom map + in + StrSetSet.fold fold dom.Mir.rdom_min StrSetMap.empty + in + StrSetMap.fold set_min parentMap (visiting, visited, doms) + in + let rdom_min = + let fold parentId res = + let parentDom = get_dom parentId doms in + let parentId = parentDom.Mir.rdom_id in + StrSetSet.singleton parentId + |> StrSetSet.union parentDom.Mir.rdom_min + |> StrSetSet.union res + in + StrSetSet.fold fold dom.Mir.rdom_min StrSetSet.empty + in + let dom = Mir.{ dom with rdom_min } in + let doms = StrSetMap.add id dom doms in + let visiting = StrSetSet.remove id visiting in + let visited = StrSetSet.add id visited in + (visiting, visited, doms) + in + let init = (StrSetSet.empty, StrSetSet.empty, domains) in + let _, _, domains = StrSetMap.fold set_min domains init in + domains + in + let domains = + let set_max id dom doms = + let fold minId doms = + let minDom = StrSetMap.find minId doms in + let rdom_max = StrSetSet.add id minDom.Mir.rdom_max in + let minDom = Mir.{ minDom with rdom_max } in + StrSetMap.add minId minDom doms + in + StrSetSet.fold fold dom.Mir.rdom_min doms + in + StrSetMap.fold set_max domains domains + in + let domains = + match by_default with + | Some def_id -> + let fold _ dom doms = + let foldName name doms = StrSetMap.add name dom doms in + StrSetSet.fold foldName dom.Mir.rdom_names doms + in + StrSetMap.empty + |> StrSetMap.fold fold domains + |> StrSetMap.add StrSet.empty (get_dom def_id domains) + | None -> Errors.raise_error "there are no default rule domain" + in + (* let _ = let iter id dom = let pp_ss fmt ss = let iter s = Format.fprintf + fmt "<%s> " s in StrSet.iter iter ss in let pp_sss fmt sss = let iter ss = + Format.fprintf fmt "%a, " pp_ss ss in StrSetSet.iter iter sss in + Format.printf "XXX %a\n: min: %a\n: max: %a\n" pp_ss id pp_sss + dom.Mir.rdom_min pp_sss dom.Mir.rdom_max in StrSetMap.iter iter domains; + exit 0 in*) + domains + (** Main translation pass that deal with regular variable definition; returns a map whose keys are the variables being defined (with the execution number corresponding to the place where it is defined) and whose values are the @@ -1431,6 +1552,8 @@ let translate (p : Mast.program) : Mir.program = let const_map = get_constants p in let var_decl_data, error_decls, idmap = get_variables_decl p const_map in let idmap = get_var_redefinitions p idmap const_map in + let rule_domains = get_rule_domains p in + let rule_domain_by_default = StrSetMap.find StrSet.empty rule_domains in let rule_data, var_data = get_rules_and_var_data idmap var_decl_data const_map p in @@ -1440,6 +1563,7 @@ let translate (p : Mast.program) : Mir.program = let rules, rule_vars = Mir.RuleMap.fold (fun rule_id (rule_vars, rule_number, rule_tags) (rules, vars) -> + let rule_domain = rule_domain_by_default in let rule_vars, vars = List.fold_left (fun (rule_vars, vars) var -> @@ -1449,8 +1573,10 @@ let translate (p : Mast.program) : Mir.program = ([], vars) (List.rev rule_vars) in let rule_tags = List.map Pos.unmark rule_tags in - ( Mir.RuleMap.add rule_id Mir.{ rule_vars; rule_number; rule_tags } rules, - vars )) + let rule_data = + Mir.{ rule_domain; rule_vars; rule_number; rule_tags } + in + (Mir.RuleMap.add rule_id rule_data rules, vars)) rule_data (Mir.RuleMap.empty, Mir.VariableDict.empty) in @@ -1469,6 +1595,7 @@ let translate (p : Mast.program) : Mir.program = Mir.RuleMap.add Mir.initial_undef_rule_id Mir. { + rule_domain = rule_domain_by_default; rule_vars = orphans; rule_number = (RuleID 0, Pos.no_pos); rule_tags = []; diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index 7221c029a..a313e17a0 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -116,6 +116,14 @@ rule token = parse { NOTIN } | "non" { NOT } +| "domaine" + { DOMAIN } +| "specialise" + { SPECIALIZE } +| "calculable" + { COMPUTABLE } +| "par_defaut" + { BY_DEFAULT } | "regle" { RULE } | "si" diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 60c72c091..508206e6b 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -49,6 +49,7 @@ along with this program. If not, see . %token COMPUTED CONST ALIAS CONTEXT FAMILY PENALITY INCOME INPUT FOR %token RULE IF THEN ELSE ENDIF ERROR VERIFICATION ANOMALY DISCORDANCE CONDITION %token INFORMATIVE OUTPUT FONCTION +%token DOMAIN SPECIALIZE COMPUTABLE BY_DEFAULT %token EOF @@ -82,6 +83,57 @@ source_file_item: | e = error_ { (Error e, mk_position $sloc) } | o = output { (Output o, mk_position $sloc) } | fonction { (Function, mk_position $sloc) } +| cr = rule_domain_decl { (RuleDomDecl cr, mk_position $sloc) } + +rule_domain_decl: +| DOMAIN RULE rdom_params = separated_nonempty_list(COLON, rdom_param_with_pos) SEMICOLON + { + let err msg pos = Errors.raise_spanned_error msg pos in + let fold (dno, dso, dco, dpdo) = function + | Some dn, _, _, _, pos -> + if dno = None then Some dn, dso, dco, dpdo + else err "rule domain names are already defined" pos + | _, Some ds, _, _, pos -> + if dso = None then dno, Some ds, dco, dpdo + else err "rule domain specialization is already specified" pos + | _, _, Some dc, _, pos -> + if dco = None then dno, dso, Some dc, dpdo + else err "rule domain is already calculated" pos + | _, _, _, Some dpd, pos -> + if dpdo = None then dno, dso, dco, Some dpd + else err "rule domain is already defined by defaut" pos + | _, _, _, _, _ -> assert false + in + let init = None, None, None, None in + let dno, dso, dco, dpdo = List.fold_left fold init rdom_params in + let rdom_names = + match dno with + | None -> err "rule domain names must be defined" (mk_position $sloc) + | Some dn -> dn + in + { + rdom_names; + rdom_parents = (match dso with None -> [] | Some ds -> ds); + rdom_computable = (match dco with None -> false | _ -> true); + rdom_by_default = (match dpdo with None -> false | _ -> true); + } + } + +rdom_param_with_pos: +| rdom_names = separated_nonempty_list(COMMA, symbol_list_with_pos) + { (Some rdom_names, None, None, None, mk_position $sloc) } +| SPECIALIZE rdom_parents = separated_nonempty_list(COMMA, symbol_list_with_pos) + { (None, Some rdom_parents, None, None, mk_position $sloc) } +| COMPUTABLE + { (None, None, Some (), None, mk_position $sloc) } +| BY_DEFAULT + { (None, None, None, Some (), mk_position $sloc) } + +%inline symbol_with_pos: +| s = SYMBOL { (s, mk_position $sloc) } + +%inline symbol_list_with_pos: +| sl = nonempty_list(symbol_with_pos) { (sl, mk_position $sloc) } fonction: | SYMBOL COLON FONCTION SYMBOL SEMICOLON { () } diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index f7c8d34d4..884d68ebc 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -389,7 +389,17 @@ let fresh_rule_num = (** Special rule id for initial definition of variables *) let initial_undef_rule_id = RuleID (-1) +type rule_domain = { + rdom_id : StrSet.t; + rdom_names : StrSetSet.t; + rdom_computable : bool; + rdom_by_default : bool; + rdom_min : StrSetSet.t; + rdom_max : StrSetSet.t; +} + type rule_data = { + rule_domain : rule_domain; rule_vars : (Variable.id * variable_data) list; rule_number : rov_id Pos.marked; rule_tags : Mast.chain_tag list; diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 3b06f5f4d..c1b298ffc 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -168,7 +168,17 @@ type rov_id = RuleID of int | VerifID of int module RuleMap : Map.S with type key = rov_id +type rule_domain = { + rdom_id : StrSet.t; + rdom_names : StrSetSet.t; + rdom_computable : bool; + rdom_by_default : bool; + rdom_min : StrSetSet.t; + rdom_max : StrSetSet.t; +} + type rule_data = { + rule_domain : rule_domain; rule_vars : (variable_id * variable_data) list; rule_number : rov_id Pos.marked; rule_tags : Mast.chain_tag list; From 9f3ac5d9857ba2d6a6539c70a5fb096aa13615ca Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 15 Jun 2023 17:31:37 +0200 Subject: [PATCH 03/26] =?UTF-8?q?Remplacement=20partiel=20des=20tags=20par?= =?UTF-8?q?=20les=20domaines=20de=20r=C3=A8gles=20(et=20les=20encha=C3=AEn?= =?UTF-8?q?eurs).?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/m_frontend/mast.ml | 49 ++++++++---------- src/mlang/m_frontend/mast_to_mir.ml | 79 +++++++++++++++++++++++------ src/mlang/m_frontend/mparser.mly | 31 +++++++++-- src/mlang/m_ir/mir.ml | 46 +++++++++++++++++ src/mlang/m_ir/mir.mli | 3 ++ src/mlang/m_ir/mir_interface.ml | 75 ++++++++------------------- src/mlang/mpp_ir/mpp_ir_to_bir.ml | 42 +++++++++++---- src/mlang/utils/pos.ml | 14 +++++ src/mlang/utils/pos.mli | 2 + src/mlang/utils/strSet.ml | 18 +++++++ src/mlang/utils/strSet.mli | 6 +++ src/mlang/utils/strSetSet.ml | 19 +++++++ src/mlang/utils/strSetSet.mli | 6 +++ 13 files changed, 279 insertions(+), 111 deletions(-) diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index d0ebc8f55..bf9e7314c 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -80,7 +80,7 @@ let all_tags : chain_tag list = Corrective; Isf; Taux; - Irisf; + (* Irisf;*) Base_hr; Base_tl; Base_tl_init; @@ -109,8 +109,7 @@ let all_tags : chain_tag list = Base_anterieure; Base_anterieure_cor; Base_stratemajo; - Non_auto_cc; - Horizontale; + (* Non_auto_cc; Horizontale;*) ] let chain_tag_of_string : string -> chain_tag = function @@ -182,6 +181,25 @@ let number_and_tags_of_name (name : string Pos.marked list) : ] ) (* No tags means both in primitive and corrective *) else (number, tags) +let tags_of_name (name : string Pos.marked list) : chain_tag Pos.marked list = + let rec aux tags = function + | [] -> tags + | h :: t -> + let tag = + try Pos.map_under_mark chain_tag_of_string h + with _ -> + Errors.raise_spanned_error + ("Unknown chain tag " ^ Pos.unmark h) + (Pos.get_position h) + in + aux (tag :: tags) t + in + let tags = aux [] name in + if List.length tags = 0 then + [ (PrimCorr, Pos.no_pos); (Primitif, Pos.no_pos); (Corrective, Pos.no_pos) ] + (* No tags means both in primitive and corrective *) + else tags + type variable_name = string (** Variables are just strings *) @@ -323,6 +341,7 @@ type formula = type rule = { rule_number : int Pos.marked; + rule_tag_names : string Pos.marked list Pos.marked; rule_tags : chain_tag Pos.marked list; rule_applications : application Pos.marked list; rule_chaining : chaining Pos.marked option; @@ -466,30 +485,6 @@ type function_spec = { let get_variable_name (v : variable) : string = match v with Normal s -> s | Generic s -> s.base -let are_tags_part_of_chain (tags : chain_tag list) (chain : chain_tag) : bool = - let is_part_of chain = List.exists (( = ) chain) tags in - match chain with - | Irisf -> false (* Not a real chain *) - | Corrective -> - (* Specific exclusion of "base_" rules in corrective *) - (not - (List.exists - (function - | Base_hr | Base_tl | Base_tl_init | Base_tl_rect | Base_initial - | Base_inr | Base_inr_ref | Base_inr_tl | Base_inr_tl22 - | Base_inr_tl24 | Base_inr_ntl | Base_inr_ntl22 | Base_inr_ntl24 - | Base_inr_inter22 | Base_inr_intertl | Base_inr_r9901 - | Base_inr_cimr07 | Base_inr_cimr99 | Base_inr_cimr24 - | Base_inr_tlcimr07 | Base_inr_tlcimr24 | Base_abat98 - | Base_abat99 | Base_majo | Base_premier | Base_anterieure - | Base_anterieure_cor | Base_stratemajo -> - true - | _ -> false) - tags)) - && (is_part_of chain || is_part_of Irisf) - | Primitif | Isf -> is_part_of chain || is_part_of Irisf - | _ -> is_part_of chain - let are_tags_part_of_verif_chain (tags : chain_tag list) (chain : chain_tag) : bool = let is_part_of = List.mem chain tags in diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index b3bbed1a9..8a5b5b3a5 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -1168,18 +1168,10 @@ let add_var_def (var_data : Mir.variable_data Mir.VariableMap.t) Mir.VariableMap.add var_lvalue vdata var_data let get_rule_domains (p : Mast.program) : Mir.rule_domain StrSetMap.t = - let sl_to_ss sl = - let fold ss s = StrSet.add (Pos.unmark s) ss in - List.fold_left fold StrSet.empty (Pos.unmark sl) - in - let sll_to_sss sll = - let fold sss sl = StrSetSet.add (sl_to_ss sl) sss in - List.fold_left fold StrSetSet.empty sll - in let fold_items (domains, synonyms, by_default) marked_item = match Pos.unmark marked_item with | Mast.RuleDomDecl decl -> - let rdom_names = sll_to_sss decl.rdom_names in + let rdom_names = StrSetSet.from_marked_list_list decl.rdom_names in let rdom_id = StrSetSet.min_elt rdom_names in let domain = Mir. @@ -1188,13 +1180,13 @@ let get_rule_domains (p : Mast.program) : Mir.rule_domain StrSetMap.t = rdom_names; rdom_computable = decl.rdom_computable; rdom_by_default = decl.rdom_by_default; - rdom_min = sll_to_sss decl.rdom_parents; + rdom_min = StrSetSet.from_marked_list_list decl.rdom_parents; rdom_max = StrSetSet.empty; } in let domains = StrSetMap.add rdom_id domain domains in let fold syn sl = - let name = sl_to_ss sl in + let name = StrSet.from_marked_list (Pos.unmark sl) in if StrSetMap.mem name syn then let msg = "there is already a domain with this name" in Errors.raise_spanned_error msg (Pos.get_position sl) @@ -1285,9 +1277,38 @@ let get_rule_domains (p : Mast.program) : Mir.rule_domain StrSetMap.t = Format.fprintf fmt "%a, " pp_ss ss in StrSetSet.iter iter sss in Format.printf "XXX %a\n: min: %a\n: max: %a\n" pp_ss id pp_sss dom.Mir.rdom_min pp_sss dom.Mir.rdom_max in StrSetMap.iter iter domains; - exit 0 in*) + exit 0 in *) domains +let get_rule_chains (domains : Mir.rule_domain StrSetMap.t) (p : Mast.program) : + Mir.rule_domain StrMap.t = + let fold_rules chains marked_item = + match Pos.unmark marked_item with + | Mast.Rule r when r.rule_chaining <> None -> + let ch_name, ch_pos = Option.get r.rule_chaining in + let rule_domain = + let rdom_id = StrSet.from_marked_list (Pos.unmark r.rule_tag_names) in + StrSetMap.find rdom_id domains + in + let ch_dom = + match StrMap.find_opt ch_name chains with + | Some dom -> dom + | None -> rule_domain + in + let rdom_is_min = StrSetSet.mem rule_domain.rdom_id ch_dom.rdom_min in + let rdom_is_max = StrSetSet.mem rule_domain.rdom_id ch_dom.rdom_max in + let rdom_is_eq = rule_domain.rdom_id = ch_dom.rdom_id in + if rdom_is_min || rdom_is_max || rdom_is_eq then + if not rdom_is_min then StrMap.add ch_name rule_domain chains + else chains + else + let msg = "chaining incompatible with rule domain" in + Errors.raise_spanned_error msg ch_pos + | _ -> chains + in + let fold_sources chains source = List.fold_left fold_rules chains source in + List.fold_left fold_sources StrMap.empty p + (** Main translation pass that deal with regular variable definition; returns a map whose keys are the variables being defined (with the execution number corresponding to the place where it is defined) and whose values are the @@ -1297,6 +1318,8 @@ let get_rules_and_var_data (idmap : Mir.idmap) (const_map : float Pos.marked ConstMap.t) (p : Mast.program) : (Mir.Variable.t list * Mir.rov_id Pos.marked + * string Pos.marked list Pos.marked + * Mast.chaining Pos.marked option * Mast.chain_tag Pos.marked list) Mir.RuleMap.t * Mir.variable_data Mir.VariableMap.t = @@ -1387,7 +1410,13 @@ let get_rules_and_var_data (idmap : Mir.idmap) let rule_number = Pos.map_under_mark (fun n -> Mir.RuleID n) r.rule_number in - let rule = (List.rev rule_vars, rule_number, rule_tags) in + let rule = + ( List.rev rule_vars, + rule_number, + r.rule_tag_names, + r.rule_chaining, + rule_tags ) + in ( Mir.RuleMap.add (Pos.unmark rule_number) rule rule_data, var_data ) | _ -> (rule_data, var_data)) @@ -1554,6 +1583,7 @@ let translate (p : Mast.program) : Mir.program = let idmap = get_var_redefinitions p idmap const_map in let rule_domains = get_rule_domains p in let rule_domain_by_default = StrSetMap.find StrSet.empty rule_domains in + let rule_chains = get_rule_chains rule_domains p in let rule_data, var_data = get_rules_and_var_data idmap var_decl_data const_map p in @@ -1562,8 +1592,24 @@ let translate (p : Mast.program) : Mir.program = in let rules, rule_vars = Mir.RuleMap.fold - (fun rule_id (rule_vars, rule_number, rule_tags) (rules, vars) -> - let rule_domain = rule_domain_by_default in + (fun rule_id + (rule_vars, rule_number, rule_tag_names, rule_chaining, rule_tags) + (rules, vars) -> + let domain_id = StrSet.from_marked_list (Pos.unmark rule_tag_names) in + let rule_domain = + match StrSetMap.find_opt domain_id rule_domains with + | Some domain -> domain + | None -> + Errors.raise_spanned_error "unknown rule domain" + (Pos.get_position rule_tag_names) + in + let rule_chain = + match rule_chaining with + | None -> None + | Some mch -> + let ch_name = Pos.unmark mch in + Some (ch_name, StrMap.find ch_name rule_chains) + in let rule_vars, vars = List.fold_left (fun (rule_vars, vars) var -> @@ -1574,7 +1620,7 @@ let translate (p : Mast.program) : Mir.program = in let rule_tags = List.map Pos.unmark rule_tags in let rule_data = - Mir.{ rule_domain; rule_vars; rule_number; rule_tags } + Mir.{ rule_domain; rule_chain; rule_vars; rule_number; rule_tags } in (Mir.RuleMap.add rule_id rule_data rules, vars)) rule_data @@ -1596,6 +1642,7 @@ let translate (p : Mast.program) : Mir.program = Mir. { rule_domain = rule_domain_by_default; + rule_chain = None; rule_vars = orphans; rule_number = (RuleID 0, Pos.no_pos); rule_tags = []; diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 508206e6b..eea7157aa 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -278,17 +278,38 @@ value_type_prim: | INTEGER { (Integer, mk_position $sloc) } | REAL { (Real, mk_position $sloc) } -rule_name_symbol: -name = SYMBOL { (name, mk_position $sloc) } - rule: -| RULE name = rule_name_symbol+ COLON apps = application_reference +| RULE name = symbol_list_with_pos COLON apps = application_reference SEMICOLON c = chaining_reference? formulaes = formula_list { - let rule_number, rule_tags = Mast.number_and_tags_of_name name in + let num, rule_tag_names = + let uname = Pos.unmark name in + let begPos = + match uname with + | h :: _ -> Pos.get_position h + | [] -> assert false + in + let rec aux tags endPos = function + | [num] -> + let pos = Pos.make_position_between begPos endPos in + num, (tags, pos) + | h :: t -> aux (h :: tags) (Pos.get_position h) t + | [] -> assert false + in + aux [] begPos uname + in + let rule_number = + try Pos.map_under_mark int_of_string num + with _ -> + Errors.raise_spanned_error + "this rule or verification doesn't have an execution number" + (Pos.get_position num) + in + let rule_tags = Mast.tags_of_name (Pos.unmark rule_tag_names) in { rule_number; + rule_tag_names; rule_tags; rule_applications = apps; rule_chaining = c; diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 884d68ebc..d0360f300 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -400,6 +400,7 @@ type rule_domain = { type rule_data = { rule_domain : rule_domain; + rule_chain : (string * rule_domain) option; rule_vars : (Variable.id * variable_data) list; rule_number : rov_id Pos.marked; rule_tags : Mast.chain_tag list; @@ -648,3 +649,48 @@ let find_vars_by_io (p : program) (io_to_find : io) : VariableDict.t = then VariableDict.add var acc else acc) p VariableDict.empty + +let tag_to_rule_domain_id : Mast.chain_tag -> StrSet.t = function + | Mast.Primitif -> StrSet.from_list [ "primitive" ] + | Mast.Corrective -> StrSet.from_list [ "corrective" ] + | Mast.Isf -> StrSet.from_list [ "isf" ] + | Mast.Taux -> StrSet.from_list [ "taux" ] + | Mast.Irisf -> StrSet.from_list [ "irisf" ] + | Mast.Base_hr -> StrSet.from_list [ "corrective"; "base_HR" ] + | Mast.Base_tl -> StrSet.from_list [ "corrective"; "base_tl" ] + | Mast.Base_tl_init -> StrSet.from_list [ "corrective"; "base_tl_init" ] + | Mast.Base_tl_rect -> StrSet.from_list [ "corrective"; "base_tl_rect" ] + | Mast.Base_initial -> StrSet.from_list [ "corrective"; "base_INITIAL" ] + | Mast.Base_inr -> StrSet.from_list [ "corrective"; "base_INR" ] + | Mast.Base_inr_ref -> StrSet.from_list [ "corrective"; "base_inr_ref" ] + | Mast.Base_inr_tl -> StrSet.from_list [ "corrective"; "base_inr_tl" ] + | Mast.Base_inr_tl22 -> StrSet.from_list [ "corrective"; "base_inr_tl22" ] + | Mast.Base_inr_tl24 -> StrSet.from_list [ "corrective"; "base_inr_tl24" ] + | Mast.Base_inr_ntl -> StrSet.from_list [ "corrective"; "base_inr_ntl" ] + | Mast.Base_inr_ntl22 -> StrSet.from_list [ "corrective"; "base_inr_ntl22" ] + | Mast.Base_inr_ntl24 -> StrSet.from_list [ "corrective"; "base_inr_ntl24" ] + | Mast.Base_inr_inter22 -> + StrSet.from_list [ "corrective"; "base_inr_inter22" ] + | Mast.Base_inr_intertl -> + StrSet.from_list [ "corrective"; "base_inr_intertl" ] + | Mast.Base_inr_r9901 -> StrSet.from_list [ "corrective"; "base_inr_r9901" ] + | Mast.Base_inr_cimr07 -> StrSet.from_list [ "corrective"; "base_inr_cimr07" ] + | Mast.Base_inr_cimr24 -> StrSet.from_list [ "corrective"; "base_inr_cimr24" ] + | Mast.Base_inr_cimr99 -> StrSet.from_list [ "corrective"; "base_inr_cimr99" ] + | Mast.Base_inr_tlcimr07 -> + StrSet.from_list [ "corrective"; "base_inr_tlcimr07" ] + | Mast.Base_inr_tlcimr24 -> + StrSet.from_list [ "corrective"; "base_inr_tlcimr24" ] + | Mast.Base_abat98 -> StrSet.from_list [ "corrective"; "base_ABAT98" ] + | Mast.Base_abat99 -> StrSet.from_list [ "corrective"; "base_ABAT99" ] + | Mast.Base_majo -> StrSet.from_list [ "corrective"; "base_MAJO" ] + | Mast.Base_premier -> StrSet.from_list [ "corrective"; "base_premier" ] + | Mast.Base_anterieure -> StrSet.from_list [ "corrective"; "base_anterieure" ] + | Mast.Base_anterieure_cor -> + StrSet.from_list [ "corrective"; "base_anterieure_cor" ] + | Mast.Base_stratemajo -> StrSet.from_list [ "corrective"; "base_stratemajo" ] + | Mast.Non_auto_cc -> StrSet.from_list [ "non_auto_cc" ] + | Mast.Horizontale -> StrSet.from_list [ "horizontale" ] + | Mast.PrimCorr -> StrSet.from_list [ "irisf"; "corrective" ] + | Mast.Custom _ -> assert false +(* StrSet.from_list [ "custom"; ch ] *) diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index c1b298ffc..626f64cd3 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -179,6 +179,7 @@ type rule_domain = { type rule_data = { rule_domain : rule_domain; + rule_chain : (string * rule_domain) option; rule_vars : (variable_id * variable_data) list; rule_number : rov_id Pos.marked; rule_tags : Mast.chain_tag list; @@ -358,3 +359,5 @@ val find_vars_by_io : program -> io -> VariableDict.t (** Returns a VariableDict.t containing all the variables that have a given io type, only one variable per name is entered in the VariableDict.t, this function chooses the one with the highest execution number*) + +val tag_to_rule_domain_id : Mast.chain_tag -> StrSet.t diff --git a/src/mlang/m_ir/mir_interface.ml b/src/mlang/m_ir/mir_interface.ml index b0011c5f7..9e4ba6598 100644 --- a/src/mlang/m_ir/mir_interface.ml +++ b/src/mlang/m_ir/mir_interface.ml @@ -60,13 +60,18 @@ type full_program = { let to_full_program (program : program) (chains : Mast.chain_tag list) : full_program = - let chains_orders, _ = + let chains_orders = List.fold_left - (fun (chains, seen_customs) tag -> + (fun chains tag -> let vars_to_rules, chain_rules = Mir.RuleMap.fold (fun rov_id rule (vars, rules) -> - if Mast.are_tags_part_of_chain rule.rule_tags tag then + let rule_domain = rule.rule_domain in + let tag_domain_id = tag_to_rule_domain_id tag in + let is_max = StrSetSet.mem tag_domain_id rule_domain.rdom_max in + let is_eq = rule_domain.rdom_id = tag_domain_id in + let is_not_rule_0 = Pos.unmark rule.rule_number <> RuleID 0 in + if is_not_rule_0 && (is_max || is_eq) then ( List.fold_left (fun vars (vid, _def) -> let var = VariableDict.find vid program.program_vars in @@ -84,31 +89,20 @@ let to_full_program (program : program) (chains : Mast.chain_tag list) : let execution_order = Mir_dependency_graph.get_rules_execution_order dep_graph in - let customs, _ = + let customs = RuleMap.fold - (fun rov_id rule (customs, in_primcorr) -> + (fun rov_id rule customs -> List.fold_left - (fun (customs, in_primcorr) tag -> + (fun customs tag -> match tag with - | Mast.Custom _ -> ( - let ipc = - Mast.are_tags_part_of_chain rule.rule_tags Mast.PrimCorr - in - if in_primcorr && not ipc then - Errors.raise_error - "Custom chain must be attributed to rules with all \ - the exact same tagging." - else - match TagMap.find_opt tag customs with - | Some rs -> - ( TagMap.add tag (rov_id :: rs) customs, - ipc || in_primcorr ) - | None -> - ( TagMap.add tag [ rov_id ] customs, - ipc || in_primcorr )) - | _ -> (customs, in_primcorr)) - (customs, in_primcorr) rule.rule_tags) - chain_rules (TagMap.empty, false) + | Mast.Custom _ -> begin + match TagMap.find_opt tag customs with + | Some rs -> TagMap.add tag (rov_id :: rs) customs + | None -> TagMap.add tag [ rov_id ] customs + end + | _ -> customs) + customs rule.rule_tags) + chain_rules TagMap.empty in let customs = TagMap.map @@ -116,32 +110,6 @@ let to_full_program (program : program) (chains : Mast.chain_tag list) : Mir_dependency_graph.pull_rules_dependencies dep_graph rules) customs in - let seen_customs = - TagMap.merge - (fun custom_tag seen curr -> - match (seen, curr) with - | None, None -> None - | Some _, None -> seen - | None, Some _ -> Some tag - | Some s, Some _ -> ( - match (s, tag) with - | Mast.Primitif, Mast.Corrective - | Mast.Corrective, Mast.Primitif -> - (* ignore this case *) seen - | _ -> - let custom_tag = - match custom_tag with - | Mast.Custom s -> s - | _ -> assert false - in - Errors.raise_error - (Format.asprintf - "Rules with custom chain %s found with incompatible \ - tags %a and %a." - custom_tag Format_mast.format_chain_tag s - Format_mast.format_chain_tag tag))) - seen_customs customs - in let chains = TagMap.fold (fun tag (dep_graph, execution_order) chains -> @@ -149,9 +117,8 @@ let to_full_program (program : program) (chains : Mast.chain_tag list) : customs (Mir.TagMap.add tag { dep_graph; execution_order } chains) in - (chains, seen_customs)) - (Mir.TagMap.empty, Mir.TagMap.empty) - chains + chains) + Mir.TagMap.empty chains in { program; chains_orders } diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml index dbe6eb3c0..120eefa13 100644 --- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml +++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml @@ -23,7 +23,8 @@ end) type translation_ctx = { new_variables : Bir.variable StringMap.t; variables_used_as_inputs : Mir.VariableDict.t; - used_chains : unit Mir.TagMap.t; + used_rule_domains : StrSetSet.t; + used_chainings : StrSet.t; verif_seen : bool; } @@ -31,7 +32,8 @@ let empty_translation_ctx : translation_ctx = { new_variables = StringMap.empty; variables_used_as_inputs = Mir.VariableDict.empty; - used_chains = Mir.TagMap.empty; + used_rule_domains = StrSetSet.empty; + used_chainings = StrSet.empty; verif_seen = false; } @@ -46,8 +48,9 @@ let ctx_join ctx1 ctx2 = variables_used_as_inputs = Mir.VariableDict.union ctx1.variables_used_as_inputs ctx2.variables_used_as_inputs; - used_chains = - Mir.TagMap.union (fun _ _ () -> Some ()) ctx1.used_chains ctx2.used_chains; + used_rule_domains = + StrSetSet.union ctx1.used_rule_domains ctx2.used_rule_domains; + used_chainings = StrSet.union ctx1.used_chainings ctx2.used_chainings; verif_seen = ctx1.verif_seen || ctx2.verif_seen; } @@ -410,7 +413,15 @@ and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list) ] ) | Mpp_ir.Expr (Call (Program chain_tag, _args), _) -> let ctx = - { ctx with used_chains = Mir.TagMap.add chain_tag () ctx.used_chains } + let used_rule_domains, used_chainings = + match chain_tag with + | Custom ch -> + (ctx.used_rule_domains, StrSet.add ch ctx.used_chainings) + | _ -> + let dom = Mir.tag_to_rule_domain_id chain_tag in + (StrSetSet.add dom ctx.used_rule_domains, ctx.used_chainings) + in + { ctx with used_rule_domains; used_chainings } in wrap_m_code_call m_program chain_tag ctx | Mpp_ir.Expr (Call (Verif (chain_tag, filter), _args), _) -> @@ -492,10 +503,23 @@ let create_combined_program (m_program : Mir_interface.full_program) Mir.RuleMap.fold (fun rov_id rule_data rules -> if - Mir.TagMap.exists - (fun chain () -> - Mast.are_tags_part_of_chain rule_data.Mir.rule_tags chain) - ctx.used_chains + let rule_domain = rule_data.Mir.rule_domain in + let has_max = + not + (StrSetSet.disjoint ctx.used_rule_domains rule_domain.rdom_max) + in + let has_used_domain = + StrSetSet.mem rule_domain.rdom_id ctx.used_rule_domains + in + let has_used_chaining = + match rule_data.Mir.rule_chain with + | None -> false + | Some (ch, _) -> StrSet.mem ch ctx.used_chainings + in + let is_not_rule_0 = + Pos.unmark rule_data.Mir.rule_number <> RuleID 0 + in + is_not_rule_0 && (has_max || has_used_domain || has_used_chaining) then let rov_name = Pos.map_under_mark diff --git a/src/mlang/utils/pos.ml b/src/mlang/utils/pos.ml index bca22f621..7f38ac7bd 100644 --- a/src/mlang/utils/pos.ml +++ b/src/mlang/utils/pos.ml @@ -22,6 +22,20 @@ type t = { pos_filename : string; pos_loc : Lexing.position * Lexing.position } let make_position (f : string) (loc : Lexing.position * Lexing.position) = { pos_filename = f; pos_loc = loc } +let make_position_between (p1 : t) (p2 : t) : t = + if p1.pos_filename <> p2.pos_filename then begin + Cli.error_print "Conflicting position filenames: %s <> %s" p1.pos_filename + p2.pos_filename; + exit (-1) + end + else + let b1, e1 = p1.pos_loc in + let b2, e2 = p2.pos_loc in + let b = if b1.Lexing.pos_cnum < b2.Lexing.pos_cnum then b1 else b2 in + let e = if e2.Lexing.pos_cnum < e1.Lexing.pos_cnum then e1 else e2 in + let pos_loc = (b, e) in + { p1 with pos_loc } + let format_position_short fmt pos = let s, e = pos.pos_loc in if s.Lexing.pos_lnum = e.Lexing.pos_lnum then diff --git a/src/mlang/utils/pos.mli b/src/mlang/utils/pos.mli index 43fed6881..5841083a4 100644 --- a/src/mlang/utils/pos.mli +++ b/src/mlang/utils/pos.mli @@ -22,6 +22,8 @@ type t val make_position : string -> Lexing.position * Lexing.position -> t +val make_position_between : t -> t -> t + val format_position_short : Format.formatter -> t -> unit val format_position : Format.formatter -> t -> unit diff --git a/src/mlang/utils/strSet.ml b/src/mlang/utils/strSet.ml index 9896b93e8..db0e7fee5 100644 --- a/src/mlang/utils/strSet.ml +++ b/src/mlang/utils/strSet.ml @@ -1 +1,19 @@ include Set.Make (String) + +let from_list (l : string list) : t = + let fold set str = add str set in + List.fold_left fold empty l + +let from_marked_list (l : string Pos.marked list) : t = + let fold set str = add (Pos.unmark str) set in + List.fold_left fold empty l + +let pp (sep : string) (fmt : Format.formatter) (set : t) : unit = + let foldSet str first = + let _ = + if first then Format.fprintf fmt "%s" str + else Format.fprintf fmt "%s%s" sep str + in + false + in + ignore (fold foldSet set true) diff --git a/src/mlang/utils/strSet.mli b/src/mlang/utils/strSet.mli index a17713181..c996938a5 100644 --- a/src/mlang/utils/strSet.mli +++ b/src/mlang/utils/strSet.mli @@ -1 +1,7 @@ include Set.S with type elt = String.t + +val from_list : string list -> t + +val from_marked_list : string Pos.marked list -> t + +val pp : string -> Format.formatter -> t -> unit diff --git a/src/mlang/utils/strSetSet.ml b/src/mlang/utils/strSetSet.ml index 16ec13c53..2b4fa7074 100644 --- a/src/mlang/utils/strSetSet.ml +++ b/src/mlang/utils/strSetSet.ml @@ -1 +1,20 @@ include Set.Make (StrSet) + +let from_list_list (ll : string list list) : t = + let fold setSet l = add (StrSet.from_list l) setSet in + List.fold_left fold empty ll + +let from_marked_list_list (ll : string Pos.marked list Pos.marked list) : t = + let fold setSet l = add (StrSet.from_marked_list (Pos.unmark l)) setSet in + List.fold_left fold empty ll + +let pp (sep1 : string) (sep2 : string) (fmt : Format.formatter) (setSet : t) : + unit = + let foldSetSet set first = + let _ = + if first then Format.fprintf fmt "%a" (StrSet.pp sep2) set + else Format.fprintf fmt "%s%a" sep1 (StrSet.pp sep2) set + in + false + in + ignore (fold foldSetSet setSet true) diff --git a/src/mlang/utils/strSetSet.mli b/src/mlang/utils/strSetSet.mli index d93e22d41..37a71055c 100644 --- a/src/mlang/utils/strSetSet.mli +++ b/src/mlang/utils/strSetSet.mli @@ -1 +1,7 @@ include Set.S with type elt = StrSet.t + +val from_list_list : string list list -> t + +val from_marked_list_list : string Pos.marked list Pos.marked list -> t + +val pp : string -> string -> Format.formatter -> t -> unit From a2f89775e3476c8bb661b06848088b77aa998c17 Mon Sep 17 00:00:00 2001 From: david Date: Tue, 20 Jun 2023 19:06:42 +0200 Subject: [PATCH 04/26] =?UTF-8?q?Avanc=C3=A9e=20du=20remplacement=20des=20?= =?UTF-8?q?tags=20par=20les=20domaines.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/m_frontend/mast_to_mir.ml | 2 + src/mlang/m_ir/mir.ml | 2 + src/mlang/m_ir/mir.mli | 2 + src/mlang/m_ir/mir_dependency_graph.mli | 2 +- src/mlang/m_ir/mir_interface.ml | 63 ++++++++++++++++++++++++- src/mlang/m_ir/mir_interface.mli | 2 + 6 files changed, 71 insertions(+), 2 deletions(-) diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 8a5b5b3a5..d97039541 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -1651,6 +1651,8 @@ let translate (p : Mast.program) : Mir.program = in let conds = get_conds error_decls const_map idmap p in { + Mir.program_domains = rule_domains; + Mir.program_chainings = rule_chains; Mir.program_vars = var_data; Mir.program_rules = rules; Mir.program_conds = conds; diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index d0360f300..21398bd9c 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -527,6 +527,8 @@ type idmap = Variable.t list Pos.VarNameToID.t type exec_pass = { exec_pass_set_variables : literal Pos.marked VariableMap.t } type program = { + program_domains : rule_domain StrSetMap.t; + program_chainings : rule_domain StrMap.t; program_vars : VariableDict.t; (** A static register of all variables that can be used during a calculation *) diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 626f64cd3..5537e66f1 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -220,6 +220,8 @@ type idmap = variable list Pos.VarNameToID.t type exec_pass = { exec_pass_set_variables : literal Pos.marked VariableMap.t } type program = { + program_domains : rule_domain StrSetMap.t; + program_chainings : rule_domain StrMap.t; program_vars : VariableDict.t; (** A static register of all variables that can be used during a calculation *) diff --git a/src/mlang/m_ir/mir_dependency_graph.mli b/src/mlang/m_ir/mir_dependency_graph.mli index 838a161ef..9dc3424eb 100644 --- a/src/mlang/m_ir/mir_dependency_graph.mli +++ b/src/mlang/m_ir/mir_dependency_graph.mli @@ -16,7 +16,7 @@ (** Defines the dependency graph of an M program *) -module RG : Graph.Sig.G +module RG : Graph.Sig.P (** Dependency graph for the rules of the M program. Each node corresponds to a rule, each edge to variables use. The edges in the graph go from input to outputs. *) diff --git a/src/mlang/m_ir/mir_interface.ml b/src/mlang/m_ir/mir_interface.ml index 9e4ba6598..4e391d391 100644 --- a/src/mlang/m_ir/mir_interface.ml +++ b/src/mlang/m_ir/mir_interface.ml @@ -56,6 +56,8 @@ type chain_order = { type full_program = { program : Mir.program; chains_orders : chain_order Mir.TagMap.t; + domains_orders : chain_order StrSetMap.t; + chainings_orders : chain_order StrMap.t; } let to_full_program (program : program) (chains : Mast.chain_tag list) : @@ -120,7 +122,66 @@ let to_full_program (program : program) (chains : Mast.chain_tag list) : chains) Mir.TagMap.empty chains in - { program; chains_orders } + let domains_orders = + StrSetMap.fold + (fun dom_id _ domains_orders -> + let vars_to_rules, chain_rules = + Mir.RuleMap.fold + (fun rov_id rule (vars, rules) -> + let rule_domain = rule.rule_domain in + let is_max = StrSetSet.mem dom_id rule_domain.rdom_max in + let is_eq = rule_domain.rdom_id = dom_id in + let is_not_rule_0 = Pos.unmark rule.rule_number <> RuleID 0 in + if is_not_rule_0 && (is_max || is_eq) then + ( List.fold_left + (fun vars (vid, _def) -> + let var = VariableDict.find vid program.program_vars in + VariableMap.add var rov_id vars) + vars rule.rule_vars, + RuleMap.add rov_id rule rules ) + else (vars, rules)) + program.program_rules + (VariableMap.empty, RuleMap.empty) + in + let dep_graph = + Mir_dependency_graph.create_rules_dependency_graph chain_rules + vars_to_rules + in + let execution_order = + Mir_dependency_graph.get_rules_execution_order dep_graph + in + StrSetMap.add dom_id { dep_graph; execution_order } domains_orders) + program.program_domains StrSetMap.empty + in + let chainings_orders = + let chainings_roots = + StrMap.map + (fun chain_dom -> + let dep_graph = + (StrSetMap.find chain_dom.rdom_id domains_orders).dep_graph + in + (dep_graph, [])) + program.program_chainings + in + let chainings_roots = + RuleMap.fold + (fun rov_id rule chainings_roots -> + match rule.rule_chain with + | Some (chain_id, _) -> + let g, rs = StrMap.find chain_id chainings_roots in + StrMap.add chain_id (g, rov_id :: rs) chainings_roots + | None -> chainings_roots) + program.program_rules chainings_roots + in + StrMap.fold + (fun chain_id (dep_graph, chain_roots) chainings_orders -> + let dep_graph, execution_order = + Mir_dependency_graph.pull_rules_dependencies dep_graph chain_roots + in + StrMap.add chain_id { dep_graph; execution_order } chainings_orders) + chainings_roots StrMap.empty + in + { program; chains_orders; domains_orders; chainings_orders } let output_var_dependencies (p : full_program) (chain : Mast.chain_tag) (var : Mir.variable) = diff --git a/src/mlang/m_ir/mir_interface.mli b/src/mlang/m_ir/mir_interface.mli index c196b91e0..22089cfc0 100644 --- a/src/mlang/m_ir/mir_interface.mli +++ b/src/mlang/m_ir/mir_interface.mli @@ -29,6 +29,8 @@ type chain_order = { type full_program = { program : Mir.program; chains_orders : chain_order Mir.TagMap.t; + domains_orders : chain_order StrSetMap.t; + chainings_orders : chain_order StrMap.t; } val to_full_program : Mir.program -> Mast.chain_tag list -> full_program From 248d4fa8e61dcdc94e494611bd6fe3a5df42faed Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Wed, 21 Jun 2023 12:35:20 +0200 Subject: [PATCH 05/26] =?UTF-8?q?S=C3=A9paration=20des=20tags,=20des=20dom?= =?UTF-8?q?aines=20de=20r=C3=A8gles=20et=20des=20encha=C3=AEneurs.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/driver.ml | 39 ++++++++++++----- src/mlang/m_frontend/mast.ml | 39 ----------------- src/mlang/m_ir/mir.ml | 41 ++++++++++++++++++ src/mlang/m_ir/mir.mli | 2 + src/mlang/m_ir/mir_interface.ml | 71 ++----------------------------- src/mlang/m_ir/mir_interface.mli | 5 +-- src/mlang/mpp_ir/mpp_ir_to_bir.ml | 24 ++++++----- 7 files changed, 90 insertions(+), 131 deletions(-) diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index b60f0f21e..fb72c0699 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -163,37 +163,54 @@ let driver (files : string list) (debug : bool) (var_info_debug : string list) Cli.debug_print "Elaborating..."; let source_m_program = !m_program in let m_program = Mast_to_mir.translate !m_program in - let full_m_program = - Mir_interface.to_full_program m_program Mast.all_tags - in + let full_m_program = Mir_interface.to_full_program m_program in let full_m_program = Mir_typechecker.expand_functions full_m_program in Cli.debug_print "Typechecking..."; let full_m_program = Mir_typechecker.typecheck full_m_program in - Mir.TagMap.iter - (fun tag Mir_interface.{ dep_graph; _ } -> + StrSetMap.iter + (fun rdom_id Mir_interface.{ dep_graph; _ } -> + Cli.debug_print + "Checking for circular variable definitions for rule domain %a..." + (StrSet.pp " ") rdom_id; + if + Mir_dependency_graph.check_for_cycle dep_graph full_m_program.program + true + then Errors.raise_error "Cycles between rules.") + full_m_program.domains_orders; + StrMap.iter + (fun chaining_id Mir_interface.{ dep_graph; _ } -> Cli.debug_print - "Checking for circular variable definitions for chain %a..." - Format_mast.format_chain_tag tag; + "Checking for circular variable definitions for chaining %s..." + chaining_id; if Mir_dependency_graph.check_for_cycle dep_graph full_m_program.program true then Errors.raise_error "Cycles between rules.") - full_m_program.chains_orders; + full_m_program.chainings_orders; let mpp = Mpp_frontend.process mpp_file full_m_program in let full_m_program = Mir_interface.to_full_program (match function_spec with | Some _ -> Mir_interface.reset_all_outputs full_m_program.program | None -> full_m_program.program) - Mast.all_tags in (match var_dependencies with | Some (var, chain) -> let var = Mir.find_var_by_name full_m_program.program (var, Pos.no_pos) in - let chain = Mast.chain_tag_of_string chain in - Mir_interface.output_var_dependencies full_m_program chain var; + let order = + try + let rdom_id = Mir.string_to_rule_domain_id chain in + match StrSetMap.find_opt rdom_id full_m_program.domains_orders with + | Some order -> order + | None -> Errors.raise_error ("unknown rule domain: " ^ chain) + with Not_found -> ( + match StrMap.find_opt chain full_m_program.chainings_orders with + | Some order -> order + | None -> Errors.raise_error ("unknown chaining: " ^ chain)) + in + Mir_interface.output_var_dependencies full_m_program order var; exit 0 | None -> ()); Cli.debug_print "Creating combined program suitable for execution..."; diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index bf9e7314c..2708731f3 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -72,45 +72,6 @@ type chain_tag = | Base_stratemajo | Non_auto_cc | Horizontale -(* Make sure to update [all_tags] below when patching this *) - -let all_tags : chain_tag list = - [ - Primitif; - Corrective; - Isf; - Taux; - (* Irisf;*) - Base_hr; - Base_tl; - Base_tl_init; - Base_tl_rect; - Base_initial; - Base_inr; - Base_inr_ref; - Base_inr_tl; - Base_inr_tl22; - Base_inr_tl24; - Base_inr_ntl; - Base_inr_ntl22; - Base_inr_ntl24; - Base_inr_inter22; - Base_inr_intertl; - Base_inr_r9901; - Base_inr_cimr07; - Base_inr_cimr24; - Base_inr_cimr99; - Base_inr_tlcimr07; - Base_inr_tlcimr24; - Base_abat98; - Base_abat99; - Base_majo; - Base_premier; - Base_anterieure; - Base_anterieure_cor; - Base_stratemajo; - (* Non_auto_cc; Horizontale;*) - ] let chain_tag_of_string : string -> chain_tag = function | "primitif" -> Primitif diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 21398bd9c..4355f1498 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -696,3 +696,44 @@ let tag_to_rule_domain_id : Mast.chain_tag -> StrSet.t = function | Mast.PrimCorr -> StrSet.from_list [ "irisf"; "corrective" ] | Mast.Custom _ -> assert false (* StrSet.from_list [ "custom"; ch ] *) + +let string_to_rule_domain_id : string -> StrSet.t = function + | "primitif" -> StrSet.from_list [ "primitive" ] + | "corrective" -> StrSet.from_list [ "corrective" ] + | "isf" -> StrSet.from_list [ "isf" ] + | "taux" -> StrSet.from_list [ "taux" ] + | "irisf" -> StrSet.from_list [ "irisf" ] + | "base_HR" -> StrSet.from_list [ "corrective"; "base_HR" ] + | "base_tl" -> StrSet.from_list [ "corrective"; "base_tl" ] + | "base_tl_init" -> StrSet.from_list [ "corrective"; "base_INITIAL" ] + | "base_tl_rect" -> StrSet.from_list [ "corrective"; "base_tl_rect" ] + | "base_INITIAL" -> StrSet.from_list [ "corrective"; "base_INITIAL" ] + | "base_INR" -> StrSet.from_list [ "corrective"; "base_INR" ] + | "base_inr_ref" -> StrSet.from_list [ "corrective"; "base_inr_ref" ] + | "base_inr_tl" -> StrSet.from_list [ "corrective"; "base_inr_tl" ] + | "base_inr_tl22" -> StrSet.from_list [ "corrective"; "base_inr_tl22" ] + | "base_inr_tl24" -> StrSet.from_list [ "corrective"; "base_inr_tl24" ] + | "base_inr_ntl" -> StrSet.from_list [ "corrective"; "base_inr_ntl" ] + | "base_inr_ntl22" -> StrSet.from_list [ "corrective"; "base_inr_ntl22" ] + | "base_inr_ntl24" -> StrSet.from_list [ "corrective"; "base_inr_ntl24" ] + | "base_inr_inter22" -> StrSet.from_list [ "corrective"; "base_inr_inter22" ] + | "base_inr_intertl" -> StrSet.from_list [ "corrective"; "base_inr_intertl" ] + | "base_inr_r9901" -> StrSet.from_list [ "corrective"; "base_inr_r9901" ] + | "base_inr_cimr07" -> StrSet.from_list [ "corrective"; "base_inr_cimr07" ] + | "base_inr_cimr24" -> StrSet.from_list [ "corrective"; "base_inr_cimr24" ] + | "base_inr_cimr99" -> StrSet.from_list [ "corrective"; "base_inr_cimr99" ] + | "base_inr_tlcimr07" -> + StrSet.from_list [ "corrective"; "base_inr_tlcimr07" ] + | "base_inr_tlcimr24" -> + StrSet.from_list [ "corrective"; "base_inr_tlcimr24" ] + | "base_ABAT98" -> StrSet.from_list [ "corrective"; "base_ABAT98" ] + | "base_ABAT99" -> StrSet.from_list [ "corrective"; "base_ABAT99" ] + | "base_MAJO" -> StrSet.from_list [ "corrective"; "base_MAJO" ] + | "base_premier" -> StrSet.from_list [ "corrective"; "base_premier" ] + | "base_anterieure" -> StrSet.from_list [ "corrective"; "base_anterieure" ] + | "base_anterieure_cor" -> + StrSet.from_list [ "corrective"; "base_anterieure_cor" ] + | "base_stratemajo" -> StrSet.from_list [ "corrective"; "base_stratemajo" ] + | "non_auto_cc" -> StrSet.from_list [ "non_auto_cc" ] + | "horizontale" -> StrSet.from_list [ "horizontale" ] + | _ -> raise Not_found diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 5537e66f1..4d5b86730 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -363,3 +363,5 @@ val find_vars_by_io : program -> io -> VariableDict.t function chooses the one with the highest execution number*) val tag_to_rule_domain_id : Mast.chain_tag -> StrSet.t + +val string_to_rule_domain_id : string -> StrSet.t diff --git a/src/mlang/m_ir/mir_interface.ml b/src/mlang/m_ir/mir_interface.ml index 4e391d391..ab919c063 100644 --- a/src/mlang/m_ir/mir_interface.ml +++ b/src/mlang/m_ir/mir_interface.ml @@ -55,73 +55,11 @@ type chain_order = { type full_program = { program : Mir.program; - chains_orders : chain_order Mir.TagMap.t; domains_orders : chain_order StrSetMap.t; chainings_orders : chain_order StrMap.t; } -let to_full_program (program : program) (chains : Mast.chain_tag list) : - full_program = - let chains_orders = - List.fold_left - (fun chains tag -> - let vars_to_rules, chain_rules = - Mir.RuleMap.fold - (fun rov_id rule (vars, rules) -> - let rule_domain = rule.rule_domain in - let tag_domain_id = tag_to_rule_domain_id tag in - let is_max = StrSetSet.mem tag_domain_id rule_domain.rdom_max in - let is_eq = rule_domain.rdom_id = tag_domain_id in - let is_not_rule_0 = Pos.unmark rule.rule_number <> RuleID 0 in - if is_not_rule_0 && (is_max || is_eq) then - ( List.fold_left - (fun vars (vid, _def) -> - let var = VariableDict.find vid program.program_vars in - VariableMap.add var rov_id vars) - vars rule.rule_vars, - RuleMap.add rov_id rule rules ) - else (vars, rules)) - program.program_rules - (VariableMap.empty, RuleMap.empty) - in - let dep_graph = - Mir_dependency_graph.create_rules_dependency_graph chain_rules - vars_to_rules - in - let execution_order = - Mir_dependency_graph.get_rules_execution_order dep_graph - in - let customs = - RuleMap.fold - (fun rov_id rule customs -> - List.fold_left - (fun customs tag -> - match tag with - | Mast.Custom _ -> begin - match TagMap.find_opt tag customs with - | Some rs -> TagMap.add tag (rov_id :: rs) customs - | None -> TagMap.add tag [ rov_id ] customs - end - | _ -> customs) - customs rule.rule_tags) - chain_rules TagMap.empty - in - let customs = - TagMap.map - (fun rules -> - Mir_dependency_graph.pull_rules_dependencies dep_graph rules) - customs - in - let chains = - TagMap.fold - (fun tag (dep_graph, execution_order) chains -> - TagMap.add tag { dep_graph; execution_order } chains) - customs - (Mir.TagMap.add tag { dep_graph; execution_order } chains) - in - chains) - Mir.TagMap.empty chains - in +let to_full_program (program : program) : full_program = let domains_orders = StrSetMap.fold (fun dom_id _ domains_orders -> @@ -181,13 +119,12 @@ let to_full_program (program : program) (chains : Mast.chain_tag list) : StrMap.add chain_id { dep_graph; execution_order } chainings_orders) chainings_roots StrMap.empty in - { program; chains_orders; domains_orders; chainings_orders } + { program; domains_orders; chainings_orders } -let output_var_dependencies (p : full_program) (chain : Mast.chain_tag) +let output_var_dependencies (p : full_program) (order : chain_order) (var : Mir.variable) = - let chain = TagMap.find chain p.chains_orders in let deps = - Mir_dependency_graph.get_var_dependencies p.program chain.execution_order + Mir_dependency_graph.get_var_dependencies p.program order.execution_order var in List.iter diff --git a/src/mlang/m_ir/mir_interface.mli b/src/mlang/m_ir/mir_interface.mli index 22089cfc0..6f9693abb 100644 --- a/src/mlang/m_ir/mir_interface.mli +++ b/src/mlang/m_ir/mir_interface.mli @@ -28,15 +28,14 @@ type chain_order = { type full_program = { program : Mir.program; - chains_orders : chain_order Mir.TagMap.t; domains_orders : chain_order StrSetMap.t; chainings_orders : chain_order StrMap.t; } -val to_full_program : Mir.program -> Mast.chain_tag list -> full_program +val to_full_program : Mir.program -> full_program (** Creates the dependency graph and stores it *) val output_var_dependencies : - full_program -> Mast.chain_tag -> Mir.variable -> unit + full_program -> chain_order -> Mir.variable -> unit (** Print list of input variables effecting the valuation of the given variable in the given chain *) diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml index 120eefa13..c0946e942 100644 --- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml +++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml @@ -199,7 +199,7 @@ let translate_m_code (m_program : Mir_interface.full_program) vars let wrap_m_code_call (m_program : Mir_interface.full_program) - (chain_tag : Mast.chain_tag) (ctx : translation_ctx) : + (order : Mir_interface.chain_order) (ctx : translation_ctx) : translation_ctx * Bir.stmt list = let m_program = { @@ -209,15 +209,12 @@ let wrap_m_code_call (m_program : Mir_interface.full_program) m_program.program ctx.variables_used_as_inputs; } in - let execution_order = - (Mir.TagMap.find chain_tag m_program.chains_orders).execution_order - in let program_stmts = List.fold_left (fun stmts rov_id -> let rule = Mir.RuleMap.find rov_id m_program.program.program_rules in Pos.same_pos_as (Bir.SRovCall rov_id) rule.Mir.rule_number :: stmts) - [] execution_order + [] order.execution_order in let program_stmts = List.rev program_stmts in (ctx, program_stmts) @@ -412,18 +409,23 @@ and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list) pos ); ] ) | Mpp_ir.Expr (Call (Program chain_tag, _args), _) -> - let ctx = - let used_rule_domains, used_chainings = + let order, ctx = + let order, used_rule_domains, used_chainings = match chain_tag with | Custom ch -> - (ctx.used_rule_domains, StrSet.add ch ctx.used_chainings) + let order = StrMap.find ch m_program.chainings_orders in + (order, ctx.used_rule_domains, StrSet.add ch ctx.used_chainings) | _ -> + let rdom_id = Mir.tag_to_rule_domain_id chain_tag in + let order = StrSetMap.find rdom_id m_program.domains_orders in let dom = Mir.tag_to_rule_domain_id chain_tag in - (StrSetSet.add dom ctx.used_rule_domains, ctx.used_chainings) + ( order, + StrSetSet.add dom ctx.used_rule_domains, + ctx.used_chainings ) in - { ctx with used_rule_domains; used_chainings } + (order, { ctx with used_rule_domains; used_chainings }) in - wrap_m_code_call m_program chain_tag ctx + wrap_m_code_call m_program order ctx | Mpp_ir.Expr (Call (Verif (chain_tag, filter), _args), _) -> ( { ctx with verif_seen = true }, generate_verif_call m_program chain_tag filter ) From b451fbe9caab4fa8bcc3dc63ba75aef72ca5d517 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Wed, 21 Jun 2023 17:06:30 +0200 Subject: [PATCH 06/26] Ajout de modules utiles (ensemble d'ensembles, etc.) --- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 11 ++-- .../backend_compilers/dgfip_gen_files.ml | 24 ++++----- src/mlang/backend_ir/bir.ml | 2 +- src/mlang/driver.ml | 2 +- src/mlang/m_frontend/mast_to_mir.ml | 2 +- src/mlang/m_frontend/mast_to_mir.mli | 2 +- src/mlang/utils/pos.ml | 2 +- src/mlang/utils/pos.mli | 2 +- src/mlang/utils/setExt.ml | 44 ++++++++++++++++ src/mlang/utils/setExt.mli | 17 ++++++ src/mlang/utils/setSetExt.ml | 52 +++++++++++++++++++ src/mlang/utils/setSetExt.mli | 21 ++++++++ src/mlang/utils/strMap.ml | 2 + src/mlang/utils/strMap.mli | 4 +- src/mlang/utils/strSet.ml | 22 ++------ src/mlang/utils/strSet.mli | 8 +-- src/mlang/utils/strSetMap.ml | 2 + src/mlang/utils/strSetMap.mli | 4 +- src/mlang/utils/strSetSet.ml | 23 ++------ src/mlang/utils/strSetSet.mli | 8 +-- 20 files changed, 177 insertions(+), 77 deletions(-) create mode 100644 src/mlang/utils/setExt.ml create mode 100644 src/mlang/utils/setExt.mli create mode 100644 src/mlang/utils/setSetExt.ml create mode 100644 src/mlang/utils/setSetExt.mli diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index accd7d453..3beea62b3 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -425,7 +425,6 @@ let generate_mpp_functions_signatures (oc : Format.formatter) let generate_rovs_files (dgfip_flags : Dgfip_options.flags) (program : program) (folder : string) (vm : Dgfip_varid.var_id_map) = - let module StringMap = Map.Make (String) in let default_file = "default" in let filemap = ROVMap.fold @@ -438,14 +437,12 @@ let generate_rovs_files (dgfip_flags : Dgfip_options.flags) (program : program) ^ ".c" in let filerovs = - match StringMap.find_opt file filemap with - | None -> [] - | Some fr -> fr + match StrMap.find_opt file filemap with None -> [] | Some fr -> fr in - StringMap.add file (rov :: filerovs) filemap) - program.rules_and_verifs StringMap.empty + StrMap.add file (rov :: filerovs) filemap) + program.rules_and_verifs StrMap.empty in - StringMap.fold + StrMap.fold (fun file rovs orphan -> if String.equal file default_file then rovs @ orphan else diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index 304935b4a..093e25e77 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -14,9 +14,6 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -module StringSet = Set.Make (String) -module StringMap = Map.Make (String) - let ascii_to_ebcdic = [| 0; 1; 2; 3; 55; 45; 46; 47; 22; 5; 37; 11; 12; 13; 14; 15; @@ -863,7 +860,7 @@ let get_rules_verif_etc prog = ( Pos.unmark r.rule_number :: rules, match r.rule_chaining with | None -> chainings - | Some cn -> StringSet.add (Pos.unmark cn) chainings ) + | Some cn -> StrSet.add (Pos.unmark cn) chainings ) else (rules, chainings) in (rules, verifs, errors, chainings) @@ -884,8 +881,7 @@ let get_rules_verif_etc prog = | _ -> (rules, verifs, errors, chainings)) (rules, verifs, errors, chainings) file) - ([], [], [], StringSet.empty) - prog + ([], [], [], StrSet.empty) prog in let rules = List.fast_sort compare rules in @@ -920,12 +916,10 @@ let gen_table_call fmt flags vars_debug rules chainings errors = Format.fprintf fmt "};\n\n" end; - StringSet.iter - (fun cn -> Format.fprintf fmt "extern void %s();\n" cn) - chainings; + StrSet.iter (fun cn -> Format.fprintf fmt "extern void %s();\n" cn) chainings; Format.fprintf fmt "T_desc_ench desc_ench[NB_ENCH + 1] = {\n"; - StringSet.iter + StrSet.iter (fun cn -> Format.fprintf fmt " { \"%s\", %s },\n" cn cn) chainings; Format.fprintf fmt "};\n" @@ -982,7 +976,7 @@ let gen_var_h fmt flags vars vars_debug rules verifs chainings errors = let nb_variation = count vars (Input (Some Variation)) in let nb_penalite = count vars (Input (Some Penality)) in let nb_restituee = count vars Output in - let nb_ench = StringSet.cardinal chainings in + let nb_ench = StrSet.cardinal chainings in let nb_err = List.length errors in let nb_debug = List.map List.length vars_debug in let nb_call = List.length rules in @@ -1165,11 +1159,11 @@ let extract_var_ids (cprog : Bir.program) vars = let pvars = cprog.mir_program.program_vars in let add vn v vm = let vs = - match StringMap.find_opt vn vm with + match StrMap.find_opt vn vm with | None -> VariableSet.empty | Some vs -> vs in - StringMap.add (Pos.unmark v.Variable.name) (VariableSet.add v vs) vm + StrMap.add (Pos.unmark v.Variable.name) (VariableSet.add v vs) vm in (* Build a map from variable names to all their definitions (with different ids) *) @@ -1178,7 +1172,7 @@ let extract_var_ids (cprog : Bir.program) vars = (fun v vm -> let vm = add (Pos.unmark v.Variable.name) v vm in match v.Variable.alias with Some a -> add a v vm | None -> vm) - pvars StringMap.empty + pvars StrMap.empty in let process_var ~alias ( tvar, @@ -1209,7 +1203,7 @@ let extract_var_ids (cprog : Bir.program) vars = (fun vm vd -> let name, vid = process_var ~alias:false vd in let vs = - try StringMap.find name vars_map + try StrMap.find name vars_map with Not_found -> Errors.raise_error (Format.asprintf "Variable %s is undeclared" name) in diff --git a/src/mlang/backend_ir/bir.ml b/src/mlang/backend_ir/bir.ml index 5cf7e2c0f..fac0e5e72 100644 --- a/src/mlang/backend_ir/bir.ml +++ b/src/mlang/backend_ir/bir.ml @@ -43,7 +43,7 @@ module VariableSet = Set.Make (struct let compare = compare_variable end) -module NameMap = Map.Make (String) +module NameMap = StrMap type offset_alloc = { mutable name_map : int NameMap.t; mutable size : int } diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index fb72c0699..b0efe2bd0 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -171,7 +171,7 @@ let driver (files : string list) (debug : bool) (var_info_debug : string list) (fun rdom_id Mir_interface.{ dep_graph; _ } -> Cli.debug_print "Checking for circular variable definitions for rule domain %a..." - (StrSet.pp " ") rdom_id; + (StrSet.pp ()) rdom_id; if Mir_dependency_graph.check_for_cycle dep_graph full_m_program.program true diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index d97039541..1436c0566 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -35,7 +35,7 @@ type var_decl_data = { } (** Intermediate container for variable declaration info *) -module ConstMap = Map.Make (String) +module ConstMap = StrMap (** {2 Loop translation context} *) diff --git a/src/mlang/m_frontend/mast_to_mir.mli b/src/mlang/m_frontend/mast_to_mir.mli index 2a27d3096..6152c63c4 100644 --- a/src/mlang/m_frontend/mast_to_mir.mli +++ b/src/mlang/m_frontend/mast_to_mir.mli @@ -27,7 +27,7 @@ (** The values of the map can be either strings of integers *) type loop_param_value = VarName of Mast.variable_name | RangeInt of int -module ConstMap : Map.S with type key = Mast.variable_name +module ConstMap : StrMap.T module ParamsMap : Map.S with type key = Char.t (** Map whose keys are loop parameters *) diff --git a/src/mlang/utils/pos.ml b/src/mlang/utils/pos.ml index 7f38ac7bd..969eeccd6 100644 --- a/src/mlang/utils/pos.ml +++ b/src/mlang/utils/pos.ml @@ -87,7 +87,7 @@ let same_pos_as (x : 'a) ((_, y) : 'b marked) : 'a marked = (x, y) let unmark_option (x : 'a marked option) : 'a option = match x with Some x -> Some (unmark x) | None -> None -module VarNameToID = Map.Make (String) +module VarNameToID = StrMap let get_start_line (pos : t) : int = let s, _ = pos.pos_loc in diff --git a/src/mlang/utils/pos.mli b/src/mlang/utils/pos.mli index 5841083a4..1e2c3f62a 100644 --- a/src/mlang/utils/pos.mli +++ b/src/mlang/utils/pos.mli @@ -45,7 +45,7 @@ val same_pos_as : 'a -> 'b marked -> 'a marked val unmark_option : 'a marked option -> 'a option -module VarNameToID : Map.S with type key = string +module VarNameToID : StrMap.T val get_start_line : t -> int diff --git a/src/mlang/utils/setExt.ml b/src/mlang/utils/setExt.ml new file mode 100644 index 000000000..f6690d8f9 --- /dev/null +++ b/src/mlang/utils/setExt.ml @@ -0,0 +1,44 @@ +module type T = sig + include Set.S + + val from_list : elt list -> t + + val from_marked_list : elt Pos.marked list -> t + + val pp : + ?sep:string -> + ?pp_elt:(Format.formatter -> elt -> unit) -> + unit -> + Format.formatter -> + t -> + unit +end + +module Make = +functor + (Ord : Set.OrderedType) + -> + struct + include Set.Make (Ord) + + let from_list (l : elt list) : t = + let fold set elt = add elt set in + List.fold_left fold empty l + + let from_marked_list (l : elt Pos.marked list) : t = + let fold set elt = add (Pos.unmark elt) set in + List.fold_left fold empty l + + let pp_nil (_ : Format.formatter) (_ : elt) = () + + let pp ?(sep = " ") ?(pp_elt = pp_nil) (_ : unit) (fmt : Format.formatter) + (set : t) : unit = + let foldSet elt first = + let _ = + if first then Format.fprintf fmt "%a" pp_elt elt + else Format.fprintf fmt "%s%a" sep pp_elt elt + in + false + in + ignore (fold foldSet set true) + end diff --git a/src/mlang/utils/setExt.mli b/src/mlang/utils/setExt.mli new file mode 100644 index 000000000..4b6996648 --- /dev/null +++ b/src/mlang/utils/setExt.mli @@ -0,0 +1,17 @@ +module type T = sig + include Set.S + + val from_list : elt list -> t + + val from_marked_list : elt Pos.marked list -> t + + val pp : + ?sep:string -> + ?pp_elt:(Format.formatter -> elt -> unit) -> + unit -> + Format.formatter -> + t -> + unit +end + +module Make : functor (Ord : Set.OrderedType) -> T with type elt = Ord.t diff --git a/src/mlang/utils/setSetExt.ml b/src/mlang/utils/setSetExt.ml new file mode 100644 index 000000000..0e4f167a5 --- /dev/null +++ b/src/mlang/utils/setSetExt.ml @@ -0,0 +1,52 @@ +module type T = sig + type base_elt + + include SetExt.T + + val from_list_list : base_elt list list -> t + + val from_marked_list_list : base_elt Pos.marked list Pos.marked list -> t + + val pp : + ?sep1:string -> + ?sep2:string -> + ?pp_elt:(Format.formatter -> base_elt -> unit) -> + unit -> + Format.formatter -> + t -> + unit +end + +module Make = +functor + (SetElt : SetExt.T) + -> + struct + type base_elt = SetElt.elt + + include SetExt.Make (SetElt) + + let from_list_list (ll : base_elt list list) : t = + let fold setSet l = add (SetElt.from_list l) setSet in + List.fold_left fold empty ll + + let from_marked_list_list (ll : base_elt Pos.marked list Pos.marked list) : + t = + let fold setSet l = add (SetElt.from_marked_list (Pos.unmark l)) setSet in + List.fold_left fold empty ll + + let pp_nil (_ : Format.formatter) (_ : base_elt) = () + + let pp ?(sep1 = ", ") ?(sep2 = " ") ?(pp_elt = pp_nil) (_ : unit) + (fmt : Format.formatter) (setSet : t) : unit = + let foldSetSet set first = + let _ = + if first then + Format.fprintf fmt "%a" (SetElt.pp ~sep:sep2 ~pp_elt ()) set + else + Format.fprintf fmt "%s%a" sep1 (SetElt.pp ~sep:sep2 ~pp_elt ()) set + in + false + in + ignore (fold foldSetSet setSet true) + end diff --git a/src/mlang/utils/setSetExt.mli b/src/mlang/utils/setSetExt.mli new file mode 100644 index 000000000..8f3a4172d --- /dev/null +++ b/src/mlang/utils/setSetExt.mli @@ -0,0 +1,21 @@ +module type T = sig + type base_elt + + include SetExt.T + + val from_list_list : base_elt list list -> t + + val from_marked_list_list : base_elt Pos.marked list Pos.marked list -> t + + val pp : + ?sep1:string -> + ?sep2:string -> + ?pp_elt:(Format.formatter -> base_elt -> unit) -> + unit -> + Format.formatter -> + t -> + unit +end + +module Make : functor (SetElt : SetExt.T) -> + T with type base_elt = SetElt.elt and type elt = SetElt.t diff --git a/src/mlang/utils/strMap.ml b/src/mlang/utils/strMap.ml index 99d658088..f81653a15 100644 --- a/src/mlang/utils/strMap.ml +++ b/src/mlang/utils/strMap.ml @@ -1 +1,3 @@ include Map.Make (String) + +module type T = Map.S with type key = String.t diff --git a/src/mlang/utils/strMap.mli b/src/mlang/utils/strMap.mli index e6228cc68..4da363d37 100644 --- a/src/mlang/utils/strMap.mli +++ b/src/mlang/utils/strMap.mli @@ -1 +1,3 @@ -include Map.S with type key = String.t +module type T = Map.S with type key = String.t + +include T diff --git a/src/mlang/utils/strSet.ml b/src/mlang/utils/strSet.ml index db0e7fee5..4071ae3bf 100644 --- a/src/mlang/utils/strSet.ml +++ b/src/mlang/utils/strSet.ml @@ -1,19 +1,7 @@ -include Set.Make (String) +module type T = SetExt.T with type elt = String.t -let from_list (l : string list) : t = - let fold set str = add str set in - List.fold_left fold empty l +include SetExt.Make (String) -let from_marked_list (l : string Pos.marked list) : t = - let fold set str = add (Pos.unmark str) set in - List.fold_left fold empty l - -let pp (sep : string) (fmt : Format.formatter) (set : t) : unit = - let foldSet str first = - let _ = - if first then Format.fprintf fmt "%s" str - else Format.fprintf fmt "%s%s" sep str - in - false - in - ignore (fold foldSet set true) +let pp ?(sep = " ") ?(pp_elt = Format.pp_print_string) (_ : unit) + (fmt : Format.formatter) (set : t) : unit = + pp ~sep ~pp_elt () fmt set diff --git a/src/mlang/utils/strSet.mli b/src/mlang/utils/strSet.mli index c996938a5..752684446 100644 --- a/src/mlang/utils/strSet.mli +++ b/src/mlang/utils/strSet.mli @@ -1,7 +1,3 @@ -include Set.S with type elt = String.t +module type T = SetExt.T with type elt = string -val from_list : string list -> t - -val from_marked_list : string Pos.marked list -> t - -val pp : string -> Format.formatter -> t -> unit +include T diff --git a/src/mlang/utils/strSetMap.ml b/src/mlang/utils/strSetMap.ml index e6405c6d1..d444ac506 100644 --- a/src/mlang/utils/strSetMap.ml +++ b/src/mlang/utils/strSetMap.ml @@ -1 +1,3 @@ include Map.Make (StrSet) + +module type T = Map.S with type key = StrSet.t diff --git a/src/mlang/utils/strSetMap.mli b/src/mlang/utils/strSetMap.mli index 5161fec6e..7c6d12874 100644 --- a/src/mlang/utils/strSetMap.mli +++ b/src/mlang/utils/strSetMap.mli @@ -1 +1,3 @@ -include Map.S with type key = StrSet.t +module type T = Map.S with type key = StrSet.t + +include T diff --git a/src/mlang/utils/strSetSet.ml b/src/mlang/utils/strSetSet.ml index 2b4fa7074..c54a4c75e 100644 --- a/src/mlang/utils/strSetSet.ml +++ b/src/mlang/utils/strSetSet.ml @@ -1,20 +1,7 @@ -include Set.Make (StrSet) +include SetSetExt.Make (StrSet) -let from_list_list (ll : string list list) : t = - let fold setSet l = add (StrSet.from_list l) setSet in - List.fold_left fold empty ll +module type T = SetSetExt.T with type base_elt = string and type elt = StrSet.t -let from_marked_list_list (ll : string Pos.marked list Pos.marked list) : t = - let fold setSet l = add (StrSet.from_marked_list (Pos.unmark l)) setSet in - List.fold_left fold empty ll - -let pp (sep1 : string) (sep2 : string) (fmt : Format.formatter) (setSet : t) : - unit = - let foldSetSet set first = - let _ = - if first then Format.fprintf fmt "%a" (StrSet.pp sep2) set - else Format.fprintf fmt "%s%a" sep1 (StrSet.pp sep2) set - in - false - in - ignore (fold foldSetSet setSet true) +let pp ?(sep1 = ", ") ?(sep2 = " ") ?(pp_elt = Format.pp_print_string) + (_ : unit) (fmt : Format.formatter) (setSet : t) : unit = + pp ~sep1 ~sep2 ~pp_elt () fmt setSet diff --git a/src/mlang/utils/strSetSet.mli b/src/mlang/utils/strSetSet.mli index 37a71055c..60d220b44 100644 --- a/src/mlang/utils/strSetSet.mli +++ b/src/mlang/utils/strSetSet.mli @@ -1,7 +1,3 @@ -include Set.S with type elt = StrSet.t +module type T = SetSetExt.T with type base_elt = string and type elt = StrSet.t -val from_list_list : string list list -> t - -val from_marked_list_list : string Pos.marked list Pos.marked list -> t - -val pp : string -> string -> Format.formatter -> t -> unit +include T From e49c8594a6f7f027151ae9fdf54f4b58c7d32dca Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Fri, 23 Jun 2023 11:11:50 +0200 Subject: [PATCH 07/26] Ajout de modules utiles (map d'ensembles, etc.) --- src/mlang/backend_ir/bir.ml | 6 +- src/mlang/backend_ir/bir.mli | 6 +- src/mlang/backend_ir/bir_instrumentation.ml | 4 +- src/mlang/backend_ir/bir_instrumentation.mli | 4 +- src/mlang/m_frontend/mast_to_mir.ml | 19 +++---- src/mlang/m_frontend/mast_to_mir.mli | 2 +- src/mlang/m_ir/format_mir.ml | 11 +--- src/mlang/m_ir/mir.ml | 60 ++++++++++---------- src/mlang/m_ir/mir.mli | 29 ++-------- src/mlang/mpp_ir/mpp_ir_to_bir.ml | 23 +++----- src/mlang/optimizing_ir/dead_code_removal.ml | 2 +- src/mlang/optimizing_ir/oir.ml | 2 +- src/mlang/optimizing_ir/oir.mli | 2 +- src/mlang/test_framework/test_interpreter.ml | 2 - src/mlang/utils/charMap.ml | 8 +++ src/mlang/utils/charMap.mli | 3 + src/mlang/utils/dict.ml | 2 +- src/mlang/utils/intMap.ml | 8 +++ src/mlang/utils/intMap.mli | 3 + src/mlang/utils/intSet.ml | 7 +++ src/mlang/utils/intSet.mli | 3 + src/mlang/utils/mapExt.ml | 43 ++++++++++++++ src/mlang/utils/mapExt.mli | 16 ++++++ src/mlang/utils/setExt.ml | 15 +++-- src/mlang/utils/strMap.ml | 9 ++- src/mlang/utils/strMap.mli | 2 +- src/mlang/utils/strSet.ml | 2 +- src/mlang/utils/strSetMap.ml | 9 ++- src/mlang/utils/strSetMap.mli | 2 +- 29 files changed, 184 insertions(+), 120 deletions(-) create mode 100644 src/mlang/utils/charMap.ml create mode 100644 src/mlang/utils/charMap.mli create mode 100644 src/mlang/utils/intMap.ml create mode 100644 src/mlang/utils/intMap.mli create mode 100644 src/mlang/utils/intSet.ml create mode 100644 src/mlang/utils/intSet.mli create mode 100644 src/mlang/utils/mapExt.ml create mode 100644 src/mlang/utils/mapExt.mli diff --git a/src/mlang/backend_ir/bir.ml b/src/mlang/backend_ir/bir.ml index fac0e5e72..cdad44d7f 100644 --- a/src/mlang/backend_ir/bir.ml +++ b/src/mlang/backend_ir/bir.ml @@ -31,13 +31,13 @@ let compare_variable v1 v2 = let c = Stdlib.compare v1.offset v2.offset in if c <> 0 then c else Mir.Variable.compare v1.mir_var v2.mir_var -module VariableMap = Map.Make (struct +module VariableMap = MapExt.Make (struct type t = variable let compare = compare_variable end) -module VariableSet = Set.Make (struct +module VariableSet = SetExt.Make (struct type t = variable let compare = compare_variable @@ -115,7 +115,7 @@ let rule_or_verif_as_statements (rov : rule_or_verif) : stmt list = type mpp_function = { mppf_stmts : stmt list; mppf_is_verif : bool } -module FunctionMap = Map.Make (struct +module FunctionMap = MapExt.Make (struct type t = function_name let compare = String.compare diff --git a/src/mlang/backend_ir/bir.mli b/src/mlang/backend_ir/bir.mli index 189091673..0b5e6e561 100644 --- a/src/mlang/backend_ir/bir.mli +++ b/src/mlang/backend_ir/bir.mli @@ -22,9 +22,9 @@ type tgv_id = string type variable = { on_tgv : tgv_id; offset : int; mir_var : Mir.Variable.t } -module VariableMap : Map.S with type key = variable +module VariableMap : MapExt.T with type key = variable -module VariableSet : Set.S with type elt = variable +module VariableSet : SetExt.T with type elt = variable type expression = variable Mir.expression_ @@ -53,7 +53,7 @@ and stmt_kind = type mpp_function = { mppf_stmts : stmt list; mppf_is_verif : bool } -module FunctionMap : Map.S with type key = function_name +module FunctionMap : MapExt.T with type key = function_name type program_context = { constant_inputs_init_stmts : stmt list; diff --git a/src/mlang/backend_ir/bir_instrumentation.ml b/src/mlang/backend_ir/bir_instrumentation.ml index 4674f8338..2536a7543 100644 --- a/src/mlang/backend_ir/bir_instrumentation.ml +++ b/src/mlang/backend_ir/bir_instrumentation.ml @@ -14,7 +14,7 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -module CodeLocationMap = Map.Make (struct +module CodeLocationMap = MapExt.Make (struct type t = Bir_interpreter.code_location let compare x y = compare x y @@ -46,7 +46,7 @@ let code_coverage_init () : unit = let code_coverage_result () : code_coverage_result = !code_coverage_acc -module VarLiteralSet = Set.Make (struct +module VarLiteralSet = SetExt.Make (struct type t = Bir_interpreter.var_literal let compare x y = diff --git a/src/mlang/backend_ir/bir_instrumentation.mli b/src/mlang/backend_ir/bir_instrumentation.mli index 18d3fc541..b432eea1b 100644 --- a/src/mlang/backend_ir/bir_instrumentation.mli +++ b/src/mlang/backend_ir/bir_instrumentation.mli @@ -18,7 +18,7 @@ (** {1 Code coverage for a single run}*) -module CodeLocationMap : Map.S with type key = Bir_interpreter.code_location +module CodeLocationMap : MapExt.T with type key = Bir_interpreter.code_location type code_coverage_result = Bir_interpreter.var_literal CodeLocationMap.t Bir.VariableMap.t @@ -40,7 +40,7 @@ val code_coverage_result : unit -> code_coverage_result (** Code coverage is best measured for multiple runs of the interpreter on a set of test files. *) -module VarLiteralSet : Set.S with type elt = Bir_interpreter.var_literal +module VarLiteralSet : SetExt.T with type elt = Bir_interpreter.var_literal type code_coverage_map_value = VarLiteralSet.t diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 1436c0566..ae07e9f3d 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -40,13 +40,12 @@ module ConstMap = StrMap (** {2 Loop translation context} *) module ParamsMap = struct - include Map.Make (Char) + include CharMap - let map_printer value_printer fmt map = - Format.fprintf fmt "{ %a }" - (fun fmt -> - iter (fun k v -> Format.fprintf fmt "%c=%a; " k value_printer v)) - map + let pp ?(sep = "; ") ?(pp_key = Format.pp_print_char) ?(assoc = "=") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map end type loop_param_value = VarName of Mast.variable_name | RangeInt of int @@ -64,12 +63,10 @@ type loop_domain = (loop_param_value * int) list ParamsMap.t (** Loops can have multiple loop parameters *) let _format_loop_context fmt (ld : loop_context) = - ParamsMap.map_printer format_loop_param_value fmt ld + ParamsMap.pp format_loop_param_value fmt ld let _format_loop_domain fmt (ld : loop_domain) = - ParamsMap.map_printer - (Format_mast.pp_print_list_comma format_loop_param_value) - fmt ld + ParamsMap.pp (Format_mast.pp_print_list_comma format_loop_param_value) fmt ld (** From a loop domain of varying loop parameters, builds by cartesian product the list of all iterations that the loop will take, each time assigining a @@ -177,8 +174,6 @@ let find_var_among_candidates (exec_number : Mir.execution_number) if List.length same_rule = 0 then list_max_execution_number l else list_max_execution_number same_rule -module IntMap = Map.Make (Int) - (** Implementation of legacy hack to use TGV variables as reusable local variables *) let is_vartmp (v : Mir.Variable.t) = diff --git a/src/mlang/m_frontend/mast_to_mir.mli b/src/mlang/m_frontend/mast_to_mir.mli index 6152c63c4..ce8d35ca4 100644 --- a/src/mlang/m_frontend/mast_to_mir.mli +++ b/src/mlang/m_frontend/mast_to_mir.mli @@ -29,7 +29,7 @@ type loop_param_value = VarName of Mast.variable_name | RangeInt of int module ConstMap : StrMap.T -module ParamsMap : Map.S with type key = Char.t +module ParamsMap : CharMap.T (** Map whose keys are loop parameters *) type loop_context = (loop_param_value * int) ParamsMap.t diff --git a/src/mlang/m_ir/format_mir.ml b/src/mlang/m_ir/format_mir.ml index fdf2ceaa9..7e688cb9b 100644 --- a/src/mlang/m_ir/format_mir.ml +++ b/src/mlang/m_ir/format_mir.ml @@ -111,7 +111,7 @@ let format_variable_def fmt (def : variable_def) = (Pos.unmark v.Variable.name) format_expression (Pos.unmark e) | TableVar (_, IndexTable defs) -> - IndexMap.map_printer (Format_mast.pp_unmark format_expression) fmt defs + IndexMap.pp (Format_mast.pp_unmark format_expression) fmt defs let format_variable_data fmt (def : variable_data) = Format.fprintf fmt "type %a, io %a:\n%a" @@ -122,14 +122,7 @@ let format_variable_data fmt (def : variable_data) = () format_io def.var_io format_variable_def def.var_definition let format_variables fmt (p : variable_data VariableMap.t) = - VariableMap.map_printer - (fun fmt var -> - Format.fprintf fmt "Variable %s%s" - (Pos.unmark var.Variable.name) - (match var.Variable.alias with - | Some x -> " (alias " ^ x ^ ")" - | None -> "")) - format_variable_data fmt p + VariableMap.pp format_variable_data fmt p let format_error fmt (e : Error.t) = Format.fprintf fmt "erreur %s (%s)" (Pos.unmark e.Error.name) diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 4355f1498..1ac588a2f 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -276,17 +276,22 @@ let rec fold_expr_var (f : 'a -> 'v -> 'a) (acc : 'a) (e : 'v expression_) : 'a (** MIR programs are just mapping from variables to their definitions, and make a massive use of [VariableMap]. *) module VariableMap = struct - include Map.Make (Variable) - - let map_printer key_printer value_printer fmt map = - Format.fprintf fmt "{ %a }" - (fun fmt -> - iter (fun k v -> - Format.fprintf fmt "%a ~> %a, " key_printer k value_printer v)) - map + include MapExt.Make (Variable) + + let pp_key fmt key = + Format.fprintf fmt "Variable %s%s" + (Pos.unmark key.Variable.name) + (match key.Variable.alias with + | Some x -> " (alias " ^ x ^ ")" + | None -> "") + + let pp ?(sep = ", ") ?(pp_key = pp_key) ?(assoc = " -> ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map end -(* module VariableDictMap = Map.Make (struct +(* module VariableDictMap = MapExt.Make (struct * type t = Variable.id * * let compare = compare @@ -305,33 +310,28 @@ module VariableDict = Dict.Make (struct let compare = compare end) -module VariableSet = Set.Make (Variable) +module VariableSet = SetExt.Make (Variable) module LocalVariableMap = struct - include Map.Make (LocalVariable) - - let map_printer value_printer fmt map = - Format.fprintf fmt "{ %a }" - (fun fmt -> - iter (fun var v -> - Format.fprintf fmt "%d ~> %a, " var.id value_printer v)) - map + include MapExt.Make (LocalVariable) + + let pp_key fmt key = Format.fprintf fmt "%d" key.id + + let pp ?(sep = ", ") ?(pp_key = pp_key) ?(assoc = " -> ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map end (** This map is used to store the definitions of all the cells of a table variable that is not not defined generically *) module IndexMap = struct - include Map.Make (struct - type t = int - - let compare = compare - end) + include IntMap - let map_printer value_printer fmt map = - Format.fprintf fmt "{ %a }" - (fun fmt -> - iter (fun k v -> Format.fprintf fmt "%d ~> %a, " k value_printer v)) - map + let pp ?(sep = ", ") ?(pp_key = Format.pp_print_int) ?(assoc = " -> ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map end type 'variable index_def = @@ -406,13 +406,13 @@ type rule_data = { rule_tags : Mast.chain_tag list; } -module RuleMap = Map.Make (struct +module RuleMap = MapExt.Make (struct type t = rov_id let compare = compare end) -module TagMap = Map.Make (struct +module TagMap = MapExt.Make (struct type t = Mast.chain_tag let compare t1 t2 = diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 4d5b86730..991598d41 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -109,36 +109,19 @@ type 'variable expression_ = type expression = variable expression_ +module VariableMap : MapExt.T with type key = variable (** MIR programs are just mapping from variables to their definitions, and make a massive use of [VariableMap]. *) -module VariableMap : sig - include Map.S with type key = variable - - val map_printer : - (Format.formatter -> variable -> unit) -> - (Format.formatter -> 'a -> unit) -> - Format.formatter -> - 'a t -> - unit -end module VariableDict : Dict.S with type key = variable_id and type elt = variable -module VariableSet : Set.S with type elt = variable +module VariableSet : SetExt.T with type elt = variable module LocalVariableMap : sig - include Map.S with type key = local_variable - - val map_printer : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit + include MapExt.T with type key = local_variable end -module IndexMap : sig - include Map.S with type key = int - - val map_printer : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit -end +module IndexMap : IntMap.T type 'variable index_def = | IndexTable of @@ -166,7 +149,7 @@ type variable_data = variable variable_data_ type rov_id = RuleID of int | VerifID of int -module RuleMap : Map.S with type key = rov_id +module RuleMap : MapExt.T with type key = rov_id type rule_domain = { rdom_id : StrSet.t; @@ -185,7 +168,7 @@ type rule_data = { rule_tags : Mast.chain_tag list; } -module TagMap : Map.S with type key = Mast.chain_tag +module TagMap : MapExt.T with type key = Mast.chain_tag type error_descr = { kind : string Pos.marked; diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml index c0946e942..02931e5c4 100644 --- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml +++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml @@ -14,14 +14,8 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -module StringMap = Map.Make (struct - type t = string - - let compare = compare -end) - type translation_ctx = { - new_variables : Bir.variable StringMap.t; + new_variables : Bir.variable StrMap.t; variables_used_as_inputs : Mir.VariableDict.t; used_rule_domains : StrSetSet.t; used_chainings : StrSet.t; @@ -30,7 +24,7 @@ type translation_ctx = { let empty_translation_ctx : translation_ctx = { - new_variables = StringMap.empty; + new_variables = StrMap.empty; variables_used_as_inputs = Mir.VariableDict.empty; used_rule_domains = StrSetSet.empty; used_chainings = StrSet.empty; @@ -40,7 +34,7 @@ let empty_translation_ctx : translation_ctx = let ctx_join ctx1 ctx2 = { new_variables = - StringMap.union + StrMap.union (fun _ v1 v2 -> assert (Bir.compare_variable v1 v2 = 0); Some v2) @@ -280,7 +274,7 @@ and translate_mpp_expr (p : Mir_interface.full_program) (ctx : translation_ctx) | Mpp_ir.Constant i -> Mir.Literal (Float (float_of_int i)) | Variable (Mbased (var, _)) -> Var Bir.(var_from_mir default_tgv var) | Variable (Local l) -> ( - try Var (StringMap.find l ctx.new_variables) + try Var (StrMap.find l ctx.new_variables) with Not_found -> Cli.error_print "Local Variable %s not found in ctx" l; assert false) @@ -327,7 +321,7 @@ and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list) match Pos.unmark stmt with | Mpp_ir.Assign (Local l, expr) -> let ctx, new_l = - match StringMap.find_opt l ctx.new_variables with + match StrMap.find_opt l ctx.new_variables with | None -> let new_l = Mir.Variable.new_var @@ -338,10 +332,7 @@ and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list) |> Bir.(var_from_mir default_tgv) in let ctx = - { - ctx with - new_variables = StringMap.add l new_l ctx.new_variables; - } + { ctx with new_variables = StrMap.add l new_l ctx.new_variables } in (ctx, new_l) | Some new_l -> (ctx, new_l) @@ -386,7 +377,7 @@ and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list) stmt; ] ) | Mpp_ir.Delete (Local l) -> - let var = StringMap.find l ctx.new_variables in + let var = StrMap.find l ctx.new_variables in ( ctx, [ Pos.same_pos_as diff --git a/src/mlang/optimizing_ir/dead_code_removal.ml b/src/mlang/optimizing_ir/dead_code_removal.ml index e0f8452f0..adafa9563 100644 --- a/src/mlang/optimizing_ir/dead_code_removal.ml +++ b/src/mlang/optimizing_ir/dead_code_removal.ml @@ -15,7 +15,7 @@ this program. If not, see . *) open Oir -module PosSet = Set.Make (Int) +module PosSet = IntSet type pos_map = PosSet.t BlockMap.t Bir.VariableMap.t diff --git a/src/mlang/optimizing_ir/oir.ml b/src/mlang/optimizing_ir/oir.ml index e7225e454..3d429f3c6 100644 --- a/src/mlang/optimizing_ir/oir.ml +++ b/src/mlang/optimizing_ir/oir.ml @@ -16,7 +16,7 @@ type block_id = int -module BlockMap = Map.Make (Int) +module BlockMap = IntMap type stmt = stmt_kind Pos.marked diff --git a/src/mlang/optimizing_ir/oir.mli b/src/mlang/optimizing_ir/oir.mli index a90683467..622d8a41a 100644 --- a/src/mlang/optimizing_ir/oir.mli +++ b/src/mlang/optimizing_ir/oir.mli @@ -16,7 +16,7 @@ type block_id = int -module BlockMap : Map.S with type key = block_id +module BlockMap : MapExt.T with type key = block_id type stmt = stmt_kind Pos.marked diff --git a/src/mlang/test_framework/test_interpreter.ml b/src/mlang/test_framework/test_interpreter.ml index 7c050055c..abab5a065 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -165,8 +165,6 @@ type coverage_kind = | NotCovered | Covered of int (** The int is the number of different values *) -module IntMap = Map.Make (Int) - let incr_int_key (m : int IntMap.t) (key : int) : int IntMap.t = match IntMap.find_opt key m with | None -> IntMap.add key 0 m diff --git a/src/mlang/utils/charMap.ml b/src/mlang/utils/charMap.ml new file mode 100644 index 000000000..ddd484036 --- /dev/null +++ b/src/mlang/utils/charMap.ml @@ -0,0 +1,8 @@ +include MapExt.Make (Char) + +module type T = MapExt.T with type key = char + +let pp ?(sep = "; ") ?(pp_key = Format.pp_print_char) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map diff --git a/src/mlang/utils/charMap.mli b/src/mlang/utils/charMap.mli new file mode 100644 index 000000000..10296b6eb --- /dev/null +++ b/src/mlang/utils/charMap.mli @@ -0,0 +1,3 @@ +module type T = MapExt.T with type key = char + +include T diff --git a/src/mlang/utils/dict.ml b/src/mlang/utils/dict.ml index 74e6f7aab..0d0fe0b5d 100644 --- a/src/mlang/utils/dict.ml +++ b/src/mlang/utils/dict.ml @@ -38,7 +38,7 @@ module Make (I : sig val compare : t -> t -> int end) = struct - module DictMap = Map.Make (I) + module DictMap = MapExt.Make (I) type key = I.t diff --git a/src/mlang/utils/intMap.ml b/src/mlang/utils/intMap.ml new file mode 100644 index 000000000..e7b3a8263 --- /dev/null +++ b/src/mlang/utils/intMap.ml @@ -0,0 +1,8 @@ +include MapExt.Make (Int) + +module type T = MapExt.T with type key = int + +let pp ?(sep = "; ") ?(pp_key = Format.pp_print_int) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map diff --git a/src/mlang/utils/intMap.mli b/src/mlang/utils/intMap.mli new file mode 100644 index 000000000..3a5a3a8d9 --- /dev/null +++ b/src/mlang/utils/intMap.mli @@ -0,0 +1,3 @@ +module type T = MapExt.T with type key = int + +include T diff --git a/src/mlang/utils/intSet.ml b/src/mlang/utils/intSet.ml new file mode 100644 index 000000000..757f976b1 --- /dev/null +++ b/src/mlang/utils/intSet.ml @@ -0,0 +1,7 @@ +module type T = SetExt.T with type elt = int + +include SetExt.Make (Int) + +let pp ?(sep = " ") ?(pp_elt = Format.pp_print_int) (_ : unit) + (fmt : Format.formatter) (set : t) : unit = + pp ~sep ~pp_elt () fmt set diff --git a/src/mlang/utils/intSet.mli b/src/mlang/utils/intSet.mli new file mode 100644 index 000000000..1fc96043b --- /dev/null +++ b/src/mlang/utils/intSet.mli @@ -0,0 +1,3 @@ +module type T = SetExt.T with type elt = int + +include T diff --git a/src/mlang/utils/mapExt.ml b/src/mlang/utils/mapExt.ml new file mode 100644 index 000000000..c7068f320 --- /dev/null +++ b/src/mlang/utils/mapExt.ml @@ -0,0 +1,43 @@ +module type T = sig + include Map.S + + val from_assoc_list : (key * 'a) list -> 'a t + + val pp : + ?sep:string -> + ?pp_key:(Format.formatter -> key -> unit) -> + ?assoc:string -> + (Format.formatter -> 'a -> unit) -> + Format.formatter -> + 'a t -> + unit +end + +module Make = +functor + (Ord : Map.OrderedType) + -> + struct + include Map.Make (Ord) + + let from_assoc_list (l : (key * 'a) list) : 'a t = + let fold map (k, v) = add k v map in + List.fold_left fold empty l + + let pp_nil (_ : Format.formatter) (_ : 'b) = () + + let pp ?(sep = "; ") ?(pp_key = pp_nil) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + let pp_content fmt map = + let foldMap k v first = + let _ = + if first then Format.fprintf fmt "%a%s%a" pp_key k assoc pp_val v + else Format.fprintf fmt "%s%a%s%a" sep pp_key k assoc pp_val v + in + false + in + ignore (fold foldMap map true) + in + Format.fprintf fmt "{ %a }" pp_content map + end diff --git a/src/mlang/utils/mapExt.mli b/src/mlang/utils/mapExt.mli new file mode 100644 index 000000000..3ec1cec6e --- /dev/null +++ b/src/mlang/utils/mapExt.mli @@ -0,0 +1,16 @@ +module type T = sig + include Map.S + + val from_assoc_list : (key * 'a) list -> 'a t + + val pp : + ?sep:string -> + ?pp_key:(Format.formatter -> key -> unit) -> + ?assoc:string -> + (Format.formatter -> 'a -> unit) -> + Format.formatter -> + 'a t -> + unit +end + +module Make : functor (Ord : Set.OrderedType) -> T with type key = Ord.t diff --git a/src/mlang/utils/setExt.ml b/src/mlang/utils/setExt.ml index f6690d8f9..ae1b2ca42 100644 --- a/src/mlang/utils/setExt.ml +++ b/src/mlang/utils/setExt.ml @@ -33,12 +33,15 @@ functor let pp ?(sep = " ") ?(pp_elt = pp_nil) (_ : unit) (fmt : Format.formatter) (set : t) : unit = - let foldSet elt first = - let _ = - if first then Format.fprintf fmt "%a" pp_elt elt - else Format.fprintf fmt "%s%a" sep pp_elt elt + let pp_content fmt set = + let foldSet elt first = + let _ = + if first then Format.fprintf fmt "%a" pp_elt elt + else Format.fprintf fmt "%s%a" sep pp_elt elt + in + false in - false + ignore (fold foldSet set true) in - ignore (fold foldSet set true) + Format.fprintf fmt "{ %a }" pp_content set end diff --git a/src/mlang/utils/strMap.ml b/src/mlang/utils/strMap.ml index f81653a15..b8b25360e 100644 --- a/src/mlang/utils/strMap.ml +++ b/src/mlang/utils/strMap.ml @@ -1,3 +1,8 @@ -include Map.Make (String) +include MapExt.Make (String) -module type T = Map.S with type key = String.t +module type T = MapExt.T with type key = string + +let pp ?(sep = "; ") ?(pp_key = Format.pp_print_string) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map diff --git a/src/mlang/utils/strMap.mli b/src/mlang/utils/strMap.mli index 4da363d37..95cfd0fb4 100644 --- a/src/mlang/utils/strMap.mli +++ b/src/mlang/utils/strMap.mli @@ -1,3 +1,3 @@ -module type T = Map.S with type key = String.t +module type T = MapExt.T with type key = string include T diff --git a/src/mlang/utils/strSet.ml b/src/mlang/utils/strSet.ml index 4071ae3bf..a3a194949 100644 --- a/src/mlang/utils/strSet.ml +++ b/src/mlang/utils/strSet.ml @@ -1,4 +1,4 @@ -module type T = SetExt.T with type elt = String.t +module type T = SetExt.T with type elt = string include SetExt.Make (String) diff --git a/src/mlang/utils/strSetMap.ml b/src/mlang/utils/strSetMap.ml index d444ac506..dd4580fa7 100644 --- a/src/mlang/utils/strSetMap.ml +++ b/src/mlang/utils/strSetMap.ml @@ -1,3 +1,8 @@ -include Map.Make (StrSet) +include MapExt.Make (StrSet) -module type T = Map.S with type key = StrSet.t +module type T = MapExt.T with type key = StrSet.t + +let pp ?(sep = ", ") ?(pp_key = StrSet.pp ()) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map diff --git a/src/mlang/utils/strSetMap.mli b/src/mlang/utils/strSetMap.mli index 7c6d12874..31ec9dfd6 100644 --- a/src/mlang/utils/strSetMap.mli +++ b/src/mlang/utils/strSetMap.mli @@ -1,3 +1,3 @@ -module type T = Map.S with type key = StrSet.t +module type T = MapExt.T with type key = StrSet.t include T From 511e53196d12e637a1e5b6e5dd932a5dfa088571 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Fri, 23 Jun 2023 13:52:34 +0200 Subject: [PATCH 08/26] Ajout de l'option without_dgfip_m. --- src/mlang/dgfip_m.ml | 227 ++++++++++++++++++++++++++++++++++++++++ src/mlang/dgfip_m.mli | 7 ++ src/mlang/driver.ml | 44 +++++--- src/mlang/utils/cli.ml | 21 ++-- src/mlang/utils/cli.mli | 2 + 5 files changed, 282 insertions(+), 19 deletions(-) create mode 100644 src/mlang/dgfip_m.ml create mode 100644 src/mlang/dgfip_m.mli diff --git a/src/mlang/dgfip_m.ml b/src/mlang/dgfip_m.ml new file mode 100644 index 000000000..f56f06b94 --- /dev/null +++ b/src/mlang/dgfip_m.ml @@ -0,0 +1,227 @@ +let variable_domains_declaration = + {| +variable saisie contexte +: attribut + classe, + priorite, + categorie_TL, + modcat, + primrest; + +variable saisie famille +: attribut + classe, + priorite, + categorie_TL, + nat_code, + modcat, + primrest; + +variable saisie revenu +: attribut + classe, + priorite, + categorie_TL, + cotsoc, + ind_abat, + acompte, + avfisc, + rapcat, + sanction, + nat_code, + modcat, + primrest; + +variable saisie revenu corrective +: attribut + classe, + priorite, + categorie_TL, + cotsoc, + ind_abat, + acompte, + avfisc, + rapcat, + sanction, + nat_code, + modcat, + primrest; + +variable saisie variation +: attribut + classe, + primrest; + +variable saisie penalite +: attribut primrest; + +variable calculee +: attribut primrest; +|} + +let rule_domains_declaration = + {| +domaine regle irisf; + +domaine regle + primitive corrective, + isf corrective, + taux corrective, + modul corrective, + irisf corrective +: specialise irisf +: par_defaut; + +domaine regle isf +: specialise irisf +: calculable; + +domaine regle primitive +: specialise primitive corrective +: calculable; + +domaine regle corrective +: specialise primitive corrective +: calculable; + +domaine regle taux +: calculable; + +domaine regle modul; + +domaine regle corrective base_anterieure_cor +: calculable; + +domaine regle corrective base_anterieure +: calculable; + +domaine regle corrective base_premier +: calculable; + +domaine regle corrective base_HR +: calculable; + +domaine regle corrective base_INITIAL +: calculable; + +domaine regle corrective base_1728 +: calculable; + +domaine regle corrective base_TLNUNV +: calculable; + +domaine regle corrective base_INR +: calculable; + +domaine regle corrective base_MAJO +: calculable; + +domaine regle corrective base_ABAT98 +: calculable; + +domaine regle corrective base_ABAT99 +: calculable; + +domaine regle corrective base_tl +: calculable; + +domaine regle corrective base_tl_init +: calculable; + +domaine regle corrective base_tl_rect +: calculable; + +domaine regle corrective base_stratemajo +: calculable; + +domaine regle corrective base_inr_ref +: calculable; + +domaine regle corrective base_inr_ntl +: calculable; + +domaine regle corrective base_inr_tl +: calculable; + +domaine regle corrective base_inr_tl22 +: calculable; + +domaine regle corrective base_inr_ntl22 +: calculable; + +domaine regle corrective base_inr_tl24 +: calculable; + +domaine regle corrective base_inr_ntl24 +: calculable; + +domaine regle corrective base_inr_cimr99 +: calculable; + +domaine regle corrective base_inr_cimr07 +: calculable; + +domaine regle corrective base_inr_tlcimr07 +: calculable; + +domaine regle corrective base_inr_cimr24 +: calculable; + +domaine regle corrective base_inr_tlcimr24 +: calculable; + +domaine regle corrective base_inr_intertl +: calculable; + +domaine regle corrective base_inr_inter22 +: calculable; + +domaine regle corrective base_inr_r9901 +: calculable; +|} + +let verif_domains_declaration = + {| +domaine verif primitive corrective, isf corrective +: autorise + calculee *, + saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, + saisie variation +: auto_cc contexte, famille, revenu, revenu corrective, variation +: par_defaut; + +domaine verif primitive +: autorise + calculee *, + saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, + saisie variation +: specialise primitive corrective; + +domaine verif isf +: autorise + calculee *, + saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, + saisie variation; + +domaine verif corrective +: autorise + calculee *, + saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, + saisie variation +: specialise primitive corrective; + +domaine verif corrective horizontale +: autorise + calculee *, + saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, + saisie variation, saisie penalite +: auto_cc penalite; +|} + +let declarations = + Format.sprintf "%s%s%s" + (ignore variable_domains_declaration; + "") + rule_domains_declaration + (ignore verif_domains_declaration; + "") diff --git a/src/mlang/dgfip_m.mli b/src/mlang/dgfip_m.mli new file mode 100644 index 000000000..28676df89 --- /dev/null +++ b/src/mlang/dgfip_m.mli @@ -0,0 +1,7 @@ +val variable_domains_declaration : string + +val rule_domains_declaration : string + +val verif_domains_declaration : string + +val declarations : string diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index b0efe2bd0..b621e3471 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -73,15 +73,16 @@ let patch_rule_1 (backend : string option) (dgfip_flags : Dgfip_options.flags) (** Entry function for the executable. Returns a negative number in case of error. *) -let driver (files : string list) (debug : bool) (var_info_debug : string list) - (display_time : bool) (dep_graph_file : string) (print_cycles : bool) - (backend : string option) (function_spec : string option) - (mpp_file : string) (output : string option) (run_all_tests : string option) - (dgfip_test_filter : bool) (run_test : string option) - (mpp_function : string) (optimize : bool) (optimize_unsafe_float : bool) - (code_coverage : bool) (precision : string option) - (roundops : string option) (test_error_margin : float option) - (m_clean_calls : bool) (dgfip_options : string list option) +let driver (files : string list) (without_dgfip_m : bool) (debug : bool) + (var_info_debug : string list) (display_time : bool) + (dep_graph_file : string) (print_cycles : bool) (backend : string option) + (function_spec : string option) (mpp_file : string) (output : string option) + (run_all_tests : string option) (dgfip_test_filter : bool) + (run_test : string option) (mpp_function : string) (optimize : bool) + (optimize_unsafe_float : bool) (code_coverage : bool) + (precision : string option) (roundops : string option) + (test_error_margin : float option) (m_clean_calls : bool) + (dgfip_options : string list option) (var_dependencies : (string * string) option) = let value_sort = let precision = Option.get precision in @@ -126,15 +127,32 @@ let driver (files : string list) (debug : bool) (var_info_debug : string list) Errors.raise_error (Format.asprintf "Unkown roundops option: %s" roundops) in - Cli.set_all_arg_refs files debug var_info_debug display_time dep_graph_file - print_cycles output optimize_unsafe_float m_clean_calls value_sort round_ops; + Cli.set_all_arg_refs files without_dgfip_m debug var_info_debug display_time + dep_graph_file print_cycles output optimize_unsafe_float m_clean_calls + value_sort round_ops; try let dgfip_flags = process_dgfip_options backend dgfip_options in Cli.debug_print "Reading M files..."; - let m_program = ref [] in + let current_progress, finish = Cli.create_progress_bar "Parsing" in + let m_program = + ref + (let filebuf = Lexing.from_string Dgfip_m.declarations in + current_progress "internal DGFiP M"; + let filebuf = + { + filebuf with + lex_curr_p = + { filebuf.lex_curr_p with pos_fname = "internal DGFiP M" }; + } + in + try + let commands = Mparser.source_file token filebuf in + [ commands ] + with Mparser.Error -> + Errors.raise_error "M syntax error in internal DGFiP M") + in if List.length !Cli.source_files = 0 then Errors.raise_error "please provide at least one M source file"; - let current_progress, finish = Cli.create_progress_bar "Parsing" in List.iter (fun source_file -> let filebuf, input = diff --git a/src/mlang/utils/cli.ml b/src/mlang/utils/cli.ml index 088350105..89880ea4e 100644 --- a/src/mlang/utils/cli.ml +++ b/src/mlang/utils/cli.ml @@ -29,6 +29,12 @@ let files = non_empty & pos_all file [] & info [] ~docv:"FILES" ~doc:"M files to be compiled") +let without_dgfip_m = + Arg.( + value & flag + & info [ "without_dfgip_m" ] + ~doc:"Don't parse M definitions of DGFiP idiosyncratic datas") + let debug = Arg.(value & flag & info [ "debug"; "d" ] ~doc:"Prints debug information") @@ -201,10 +207,10 @@ let var_dependencies = let mlang_t f = Term.( - const f $ files $ debug $ var_info_debug $ display_time $ dep_graph_file - $ no_print_cycles $ backend $ function_spec $ mpp_file $ output - $ run_all_tests $ dgfip_test_filter $ run_test $ mpp_function $ optimize - $ optimize_unsafe_float $ code_coverage $ precision $ roundops + const f $ files $ without_dgfip_m $ debug $ var_info_debug $ display_time + $ dep_graph_file $ no_print_cycles $ backend $ function_spec $ mpp_file + $ output $ run_all_tests $ dgfip_test_filter $ run_test $ mpp_function + $ optimize $ optimize_unsafe_float $ code_coverage $ precision $ roundops $ test_error_margin $ m_clean_calls $ dgfip_options $ var_dependencies) let info = @@ -261,6 +267,8 @@ type round_ops = RODefault | ROMulti | ROMainframe of int let source_files : string list ref = ref [] +let without_dgfip_m = ref false + let dep_graph_file : string ref = ref "dep_graph.dot" let verify_flag = ref false @@ -287,13 +295,14 @@ let value_sort = ref RegularFloat let round_ops = ref RODefault -let set_all_arg_refs (files_ : string list) (debug_ : bool) - (var_info_debug_ : string list) (display_time_ : bool) +let set_all_arg_refs (files_ : string list) (without_dgfip_m_ : bool) + (debug_ : bool) (var_info_debug_ : string list) (display_time_ : bool) (dep_graph_file_ : string) (no_print_cycles_ : bool) (output_file_ : string option) (optimize_unsafe_float_ : bool) (m_clean_calls_ : bool) (value_sort_ : value_sort) (round_ops_ : round_ops) = source_files := files_; + without_dgfip_m := without_dgfip_m_; debug_flag := debug_; var_info_debug := var_info_debug_; var_info_flag := !var_info_debug <> []; diff --git a/src/mlang/utils/cli.mli b/src/mlang/utils/cli.mli index 388b3c9bf..78a872ec0 100644 --- a/src/mlang/utils/cli.mli +++ b/src/mlang/utils/cli.mli @@ -21,6 +21,7 @@ val mlang_t : (string list -> bool -> + bool -> string list -> bool -> string -> @@ -114,6 +115,7 @@ val round_ops : round_ops ref val set_all_arg_refs : (* files *) string list -> + (* without_dgfip_m *) bool -> (* debug *) bool -> (* var_info_debug *) string list -> (* display_time *) bool -> From a464a1823948eac2ad9db854073de0c7ebe0e0a4 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Wed, 28 Jun 2023 13:34:12 +0200 Subject: [PATCH 09/26] =?UTF-8?q?Ajout=20des=20domaines=20de=20v=C3=A9rifs?= =?UTF-8?q?.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/backend_ir/bir_interface.ml | 1 + src/mlang/dgfip_m.ml | 50 +++---- src/mlang/m_frontend/format_mast.ml | 12 ++ src/mlang/m_frontend/format_mast.mli | 2 + src/mlang/m_frontend/mast.ml | 40 ++---- src/mlang/m_frontend/mast_to_mir.ml | 183 +++++++++++++++++++++----- src/mlang/m_frontend/mlexer.mll | 4 + src/mlang/m_frontend/mparser.mly | 78 ++++++++++- src/mlang/m_ir/mir.ml | 20 +-- src/mlang/m_ir/mir.mli | 20 +-- src/mlang/m_ir/mir_interface.ml | 8 +- src/mlang/mpp_ir/mpp_ir_to_bir.ml | 5 +- 12 files changed, 309 insertions(+), 114 deletions(-) diff --git a/src/mlang/backend_ir/bir_interface.ml b/src/mlang/backend_ir/bir_interface.ml index 9d01428da..cec89bf6b 100644 --- a/src/mlang/backend_ir/bir_interface.ml +++ b/src/mlang/backend_ir/bir_interface.ml @@ -138,6 +138,7 @@ let translate_external_conditions idmap Mast.Verification { verif_number = (0, Pos.no_pos); + verif_tag_names = ([], Pos.no_pos); verif_tags = []; verif_applications = [ ("iliad", Pos.no_pos) ]; verif_conditions = verif_conds; diff --git a/src/mlang/dgfip_m.ml b/src/mlang/dgfip_m.ml index f56f06b94..fe2a80b4a 100644 --- a/src/mlang/dgfip_m.ml +++ b/src/mlang/dgfip_m.ml @@ -183,45 +183,45 @@ domaine regle corrective base_inr_r9901 let verif_domains_declaration = {| domaine verif primitive corrective, isf corrective -: autorise - calculee *, - saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, - saisie variation -: auto_cc contexte, famille, revenu, revenu corrective, variation +#: autorise +# calculee *, +# saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, +# saisie variation +#: auto_cc contexte, famille, revenu, revenu corrective, variation : par_defaut; domaine verif primitive -: autorise - calculee *, - saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, - saisie variation +#: autorise +# calculee *, +# saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, +# saisie variation : specialise primitive corrective; domaine verif isf -: autorise - calculee *, - saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, - saisie variation; +#: autorise +# calculee *, +# saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, +# saisie variation +; domaine verif corrective -: autorise - calculee *, - saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, - saisie variation +#: autorise +# calculee *, +# saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, +# saisie variation : specialise primitive corrective; domaine verif corrective horizontale -: autorise - calculee *, - saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, - saisie variation, saisie penalite -: auto_cc penalite; +#: autorise +# calculee *, +# saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, +# saisie variation, saisie penalite +#: auto_cc penalite +; |} let declarations = Format.sprintf "%s%s%s" (ignore variable_domains_declaration; "") - rule_domains_declaration - (ignore verif_domains_declaration; - "") + rule_domains_declaration verif_domains_declaration diff --git a/src/mlang/m_frontend/format_mast.ml b/src/mlang/m_frontend/format_mast.ml index fe251a84e..8e18b59a9 100644 --- a/src/mlang/m_frontend/format_mast.ml +++ b/src/mlang/m_frontend/format_mast.ml @@ -345,6 +345,16 @@ let format_rule_domain fmt (rd : rule_domain_decl) = (format_domain_attribute "par_defaut") rd.rdom_by_default +let format_verif_domain fmt (vd : verif_domain_decl) = + Format.fprintf fmt "%a%a%a%a" + (pp_print_list_comma + (pp_unmark (pp_print_list_space (pp_unmark Format.pp_print_string)))) + vd.vdom_names format_specialize_domain vd.vdom_parents + (format_domain_attribute "auto_cc") + vd.vdom_auto_cc + (format_domain_attribute "par_defaut") + vd.vdom_by_default + let format_source_file_item fmt (i : source_file_item) = match i with | Application app -> @@ -361,6 +371,8 @@ let format_source_file_item fmt (i : source_file_item) = | Output o -> Format.fprintf fmt "sortie(%a);" format_variable_name (Pos.unmark o) | RuleDomDecl rd -> Format.fprintf fmt "rule domain %a;" format_rule_domain rd + | VerifDomDecl vd -> + Format.fprintf fmt "verif domain %a;" format_verif_domain vd let format_source_file fmt (f : source_file) = pp_print_list_endline (pp_unmark format_source_file_item) fmt f diff --git a/src/mlang/m_frontend/format_mast.mli b/src/mlang/m_frontend/format_mast.mli index 1100a1e56..53090bd29 100644 --- a/src/mlang/m_frontend/format_mast.mli +++ b/src/mlang/m_frontend/format_mast.mli @@ -26,6 +26,8 @@ val format_variable : Format.formatter -> Mast.variable -> unit val format_rule_domain : Format.formatter -> Mast.rule_domain_decl -> unit +val format_verif_domain : Format.formatter -> Mast.verif_domain_decl -> unit + val format_source_file : Format.formatter -> Mast.source_file -> unit val pp_print_list_endline : diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index 2708731f3..8c60efbd2 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -111,37 +111,6 @@ let chain_tag_of_string : string -> chain_tag = function | "horizontale" -> Horizontale | s -> Custom s -let number_and_tags_of_name (name : string Pos.marked list) : - int Pos.marked * chain_tag Pos.marked list = - let rec aux tags = function - | [] -> assert false (* M parser shouldn't allow it *) - | [ n ] -> - let num = - try Pos.map_under_mark int_of_string n - with _ -> - Errors.raise_spanned_error - "this rule or verification doesn't have an execution number" - (Pos.get_position (List.hd name)) - in - (num, tags) - | h :: t -> - let tag = - try Pos.map_under_mark chain_tag_of_string h - with _ -> - Errors.raise_spanned_error - ("Unknown chain tag " ^ Pos.unmark h) - (Pos.get_position h) - in - aux (tag :: tags) t - in - let number, tags = aux [] name in - if List.length tags = 0 then - ( number, - [ - (PrimCorr, Pos.no_pos); (Primitif, Pos.no_pos); (Corrective, Pos.no_pos); - ] ) (* No tags means both in primitive and corrective *) - else (number, tags) - let tags_of_name (name : string Pos.marked list) : chain_tag Pos.marked list = let rec aux tags = function | [] -> tags @@ -390,12 +359,20 @@ type verification_condition = { type verification = { verif_number : int Pos.marked; + verif_tag_names : string Pos.marked list Pos.marked; verif_tags : chain_tag Pos.marked list; verif_applications : application Pos.marked list; (** Verification conditions are application-specific *) verif_conditions : verification_condition Pos.marked list; } +type verif_domain_decl = { + vdom_names : string Pos.marked list Pos.marked list; + vdom_parents : string Pos.marked list Pos.marked list; + vdom_auto_cc : bool; + vdom_by_default : bool; +} + type error_typ = Anomaly | Discordance | Information let compare_error_type e1 e2 = @@ -425,6 +402,7 @@ type source_file_item = | Output of variable_name Pos.marked (** Declares an output variable *) | Function (** Declares a function, unused *) | RuleDomDecl of rule_domain_decl + | VerifDomDecl of verif_domain_decl (* TODO: parse something here *) diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index ae07e9f3d..a445ae6bd 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -1166,32 +1166,32 @@ let get_rule_domains (p : Mast.program) : Mir.rule_domain StrSetMap.t = let fold_items (domains, synonyms, by_default) marked_item = match Pos.unmark marked_item with | Mast.RuleDomDecl decl -> - let rdom_names = StrSetSet.from_marked_list_list decl.rdom_names in - let rdom_id = StrSetSet.min_elt rdom_names in - let domain = + let dom_names = StrSetSet.from_marked_list_list decl.rdom_names in + let dom_id = StrSetSet.min_elt dom_names in + let rdom = Mir. { - rdom_id; - rdom_names; - rdom_computable = decl.rdom_computable; - rdom_by_default = decl.rdom_by_default; - rdom_min = StrSetSet.from_marked_list_list decl.rdom_parents; - rdom_max = StrSetSet.empty; + dom_id; + dom_names; + dom_by_default = decl.rdom_by_default; + dom_min = StrSetSet.from_marked_list_list decl.rdom_parents; + dom_max = StrSetSet.empty; } in - let domains = StrSetMap.add rdom_id domain domains in + let domain = Mir.{ rdom; rdom_computable = decl.rdom_computable } in + let domains = StrSetMap.add dom_id domain domains in let fold syn sl = let name = StrSet.from_marked_list (Pos.unmark sl) in if StrSetMap.mem name syn then let msg = "there is already a domain with this name" in Errors.raise_spanned_error msg (Pos.get_position sl) - else StrSetMap.add name rdom_id syn + else StrSetMap.add name dom_id syn in let synonyms = List.fold_left fold synonyms decl.rdom_names in let by_default = if decl.rdom_by_default then match by_default with - | None -> Some rdom_id + | None -> Some dom_id | _ -> let msg = "there is already a default rule domain" in Errors.raise_spanned_error msg (Pos.get_position marked_item) @@ -1216,24 +1216,24 @@ let get_rule_domains (p : Mast.program) : Mir.rule_domain StrSetMap.t = let parentMap = let fold parentId map = let parentDom = get_dom parentId doms in - let parentId = parentDom.Mir.rdom_id in + let parentId = parentDom.Mir.rdom.dom_id in StrSetMap.add parentId parentDom map in - StrSetSet.fold fold dom.Mir.rdom_min StrSetMap.empty + StrSetSet.fold fold dom.Mir.rdom.dom_min StrSetMap.empty in StrSetMap.fold set_min parentMap (visiting, visited, doms) in - let rdom_min = + let dom_min = let fold parentId res = let parentDom = get_dom parentId doms in - let parentId = parentDom.Mir.rdom_id in + let parentId = parentDom.Mir.rdom.dom_id in StrSetSet.singleton parentId - |> StrSetSet.union parentDom.Mir.rdom_min + |> StrSetSet.union parentDom.Mir.rdom.dom_min |> StrSetSet.union res in - StrSetSet.fold fold dom.Mir.rdom_min StrSetSet.empty + StrSetSet.fold fold dom.Mir.rdom.dom_min StrSetSet.empty in - let dom = Mir.{ dom with rdom_min } in + let dom = Mir.{ dom with rdom = { dom.rdom with dom_min } } in let doms = StrSetMap.add id dom doms in let visiting = StrSetSet.remove id visiting in let visited = StrSetSet.add id visited in @@ -1247,11 +1247,11 @@ let get_rule_domains (p : Mast.program) : Mir.rule_domain StrSetMap.t = let set_max id dom doms = let fold minId doms = let minDom = StrSetMap.find minId doms in - let rdom_max = StrSetSet.add id minDom.Mir.rdom_max in - let minDom = Mir.{ minDom with rdom_max } in + let dom_max = StrSetSet.add id minDom.Mir.rdom.dom_max in + let minDom = Mir.{ minDom with rdom = { minDom.rdom with dom_max } } in StrSetMap.add minId minDom doms in - StrSetSet.fold fold dom.Mir.rdom_min doms + StrSetSet.fold fold dom.Mir.rdom.dom_min doms in StrSetMap.fold set_max domains domains in @@ -1260,7 +1260,7 @@ let get_rule_domains (p : Mast.program) : Mir.rule_domain StrSetMap.t = | Some def_id -> let fold _ dom doms = let foldName name doms = StrSetMap.add name dom doms in - StrSetSet.fold foldName dom.Mir.rdom_names doms + StrSetSet.fold foldName dom.Mir.rdom.dom_names doms in StrSetMap.empty |> StrSetMap.fold fold domains @@ -1271,8 +1271,8 @@ let get_rule_domains (p : Mast.program) : Mir.rule_domain StrSetMap.t = fmt "<%s> " s in StrSet.iter iter ss in let pp_sss fmt sss = let iter ss = Format.fprintf fmt "%a, " pp_ss ss in StrSetSet.iter iter sss in Format.printf "XXX %a\n: min: %a\n: max: %a\n" pp_ss id pp_sss - dom.Mir.rdom_min pp_sss dom.Mir.rdom_max in StrSetMap.iter iter domains; - exit 0 in *) + dom.Mir.rdom.dom_min pp_sss dom.Mir.rdom.dom_max in StrSetMap.iter iter + domains; exit 0 in *) domains let get_rule_chains (domains : Mir.rule_domain StrSetMap.t) (p : Mast.program) : @@ -1282,17 +1282,21 @@ let get_rule_chains (domains : Mir.rule_domain StrSetMap.t) (p : Mast.program) : | Mast.Rule r when r.rule_chaining <> None -> let ch_name, ch_pos = Option.get r.rule_chaining in let rule_domain = - let rdom_id = StrSet.from_marked_list (Pos.unmark r.rule_tag_names) in - StrSetMap.find rdom_id domains + let dom_id = StrSet.from_marked_list (Pos.unmark r.rule_tag_names) in + StrSetMap.find dom_id domains in let ch_dom = match StrMap.find_opt ch_name chains with | Some dom -> dom | None -> rule_domain in - let rdom_is_min = StrSetSet.mem rule_domain.rdom_id ch_dom.rdom_min in - let rdom_is_max = StrSetSet.mem rule_domain.rdom_id ch_dom.rdom_max in - let rdom_is_eq = rule_domain.rdom_id = ch_dom.rdom_id in + let rdom_is_min = + StrSetSet.mem rule_domain.rdom.dom_id ch_dom.rdom.dom_min + in + let rdom_is_max = + StrSetSet.mem rule_domain.rdom.dom_id ch_dom.rdom.dom_max + in + let rdom_is_eq = rule_domain.rdom.dom_id = ch_dom.rdom.dom_id in if rdom_is_min || rdom_is_max || rdom_is_eq then if not rdom_is_min then StrMap.add ch_name rule_domain chains else chains @@ -1304,6 +1308,119 @@ let get_rule_chains (domains : Mir.rule_domain StrSetMap.t) (p : Mast.program) : let fold_sources chains source = List.fold_left fold_rules chains source in List.fold_left fold_sources StrMap.empty p +let get_verif_domains (p : Mast.program) : Mir.verif_domain StrSetMap.t = + let fold_items (domains, synonyms, by_default) marked_item = + match Pos.unmark marked_item with + | Mast.VerifDomDecl decl -> + let dom_names = StrSetSet.from_marked_list_list decl.vdom_names in + let dom_id = StrSetSet.min_elt dom_names in + let vdom = + Mir. + { + dom_id; + dom_names; + dom_by_default = decl.vdom_by_default; + dom_min = StrSetSet.from_marked_list_list decl.vdom_parents; + dom_max = StrSetSet.empty; + } + in + let domain = Mir.{ vdom; vdom_auto_cc = decl.vdom_auto_cc } in + let domains = StrSetMap.add dom_id domain domains in + let fold syn sl = + let name = StrSet.from_marked_list (Pos.unmark sl) in + if StrSetMap.mem name syn then + let msg = "there is already a domain with this name" in + Errors.raise_spanned_error msg (Pos.get_position sl) + else StrSetMap.add name dom_id syn + in + let synonyms = List.fold_left fold synonyms decl.vdom_names in + let by_default = + if decl.vdom_by_default then + match by_default with + | None -> Some dom_id + | _ -> + let msg = "there is already a default verif domain" in + Errors.raise_spanned_error msg (Pos.get_position marked_item) + else by_default + in + (domains, synonyms, by_default) + | _ -> (domains, synonyms, by_default) + in + let fold_sources doms source = List.fold_left fold_items doms source in + let domains, synonyms, by_default = + List.fold_left fold_sources (StrSetMap.empty, StrSetMap.empty, None) p + in + let get_dom id dom = StrSetMap.find (StrSetMap.find id synonyms) dom in + let domains = + let rec set_min id dom (visiting, visited, doms) = + if StrSetSet.mem id visited then (visiting, visited, doms) + else if StrSetSet.mem id visiting then + Errors.raise_error "there is a loop in the verif domain hierarchy" + else + let visiting = StrSetSet.add id visiting in + let visiting, visited, doms = + let parentMap = + let fold parentId map = + let parentDom = get_dom parentId doms in + let parentId = parentDom.Mir.vdom.dom_id in + StrSetMap.add parentId parentDom map + in + StrSetSet.fold fold dom.Mir.vdom.dom_min StrSetMap.empty + in + StrSetMap.fold set_min parentMap (visiting, visited, doms) + in + let dom_min = + let fold parentId res = + let parentDom = get_dom parentId doms in + let parentId = parentDom.Mir.vdom.dom_id in + StrSetSet.singleton parentId + |> StrSetSet.union parentDom.Mir.vdom.dom_min + |> StrSetSet.union res + in + StrSetSet.fold fold dom.Mir.vdom.dom_min StrSetSet.empty + in + let dom = Mir.{ dom with vdom = { dom.vdom with dom_min } } in + let doms = StrSetMap.add id dom doms in + let visiting = StrSetSet.remove id visiting in + let visited = StrSetSet.add id visited in + (visiting, visited, doms) + in + let init = (StrSetSet.empty, StrSetSet.empty, domains) in + let _, _, domains = StrSetMap.fold set_min domains init in + domains + in + let domains = + let set_max id dom doms = + let fold minId doms = + let minDom = StrSetMap.find minId doms in + let dom_max = StrSetSet.add id minDom.Mir.vdom.dom_max in + let minDom = Mir.{ minDom with vdom = { minDom.vdom with dom_max } } in + StrSetMap.add minId minDom doms + in + StrSetSet.fold fold dom.Mir.vdom.dom_min doms + in + StrSetMap.fold set_max domains domains + in + let domains = + match by_default with + | Some def_id -> + let fold _ dom doms = + let foldName name doms = StrSetMap.add name dom doms in + StrSetSet.fold foldName dom.Mir.vdom.dom_names doms + in + StrSetMap.empty + |> StrSetMap.fold fold domains + |> StrSetMap.add StrSet.empty (get_dom def_id domains) + | None -> Errors.raise_error "there are no default verif domain" + in + (* let _ = let iter id dom = let pp_ss fmt ss = let iter s = Format.fprintf + fmt "<%s> " s in StrSet.iter iter ss in let pp_sss fmt sss = let iter ss = + Format.fprintf fmt "%a, " pp_ss ss in StrSetSet.iter iter sss in + Format.printf "XXX %a\n: min: %a\n: max: %a\n" pp_ss id pp_sss + dom.Mir.rdom.dom_min pp_sss dom.Mir.rdom.dom_max in StrSetMap.iter iter + domains; exit 0 in *) + domains + (** Main translation pass that deal with regular variable definition; returns a map whose keys are the variables being defined (with the execution number corresponding to the place where it is defined) and whose values are the @@ -1579,6 +1696,9 @@ let translate (p : Mast.program) : Mir.program = let rule_domains = get_rule_domains p in let rule_domain_by_default = StrSetMap.find StrSet.empty rule_domains in let rule_chains = get_rule_chains rule_domains p in + let verif_domains = get_verif_domains p in + (* let verif_domain_by_default = StrSetMap.find StrSet.empty verif_domains + in *) let rule_data, var_data = get_rules_and_var_data idmap var_decl_data const_map p in @@ -1646,7 +1766,8 @@ let translate (p : Mast.program) : Mir.program = in let conds = get_conds error_decls const_map idmap p in { - Mir.program_domains = rule_domains; + Mir.program_rule_domains = rule_domains; + Mir.program_verif_domains = verif_domains; Mir.program_chainings = rule_chains; Mir.program_vars = var_data; Mir.program_rules = rules; diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index a313e17a0..a1099b676 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -150,6 +150,10 @@ rule token = parse { OUTPUT } | "fonction" { FONCTION } +| "auto_cc" + { AUTO_CC } +| "non_auto_cc" + { NON_AUTO_CC } | '"' [^'"']* '"' as s { STRING s } | ['a'-'z'] as s diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index eea7157aa..50b031c09 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -49,7 +49,7 @@ along with this program. If not, see . %token COMPUTED CONST ALIAS CONTEXT FAMILY PENALITY INCOME INPUT FOR %token RULE IF THEN ELSE ENDIF ERROR VERIFICATION ANOMALY DISCORDANCE CONDITION %token INFORMATIVE OUTPUT FONCTION -%token DOMAIN SPECIALIZE COMPUTABLE BY_DEFAULT +%token DOMAIN SPECIALIZE COMPUTABLE BY_DEFAULT AUTO_CC NON_AUTO_CC %token EOF @@ -73,7 +73,6 @@ source_file: | i = source_file_item is = source_file { i::is } | EOF { [] } - source_file_item: | a = application { (Application a, mk_position $sloc) } | c = chaining { let (s, aps) = c in (Chaining (s, aps), mk_position $sloc) } @@ -84,6 +83,7 @@ source_file_item: | o = output { (Output o, mk_position $sloc) } | fonction { (Function, mk_position $sloc) } | cr = rule_domain_decl { (RuleDomDecl cr, mk_position $sloc) } +| cv = verif_domain_decl { (VerifDomDecl cv, mk_position $sloc) } rule_domain_decl: | DOMAIN RULE rdom_params = separated_nonempty_list(COLON, rdom_param_with_pos) SEMICOLON @@ -129,6 +129,50 @@ rdom_param_with_pos: | BY_DEFAULT { (None, None, None, Some (), mk_position $sloc) } +verif_domain_decl: +| DOMAIN VERIFICATION vdom_params = separated_nonempty_list(COLON, vdom_param_with_pos) SEMICOLON + { + let err msg pos = Errors.raise_spanned_error msg pos in + let fold (dno, dso, dao, dpdo) = function + | Some dn, _, _, _, pos -> + if dno = None then Some dn, dso, dao, dpdo + else err "verif domain names are already defined" pos + | _, Some ds, _, _, pos -> + if dso = None then dno, Some ds, dao, dpdo + else err "verif domain specialization is already specified" pos + | _, _, Some da, _, pos -> + if dao = None then dno, dso, Some da, dpdo + else err "verif domain is already auto-consistent" pos + | _, _, _, Some dpd, pos -> + if dpdo = None then dno, dso, dao, Some dpd + else err "verif domain is already defined by defaut" pos + | _, _, _, _, _ -> assert false + in + let init = None, None, None, None in + let dno, dso, dao, dpdo = List.fold_left fold init vdom_params in + let vdom_names = + match dno with + | None -> err "rule domain names must be defined" (mk_position $sloc) + | Some dn -> dn + in + { + vdom_names; + vdom_parents = (match dso with None -> [] | Some ds -> ds); + vdom_auto_cc = (match dao with None -> false | _ -> true); + vdom_by_default = (match dpdo with None -> false | _ -> true); + } + } + +vdom_param_with_pos: +| vdom_names = separated_nonempty_list(COMMA, symbol_list_with_pos) + { (Some vdom_names, None, None, None, mk_position $sloc) } +| SPECIALIZE vdom_parents = separated_nonempty_list(COMMA, symbol_list_with_pos) + { (None, Some vdom_parents, None, None, mk_position $sloc) } +| AUTO_CC + { (None, None, Some (), None, mk_position $sloc) } +| BY_DEFAULT + { (None, None, None, Some (), mk_position $sloc) } + %inline symbol_with_pos: | s = SYMBOL { (s, mk_position $sloc) } @@ -303,7 +347,7 @@ rule: try Pos.map_under_mark int_of_string num with _ -> Errors.raise_spanned_error - "this rule or verification doesn't have an execution number" + "this rule doesn't have an execution number" (Pos.get_position num) in let rule_tags = Mast.tags_of_name (Pos.unmark rule_tag_names) in @@ -346,11 +390,35 @@ verification_name: | name = SYMBOL { (name, mk_position $sloc) } verification: -| VERIFICATION name = verification_name+ COLON apps = application_reference +| VERIFICATION NON_AUTO_CC? name = symbol_list_with_pos COLON apps = application_reference SEMICOLON conds = verification_condition* { - let verif_number, verif_tags = Mast.number_and_tags_of_name name in + let num, verif_tag_names = + let uname = Pos.unmark name in + let begPos = + match uname with + | h :: _ -> Pos.get_position h + | [] -> assert false + in + let rec aux tags endPos = function + | [num] -> + let pos = Pos.make_position_between begPos endPos in + num, (tags, pos) + | h :: t -> aux (h :: tags) (Pos.get_position h) t + | [] -> assert false + in + aux [] begPos uname + in + let verif_number = + try Pos.map_under_mark int_of_string num + with _ -> + Errors.raise_spanned_error + "this verification doesn't have an execution number" + (Pos.get_position num) + in + let verif_tags = Mast.tags_of_name (Pos.unmark verif_tag_names) in { verif_number; + verif_tag_names; verif_tags; verif_applications = apps; verif_conditions = conds; diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 1ac588a2f..c904533ae 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -389,15 +389,16 @@ let fresh_rule_num = (** Special rule id for initial definition of variables *) let initial_undef_rule_id = RuleID (-1) -type rule_domain = { - rdom_id : StrSet.t; - rdom_names : StrSetSet.t; - rdom_computable : bool; - rdom_by_default : bool; - rdom_min : StrSetSet.t; - rdom_max : StrSetSet.t; +type domain = { + dom_id : StrSet.t; + dom_names : StrSetSet.t; + dom_by_default : bool; + dom_min : StrSetSet.t; + dom_max : StrSetSet.t; } +type rule_domain = { rdom : domain; rdom_computable : bool } + type rule_data = { rule_domain : rule_domain; rule_chain : (string * rule_domain) option; @@ -498,6 +499,8 @@ module Error = struct let compare (var1 : t) (var2 : t) = compare var1.id var2.id end +type verif_domain = { vdom : domain; vdom_auto_cc : bool } + type 'variable condition_data_ = { cond_number : rov_id Pos.marked; cond_expr : 'variable expression_ Pos.marked; @@ -527,7 +530,8 @@ type idmap = Variable.t list Pos.VarNameToID.t type exec_pass = { exec_pass_set_variables : literal Pos.marked VariableMap.t } type program = { - program_domains : rule_domain StrSetMap.t; + program_rule_domains : rule_domain StrSetMap.t; + program_verif_domains : verif_domain StrSetMap.t; program_chainings : rule_domain StrMap.t; program_vars : VariableDict.t; (** A static register of all variables that can be used during a diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 991598d41..1861759b5 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -151,15 +151,16 @@ type rov_id = RuleID of int | VerifID of int module RuleMap : MapExt.T with type key = rov_id -type rule_domain = { - rdom_id : StrSet.t; - rdom_names : StrSetSet.t; - rdom_computable : bool; - rdom_by_default : bool; - rdom_min : StrSetSet.t; - rdom_max : StrSetSet.t; +type domain = { + dom_id : StrSet.t; + dom_names : StrSetSet.t; + dom_by_default : bool; + dom_min : StrSetSet.t; + dom_max : StrSetSet.t; } +type rule_domain = { rdom : domain; rdom_computable : bool } + type rule_data = { rule_domain : rule_domain; rule_chain : (string * rule_domain) option; @@ -186,6 +187,8 @@ type error = { typ : Mast.error_typ; } +type verif_domain = { vdom : domain; vdom_auto_cc : bool } + type 'variable condition_data_ = { cond_number : rov_id Pos.marked; cond_expr : 'variable expression_ Pos.marked; @@ -203,7 +206,8 @@ type idmap = variable list Pos.VarNameToID.t type exec_pass = { exec_pass_set_variables : literal Pos.marked VariableMap.t } type program = { - program_domains : rule_domain StrSetMap.t; + program_rule_domains : rule_domain StrSetMap.t; + program_verif_domains : verif_domain StrSetMap.t; program_chainings : rule_domain StrMap.t; program_vars : VariableDict.t; (** A static register of all variables that can be used during a diff --git a/src/mlang/m_ir/mir_interface.ml b/src/mlang/m_ir/mir_interface.ml index ab919c063..41d091e91 100644 --- a/src/mlang/m_ir/mir_interface.ml +++ b/src/mlang/m_ir/mir_interface.ml @@ -67,8 +67,8 @@ let to_full_program (program : program) : full_program = Mir.RuleMap.fold (fun rov_id rule (vars, rules) -> let rule_domain = rule.rule_domain in - let is_max = StrSetSet.mem dom_id rule_domain.rdom_max in - let is_eq = rule_domain.rdom_id = dom_id in + let is_max = StrSetSet.mem dom_id rule_domain.rdom.dom_max in + let is_eq = rule_domain.rdom.dom_id = dom_id in let is_not_rule_0 = Pos.unmark rule.rule_number <> RuleID 0 in if is_not_rule_0 && (is_max || is_eq) then ( List.fold_left @@ -89,14 +89,14 @@ let to_full_program (program : program) : full_program = Mir_dependency_graph.get_rules_execution_order dep_graph in StrSetMap.add dom_id { dep_graph; execution_order } domains_orders) - program.program_domains StrSetMap.empty + program.program_rule_domains StrSetMap.empty in let chainings_orders = let chainings_roots = StrMap.map (fun chain_dom -> let dep_graph = - (StrSetMap.find chain_dom.rdom_id domains_orders).dep_graph + (StrSetMap.find chain_dom.rdom.dom_id domains_orders).dep_graph in (dep_graph, [])) program.program_chainings diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml index 02931e5c4..99b5c9818 100644 --- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml +++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml @@ -499,10 +499,11 @@ let create_combined_program (m_program : Mir_interface.full_program) let rule_domain = rule_data.Mir.rule_domain in let has_max = not - (StrSetSet.disjoint ctx.used_rule_domains rule_domain.rdom_max) + (StrSetSet.disjoint ctx.used_rule_domains + rule_domain.rdom.dom_max) in let has_used_domain = - StrSetSet.mem rule_domain.rdom_id ctx.used_rule_domains + StrSetSet.mem rule_domain.rdom.dom_id ctx.used_rule_domains in let has_used_chaining = match rule_data.Mir.rule_chain with From e23fb38271f1b1d1edb33f71671305095d371ad7 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 4 Jul 2023 15:20:58 +0200 Subject: [PATCH 10/26] =?UTF-8?q?=C3=89limination=20du=20type=20chain=5Fta?= =?UTF-8?q?g.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/backend_ir/bir_interface.ml | 30 +- src/mlang/dgfip_m.ml | 58 +++ src/mlang/dgfip_m.mli | 4 + src/mlang/driver.ml | 16 +- src/mlang/m_frontend/format_mast.ml | 72 +--- src/mlang/m_frontend/format_mast.mli | 2 - src/mlang/m_frontend/mast.ml | 139 +------ src/mlang/m_frontend/mast_to_mir.ml | 544 +++++++++++-------------- src/mlang/m_frontend/mast_to_mir.mli | 2 +- src/mlang/m_frontend/mparser.mly | 24 +- src/mlang/m_ir/mir.ml | 125 +----- src/mlang/m_ir/mir.mli | 34 +- src/mlang/m_ir/mir_interface.ml | 32 +- src/mlang/m_ir/mir_interface.mli | 4 +- src/mlang/mpp_frontend/mpp_frontend.ml | 4 +- src/mlang/mpp_ir/mpp_format.ml | 5 +- src/mlang/mpp_ir/mpp_ir.ml | 4 +- src/mlang/mpp_ir/mpp_ir_to_bir.ml | 70 ++-- 18 files changed, 474 insertions(+), 695 deletions(-) diff --git a/src/mlang/backend_ir/bir_interface.ml b/src/mlang/backend_ir/bir_interface.ml index cec89bf6b..a6d8aa5d0 100644 --- a/src/mlang/backend_ir/bir_interface.ml +++ b/src/mlang/backend_ir/bir_interface.ml @@ -135,20 +135,30 @@ let translate_external_conditions idmap [] conds in let program = - Mast.Verification - { - verif_number = (0, Pos.no_pos); - verif_tag_names = ([], Pos.no_pos); - verif_tags = []; - verif_applications = [ ("iliad", Pos.no_pos) ]; - verif_conditions = verif_conds; - } + List.map + (fun item -> (item, Pos.no_pos)) + [ + Mast.Verification + { + verif_number = (0, Pos.no_pos); + verif_tag_names = ([], Pos.no_pos); + verif_applications = [ ("iliad", Pos.no_pos) ]; + verif_conditions = verif_conds; + }; + Mast.VerifDomDecl + { + dom_names = [ ([], Pos.no_pos) ]; + dom_parents = []; + dom_by_default = true; + dom_data = { vdom_auto_cc = false }; + }; + ] in - let conds = + let _, conds = (* Leave a constant map empty is risky, it will fail if we allow tests to refer to M constants in their expressions *) Mast_to_mir.get_conds [ test_error ] Mast_to_mir.ConstMap.empty idmap - [ [ (program, Pos.no_pos) ] ] + [ program ] in Mir.VariableMap.fold (fun v data acc -> diff --git a/src/mlang/dgfip_m.ml b/src/mlang/dgfip_m.ml index d1d53c0b4..7d5e1b1bc 100644 --- a/src/mlang/dgfip_m.ml +++ b/src/mlang/dgfip_m.ml @@ -223,3 +223,61 @@ domaine verif corrective horizontale let declarations = Format.sprintf "%s%s%s" variable_domains_declaration rule_domains_declaration verif_domains_declaration + +let string_to_rule_domain_id : string -> Mast.DomainId.t = function + | "primitif" -> Mast.DomainId.from_list [ "primitive" ] + | "corrective" -> Mast.DomainId.from_list [ "corrective" ] + | "isf" -> Mast.DomainId.from_list [ "isf" ] + | "taux" -> Mast.DomainId.from_list [ "taux" ] + | "irisf" -> Mast.DomainId.from_list [ "irisf" ] + | "base_HR" -> Mast.DomainId.from_list [ "corrective"; "base_HR" ] + | "base_tl" -> Mast.DomainId.from_list [ "corrective"; "base_tl" ] + | "base_tl_init" -> Mast.DomainId.from_list [ "corrective"; "base_INITIAL" ] + | "base_tl_rect" -> Mast.DomainId.from_list [ "corrective"; "base_tl_rect" ] + | "base_INITIAL" -> Mast.DomainId.from_list [ "corrective"; "base_INITIAL" ] + | "base_INR" -> Mast.DomainId.from_list [ "corrective"; "base_INR" ] + | "base_inr_ref" -> Mast.DomainId.from_list [ "corrective"; "base_inr_ref" ] + | "base_inr_tl" -> Mast.DomainId.from_list [ "corrective"; "base_inr_tl" ] + | "base_inr_tl22" -> Mast.DomainId.from_list [ "corrective"; "base_inr_tl22" ] + | "base_inr_tl24" -> Mast.DomainId.from_list [ "corrective"; "base_inr_tl24" ] + | "base_inr_ntl" -> Mast.DomainId.from_list [ "corrective"; "base_inr_ntl" ] + | "base_inr_ntl22" -> + Mast.DomainId.from_list [ "corrective"; "base_inr_ntl22" ] + | "base_inr_ntl24" -> + Mast.DomainId.from_list [ "corrective"; "base_inr_ntl24" ] + | "base_inr_inter22" -> + Mast.DomainId.from_list [ "corrective"; "base_inr_inter22" ] + | "base_inr_intertl" -> + Mast.DomainId.from_list [ "corrective"; "base_inr_intertl" ] + | "base_inr_r9901" -> + Mast.DomainId.from_list [ "corrective"; "base_inr_r9901" ] + | "base_inr_cimr07" -> + Mast.DomainId.from_list [ "corrective"; "base_inr_cimr07" ] + | "base_inr_cimr24" -> + Mast.DomainId.from_list [ "corrective"; "base_inr_cimr24" ] + | "base_inr_cimr99" -> + Mast.DomainId.from_list [ "corrective"; "base_inr_cimr99" ] + | "base_inr_tlcimr07" -> + Mast.DomainId.from_list [ "corrective"; "base_inr_tlcimr07" ] + | "base_inr_tlcimr24" -> + Mast.DomainId.from_list [ "corrective"; "base_inr_tlcimr24" ] + | "base_ABAT98" -> Mast.DomainId.from_list [ "corrective"; "base_ABAT98" ] + | "base_ABAT99" -> Mast.DomainId.from_list [ "corrective"; "base_ABAT99" ] + | "base_MAJO" -> Mast.DomainId.from_list [ "corrective"; "base_MAJO" ] + | "base_premier" -> Mast.DomainId.from_list [ "corrective"; "base_premier" ] + | "base_anterieure" -> + Mast.DomainId.from_list [ "corrective"; "base_anterieure" ] + | "base_anterieure_cor" -> + Mast.DomainId.from_list [ "corrective"; "base_anterieure_cor" ] + | "base_stratemajo" -> + Mast.DomainId.from_list [ "corrective"; "base_stratemajo" ] + | "non_auto_cc" -> Mast.DomainId.from_list [] + | "horizontale" -> Mast.DomainId.from_list [ "horizontale" ] + | str -> Errors.raise_error (Format.sprintf "Unknown rule tag: %s" str) + +let string_to_verif_domain_id : string -> Mast.DomainId.t = function + | "primitif" | "primitive" -> Mast.DomainId.from_list [ "primitive" ] + | "corrective" -> Mast.DomainId.from_list [ "corrective" ] + | "isf" -> Mast.DomainId.from_list [ "isf" ] + | "horizontale" -> Mast.DomainId.from_list [ "corrective"; "horizontale" ] + | str -> Errors.raise_error (Format.sprintf "Unknown verif tag: %s" str) diff --git a/src/mlang/dgfip_m.mli b/src/mlang/dgfip_m.mli index 28676df89..a51adae1b 100644 --- a/src/mlang/dgfip_m.mli +++ b/src/mlang/dgfip_m.mli @@ -5,3 +5,7 @@ val rule_domains_declaration : string val verif_domains_declaration : string val declarations : string + +val string_to_rule_domain_id : string -> Mast.DomainId.t + +val string_to_verif_domain_id : string -> Mast.DomainId.t diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index b621e3471..e22dad74f 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -185,17 +185,17 @@ let driver (files : string list) (without_dgfip_m : bool) (debug : bool) let full_m_program = Mir_typechecker.expand_functions full_m_program in Cli.debug_print "Typechecking..."; let full_m_program = Mir_typechecker.typecheck full_m_program in - StrSetMap.iter + Mast.DomainIdMap.iter (fun rdom_id Mir_interface.{ dep_graph; _ } -> Cli.debug_print "Checking for circular variable definitions for rule domain %a..." - (StrSet.pp ()) rdom_id; + (Mast.DomainId.pp ()) rdom_id; if Mir_dependency_graph.check_for_cycle dep_graph full_m_program.program true then Errors.raise_error "Cycles between rules.") full_m_program.domains_orders; - StrMap.iter + Mast.ChainingMap.iter (fun chaining_id Mir_interface.{ dep_graph; _ } -> Cli.debug_print "Checking for circular variable definitions for chaining %s..." @@ -219,12 +219,16 @@ let driver (files : string list) (without_dgfip_m : bool) (debug : bool) in let order = try - let rdom_id = Mir.string_to_rule_domain_id chain in - match StrSetMap.find_opt rdom_id full_m_program.domains_orders with + let rdom_id = Dgfip_m.string_to_rule_domain_id chain in + match + Mast.DomainIdMap.find_opt rdom_id full_m_program.domains_orders + with | Some order -> order | None -> Errors.raise_error ("unknown rule domain: " ^ chain) with Not_found -> ( - match StrMap.find_opt chain full_m_program.chainings_orders with + match + Mast.ChainingMap.find_opt chain full_m_program.chainings_orders + with | Some order -> order | None -> Errors.raise_error ("unknown chaining: " ^ chain)) in diff --git a/src/mlang/m_frontend/format_mast.ml b/src/mlang/m_frontend/format_mast.ml index 50d8671ec..5ad869a3a 100644 --- a/src/mlang/m_frontend/format_mast.ml +++ b/src/mlang/m_frontend/format_mast.ml @@ -39,47 +39,6 @@ let format_application fmt (app : application) = Format.fprintf fmt "%s" app let format_chaining fmt (c : chaining) = Format.fprintf fmt "%s" c -let format_chain_tag fmt (t : chain_tag) = - Format.pp_print_string fmt - (match t with - | Custom name -> "\"" ^ name ^ "\"" - | PrimCorr -> "" - | Primitif -> "primitif" - | Corrective -> "corrective" - | Isf -> "isf" - | Taux -> "taux" - | Irisf -> "irisf" - | Base_hr -> "base_HR" - | Base_tl -> "base_tl" - | Base_tl_init -> "base_tl_init" - | Base_tl_rect -> "base_tl_rect" - | Base_inr -> "base_INR" - | Base_inr_ref -> "base_inr_ref" - | Base_inr_tl -> "base_inr_tl" - | Base_inr_tl22 -> "base_inr_tl22" - | Base_inr_tl24 -> "base_inr_tl24" - | Base_inr_ntl -> "base_inr_ntl" - | Base_inr_ntl22 -> "base_inr_ntl22" - | Base_inr_ntl24 -> "base_inr_ntl24" - | Base_inr_inter22 -> "base_inr_inter22" - | Base_inr_intertl -> "base_inr_intertl" - | Base_inr_r9901 -> "base_inr_r9901" - | Base_inr_cimr07 -> "base_inr_cimr07" - | Base_inr_cimr24 -> "base_inr_cimr24" - | Base_inr_cimr99 -> "base_inr_cimr99" - | Base_inr_tlcimr07 -> "base_inr_tlcimr07" - | Base_inr_tlcimr24 -> "base_inr_tlcimr24" - | Base_abat98 -> "base_ABAT98" - | Base_abat99 -> "base_ABAT99" - | Base_initial -> "base_INITIAL" - | Base_premier -> "base_premier" - | Base_anterieure -> "base_anterieure" - | Base_anterieure_cor -> "base_anterieure_cor" - | Base_majo -> "base_MAJO" - | Base_stratemajo -> "base_stratemajo" - | Non_auto_cc -> "non_auto_cc" - | Horizontale -> "horizontale") - let format_variable_name fmt (v : variable_name) = Format.fprintf fmt "%s" v let format_func_name fmt (f : func_name) = Format.fprintf fmt "%s" f @@ -332,25 +291,30 @@ let format_specialize_domain fmt (dl : string Pos.marked list Pos.marked list) = let format_domain_attribute attr fmt b = if b then Format.fprintf fmt " :@ %s" attr -let format_rule_domain fmt (rd : rule_domain_decl) = +let format_domain (pp_data : Format.formatter -> 'a -> unit) fmt + (d : 'a domain_decl) = Format.fprintf fmt "%a%a%a%a" (pp_print_list_comma (pp_unmark (pp_print_list_space (pp_unmark Format.pp_print_string)))) - rd.rdom_names format_specialize_domain rd.rdom_parents - (format_domain_attribute "calculable") - rd.rdom_computable + d.dom_names format_specialize_domain d.dom_parents (format_domain_attribute "par_defaut") - rd.rdom_by_default + d.dom_by_default pp_data d.dom_data + +let format_rule_domain fmt (rd : rule_domain_decl) = + let pp_data fmt data = + Format.fprintf fmt "%a" + (format_domain_attribute "calculable") + data.rdom_computable + in + format_domain pp_data fmt rd let format_verif_domain fmt (vd : verif_domain_decl) = - Format.fprintf fmt "%a%a%a%a" - (pp_print_list_comma - (pp_unmark (pp_print_list_space (pp_unmark Format.pp_print_string)))) - vd.vdom_names format_specialize_domain vd.vdom_parents - (format_domain_attribute "auto_cc") - vd.vdom_auto_cc - (format_domain_attribute "par_defaut") - vd.vdom_by_default + let pp_data fmt data = + Format.fprintf fmt "%a" + (format_domain_attribute "auto_cc") + data.vdom_auto_cc + in + format_domain pp_data fmt vd let format_source_file_item fmt (i : source_file_item) = match i with diff --git a/src/mlang/m_frontend/format_mast.mli b/src/mlang/m_frontend/format_mast.mli index ff57f3591..510df0df6 100644 --- a/src/mlang/m_frontend/format_mast.mli +++ b/src/mlang/m_frontend/format_mast.mli @@ -42,5 +42,3 @@ val pp_print_list_space : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit val pp_unmark : ('a -> 'b -> 'c) -> 'a -> 'b Pos.marked -> 'c - -val format_chain_tag : Format.formatter -> Mast.chain_tag -> unit diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index 22b1ffeac..ee3e847a9 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -31,104 +31,15 @@ type application = string - [bareme]: seems to compute the income tax; - [iliad]: usage unkown, much bigger than [bareme]. *) +module DomainId = StrSet +module DomainIdSet = StrSetSet +module DomainIdMap = StrSetMap + type chaining = string (** "enchaineur" in the M source code, utility unknown *) -type chain_tag = - | Custom of string (* Custom chain, not an actual rule tag *) - | PrimCorr (* empty tag *) - | Primitif - | Corrective - | Isf - | Taux - | Irisf - | Base_hr - | Base_tl - | Base_tl_init - | Base_tl_rect - | Base_initial - | Base_inr - | Base_inr_ref - | Base_inr_tl - | Base_inr_tl22 - | Base_inr_tl24 - | Base_inr_ntl - | Base_inr_ntl22 - | Base_inr_ntl24 - | Base_inr_inter22 - | Base_inr_intertl - | Base_inr_r9901 - | Base_inr_cimr07 - | Base_inr_cimr24 - | Base_inr_cimr99 - | Base_inr_tlcimr07 - | Base_inr_tlcimr24 - | Base_abat98 - | Base_abat99 - | Base_majo - | Base_premier - | Base_anterieure - | Base_anterieure_cor - | Base_stratemajo - | Non_auto_cc - | Horizontale - -let chain_tag_of_string : string -> chain_tag = function - | "primitif" -> Primitif - | "corrective" -> Corrective - | "isf" -> Isf - | "taux" -> Taux - | "irisf" -> Irisf - | "base_HR" -> Base_hr - | "base_tl" -> Base_tl - | "base_tl_init" -> Base_tl_init - | "base_tl_rect" -> Base_tl_rect - | "base_INR" -> Base_inr - | "base_inr_ref" -> Base_inr_ref - | "base_inr_tl" -> Base_inr_tl - | "base_inr_tl22" -> Base_inr_tl22 - | "base_inr_tl24" -> Base_inr_tl24 - | "base_inr_ntl" -> Base_inr_ntl - | "base_inr_ntl22" -> Base_inr_ntl22 - | "base_inr_ntl24" -> Base_inr_ntl24 - | "base_inr_inter22" -> Base_inr_inter22 - | "base_inr_intertl" -> Base_inr_intertl - | "base_inr_r9901" -> Base_inr_r9901 - | "base_inr_cimr07" -> Base_inr_cimr07 - | "base_inr_cimr24" -> Base_inr_cimr24 - | "base_inr_cimr99" -> Base_inr_cimr99 - | "base_inr_tlcimr07" -> Base_inr_tlcimr07 - | "base_inr_tlcimr24" -> Base_inr_tlcimr24 - | "base_ABAT98" -> Base_abat98 - | "base_ABAT99" -> Base_abat99 - | "base_INITIAL" -> Base_initial - | "base_premier" -> Base_premier - | "base_anterieure" -> Base_anterieure - | "base_anterieure_cor" -> Base_anterieure_cor - | "base_MAJO" -> Base_majo - | "base_stratemajo" -> Base_stratemajo - | "non_auto_cc" -> Non_auto_cc - | "horizontale" -> Horizontale - | s -> Custom s - -let tags_of_name (name : string Pos.marked list) : chain_tag Pos.marked list = - let rec aux tags = function - | [] -> tags - | h :: t -> - let tag = - try Pos.map_under_mark chain_tag_of_string h - with _ -> - Errors.raise_spanned_error - ("Unknown chain tag " ^ Pos.unmark h) - (Pos.get_position h) - in - aux (tag :: tags) t - in - let tags = aux [] name in - if List.length tags = 0 then - [ (PrimCorr, Pos.no_pos); (Primitif, Pos.no_pos); (Corrective, Pos.no_pos) ] - (* No tags means both in primitive and corrective *) - else tags +module ChainingSet = StrSet +module ChainingMap = StrMap type variable_name = string (** Variables are just strings *) @@ -272,20 +183,23 @@ type formula = type rule = { rule_number : int Pos.marked; rule_tag_names : string Pos.marked list Pos.marked; - rule_tags : chain_tag Pos.marked list; rule_applications : application Pos.marked list; rule_chaining : chaining Pos.marked option; rule_formulaes : formula Pos.marked list; (** A rule can contain many variable definitions *) } -type rule_domain_decl = { - rdom_names : string Pos.marked list Pos.marked list; - rdom_parents : string Pos.marked list Pos.marked list; - rdom_computable : bool; - rdom_by_default : bool; +type 'a domain_decl = { + dom_names : string Pos.marked list Pos.marked list; + dom_parents : string Pos.marked list Pos.marked list; + dom_by_default : bool; + dom_data : 'a; } +type rule_domain_data = { rdom_computable : bool } + +type rule_domain_decl = rule_domain_data domain_decl + (**{2 Variable declaration}*) (** The M language has prototypes for declaring variables with types and various @@ -372,18 +286,14 @@ type verification_condition = { type verification = { verif_number : int Pos.marked; verif_tag_names : string Pos.marked list Pos.marked; - verif_tags : chain_tag Pos.marked list; verif_applications : application Pos.marked list; (** Verification conditions are application-specific *) verif_conditions : verification_condition Pos.marked list; } -type verif_domain_decl = { - vdom_names : string Pos.marked list Pos.marked list; - vdom_parents : string Pos.marked list Pos.marked list; - vdom_auto_cc : bool; - vdom_by_default : bool; -} +type verif_domain_data = { vdom_auto_cc : bool } + +type verif_domain_decl = verif_domain_data domain_decl type error_typ = Anomaly | Discordance | Information @@ -436,16 +346,3 @@ type function_spec = { let get_variable_name (v : variable) : string = match v with Normal s -> s | Generic s -> s.base - -let are_tags_part_of_verif_chain (tags : chain_tag list) (chain : chain_tag) : - bool = - let is_part_of = List.mem chain tags in - match chain with - | Primitif -> - is_part_of || (List.mem Isf tags && List.mem Corrective tags) - (* include "isf corrective" *) - | Isf -> - is_part_of && not (List.mem Corrective tags) - (* exclude "isf corrective" *) - | Corrective -> is_part_of && not (List.mem Horizontale tags) - | _ -> is_part_of diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index b5e79693a..d75e8082c 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -1320,143 +1320,171 @@ let add_var_def (var_data : Mir.variable_data Mir.VariableMap.t) in Mir.VariableMap.add var_lvalue vdata var_data -let get_rule_domains (p : Mast.program) : Mir.rule_domain StrSetMap.t = +let get_domains (cat_str : string) + (get_item : Mast.source_file_item -> ('a Mast.domain_decl * 'b) option) + (p : Mast.program) : 'b Mir.domain Mast.DomainIdMap.t = let fold_items (domains, synonyms, by_default) marked_item = - match Pos.unmark marked_item with - | Mast.RuleDomDecl decl -> - let dom_names = StrSetSet.from_marked_list_list decl.rdom_names in - let dom_id = StrSetSet.min_elt dom_names in - let rdom = + match get_item (Pos.unmark marked_item) with + | Some (decl, dom_data) -> + let dom_names = Mast.DomainIdSet.from_marked_list_list decl.dom_names in + let dom_id = Mast.DomainIdSet.min_elt dom_names in + let domain = Mir. { dom_id; dom_names; - dom_by_default = decl.rdom_by_default; - dom_min = StrSetSet.from_marked_list_list decl.rdom_parents; - dom_max = StrSetSet.empty; + dom_by_default = decl.dom_by_default; + dom_min = Mast.DomainIdSet.from_marked_list_list decl.dom_parents; + dom_max = Mast.DomainIdSet.empty; + dom_data; } in - let domain = Mir.{ rdom; rdom_computable = decl.rdom_computable } in - let domains = StrSetMap.add dom_id domain domains in + let domains = Mast.DomainIdMap.add dom_id domain domains in let fold syn sl = - let name = StrSet.from_marked_list (Pos.unmark sl) in - if StrSetMap.mem name syn then - let msg = "there is already a domain with this name" in + let name = Mast.DomainId.from_marked_list (Pos.unmark sl) in + if Mast.DomainIdMap.mem name syn then + let msg = + Format.sprintf "there is already a %s domain with this name" + cat_str + in Errors.raise_spanned_error msg (Pos.get_position sl) - else StrSetMap.add name dom_id syn + else Mast.DomainIdMap.add name dom_id syn in - let synonyms = List.fold_left fold synonyms decl.rdom_names in + let synonyms = List.fold_left fold synonyms decl.dom_names in let by_default = - if decl.rdom_by_default then + if decl.dom_by_default then match by_default with | None -> Some dom_id | _ -> - let msg = "there is already a default rule domain" in + let msg = + Format.sprintf "there is already a default %s domain" cat_str + in Errors.raise_spanned_error msg (Pos.get_position marked_item) else by_default in (domains, synonyms, by_default) - | _ -> (domains, synonyms, by_default) + | None -> (domains, synonyms, by_default) in let fold_sources doms source = List.fold_left fold_items doms source in let domains, synonyms, by_default = - List.fold_left fold_sources (StrSetMap.empty, StrSetMap.empty, None) p + List.fold_left fold_sources + (Mast.DomainIdMap.empty, Mast.DomainIdMap.empty, None) + p + in + let get_dom id dom = + Mast.DomainIdMap.find (Mast.DomainIdMap.find id synonyms) dom in - let get_dom id dom = StrSetMap.find (StrSetMap.find id synonyms) dom in let domains = let rec set_min id dom (visiting, visited, doms) = - if StrSetSet.mem id visited then (visiting, visited, doms) - else if StrSetSet.mem id visiting then - Errors.raise_error "there is a loop in the rule domain hierarchy" + if Mast.DomainIdSet.mem id visited then (visiting, visited, doms) + else if Mast.DomainIdSet.mem id visiting then + Errors.raise_error + (Format.sprintf "there is a loop in the %s domain hierarchy" cat_str) else - let visiting = StrSetSet.add id visiting in + let visiting = Mast.DomainIdSet.add id visiting in let visiting, visited, doms = let parentMap = let fold parentId map = let parentDom = get_dom parentId doms in - let parentId = parentDom.Mir.rdom.dom_id in - StrSetMap.add parentId parentDom map + let parentId = parentDom.Mir.dom_id in + Mast.DomainIdMap.add parentId parentDom map in - StrSetSet.fold fold dom.Mir.rdom.dom_min StrSetMap.empty + Mast.DomainIdSet.fold fold dom.Mir.dom_min Mast.DomainIdMap.empty in - StrSetMap.fold set_min parentMap (visiting, visited, doms) + Mast.DomainIdMap.fold set_min parentMap (visiting, visited, doms) in let dom_min = let fold parentId res = let parentDom = get_dom parentId doms in - let parentId = parentDom.Mir.rdom.dom_id in - StrSetSet.singleton parentId - |> StrSetSet.union parentDom.Mir.rdom.dom_min - |> StrSetSet.union res + let parentId = parentDom.Mir.dom_id in + Mast.DomainIdSet.singleton parentId + |> Mast.DomainIdSet.union parentDom.Mir.dom_min + |> Mast.DomainIdSet.union res in - StrSetSet.fold fold dom.Mir.rdom.dom_min StrSetSet.empty + Mast.DomainIdSet.fold fold dom.Mir.dom_min Mast.DomainIdSet.empty in - let dom = Mir.{ dom with rdom = { dom.rdom with dom_min } } in - let doms = StrSetMap.add id dom doms in - let visiting = StrSetSet.remove id visiting in - let visited = StrSetSet.add id visited in + let dom = Mir.{ dom with dom_min } in + let doms = Mast.DomainIdMap.add id dom doms in + let visiting = Mast.DomainIdSet.remove id visiting in + let visited = Mast.DomainIdSet.add id visited in (visiting, visited, doms) in - let init = (StrSetSet.empty, StrSetSet.empty, domains) in - let _, _, domains = StrSetMap.fold set_min domains init in + let init = (Mast.DomainIdSet.empty, Mast.DomainIdSet.empty, domains) in + let _, _, domains = Mast.DomainIdMap.fold set_min domains init in domains in let domains = let set_max id dom doms = let fold minId doms = - let minDom = StrSetMap.find minId doms in - let dom_max = StrSetSet.add id minDom.Mir.rdom.dom_max in - let minDom = Mir.{ minDom with rdom = { minDom.rdom with dom_max } } in - StrSetMap.add minId minDom doms + let minDom = Mast.DomainIdMap.find minId doms in + let dom_max = Mast.DomainIdSet.add id minDom.Mir.dom_max in + let minDom = Mir.{ minDom with dom_max } in + Mast.DomainIdMap.add minId minDom doms in - StrSetSet.fold fold dom.Mir.rdom.dom_min doms + Mast.DomainIdSet.fold fold dom.Mir.dom_min doms in - StrSetMap.fold set_max domains domains + Mast.DomainIdMap.fold set_max domains domains in let domains = match by_default with | Some def_id -> let fold _ dom doms = - let foldName name doms = StrSetMap.add name dom doms in - StrSetSet.fold foldName dom.Mir.rdom.dom_names doms + let foldName name doms = Mast.DomainIdMap.add name dom doms in + Mast.DomainIdSet.fold foldName dom.Mir.dom_names doms in - StrSetMap.empty - |> StrSetMap.fold fold domains - |> StrSetMap.add StrSet.empty (get_dom def_id domains) - | None -> Errors.raise_error "there are no default rule domain" + Mast.DomainIdMap.empty + |> Mast.DomainIdMap.fold fold domains + |> Mast.DomainIdMap.add Mast.DomainId.empty (get_dom def_id domains) + | None -> + Errors.raise_error + (Format.sprintf "there are no default %s domain" cat_str) in (* let _ = let iter id dom = let pp_ss fmt ss = let iter s = Format.fprintf - fmt "<%s> " s in StrSet.iter iter ss in let pp_sss fmt sss = let iter ss = - Format.fprintf fmt "%a, " pp_ss ss in StrSetSet.iter iter sss in - Format.printf "XXX %a\n: min: %a\n: max: %a\n" pp_ss id pp_sss - dom.Mir.rdom.dom_min pp_sss dom.Mir.rdom.dom_max in StrSetMap.iter iter + fmt "<%s> " s in Mast.DomainId.iter iter ss in let pp_sss fmt sss = let + iter ss = Format.fprintf fmt "%a, " pp_ss ss in Mast.DomainIdSet.iter iter + sss in Format.printf "XXX %a\n: min: %a\n: max: %a\n" pp_ss id pp_sss + dom.Mir.dom_min pp_sss dom.Mir.dom_max in Mast.DomainIdMap.iter iter domains; exit 0 in *) domains -let get_rule_chains (domains : Mir.rule_domain StrSetMap.t) (p : Mast.program) : - Mir.rule_domain StrMap.t = +let get_rule_domains (p : Mast.program) : Mir.rule_domain Mast.DomainIdMap.t = + let get_item = function + | Mast.RuleDomDecl decl -> + let dom_data = + { Mir.rdom_computable = decl.Mast.dom_data.rdom_computable } + in + Some (decl, dom_data) + | _ -> None + in + get_domains "rule" get_item p + +let get_rule_chains (domains : Mir.rule_domain Mast.DomainIdMap.t) + (p : Mast.program) : Mir.rule_domain Mast.ChainingMap.t = let fold_rules chains marked_item = match Pos.unmark marked_item with | Mast.Rule r when r.rule_chaining <> None -> let ch_name, ch_pos = Option.get r.rule_chaining in let rule_domain = - let dom_id = StrSet.from_marked_list (Pos.unmark r.rule_tag_names) in - StrSetMap.find dom_id domains + let dom_id = + Mast.DomainId.from_marked_list (Pos.unmark r.rule_tag_names) + in + Mast.DomainIdMap.find dom_id domains in let ch_dom = - match StrMap.find_opt ch_name chains with + match Mast.ChainingMap.find_opt ch_name chains with | Some dom -> dom | None -> rule_domain in let rdom_is_min = - StrSetSet.mem rule_domain.rdom.dom_id ch_dom.rdom.dom_min + Mast.DomainIdSet.mem rule_domain.dom_id ch_dom.dom_min in let rdom_is_max = - StrSetSet.mem rule_domain.rdom.dom_id ch_dom.rdom.dom_max + Mast.DomainIdSet.mem rule_domain.dom_id ch_dom.dom_max in - let rdom_is_eq = rule_domain.rdom.dom_id = ch_dom.rdom.dom_id in + let rdom_is_eq = rule_domain.dom_id = ch_dom.dom_id in if rdom_is_min || rdom_is_max || rdom_is_eq then - if not rdom_is_min then StrMap.add ch_name rule_domain chains + if not rdom_is_min then + Mast.ChainingMap.add ch_name rule_domain chains else chains else let msg = "chaining incompatible with rule domain" in @@ -1464,120 +1492,16 @@ let get_rule_chains (domains : Mir.rule_domain StrSetMap.t) (p : Mast.program) : | _ -> chains in let fold_sources chains source = List.fold_left fold_rules chains source in - List.fold_left fold_sources StrMap.empty p + List.fold_left fold_sources Mast.ChainingMap.empty p -let get_verif_domains (p : Mast.program) : Mir.verif_domain StrSetMap.t = - let fold_items (domains, synonyms, by_default) marked_item = - match Pos.unmark marked_item with +let get_verif_domains (p : Mast.program) : Mir.verif_domain Mast.DomainIdMap.t = + let get_item = function | Mast.VerifDomDecl decl -> - let dom_names = StrSetSet.from_marked_list_list decl.vdom_names in - let dom_id = StrSetSet.min_elt dom_names in - let vdom = - Mir. - { - dom_id; - dom_names; - dom_by_default = decl.vdom_by_default; - dom_min = StrSetSet.from_marked_list_list decl.vdom_parents; - dom_max = StrSetSet.empty; - } - in - let domain = Mir.{ vdom; vdom_auto_cc = decl.vdom_auto_cc } in - let domains = StrSetMap.add dom_id domain domains in - let fold syn sl = - let name = StrSet.from_marked_list (Pos.unmark sl) in - if StrSetMap.mem name syn then - let msg = "there is already a domain with this name" in - Errors.raise_spanned_error msg (Pos.get_position sl) - else StrSetMap.add name dom_id syn - in - let synonyms = List.fold_left fold synonyms decl.vdom_names in - let by_default = - if decl.vdom_by_default then - match by_default with - | None -> Some dom_id - | _ -> - let msg = "there is already a default verif domain" in - Errors.raise_spanned_error msg (Pos.get_position marked_item) - else by_default - in - (domains, synonyms, by_default) - | _ -> (domains, synonyms, by_default) - in - let fold_sources doms source = List.fold_left fold_items doms source in - let domains, synonyms, by_default = - List.fold_left fold_sources (StrSetMap.empty, StrSetMap.empty, None) p - in - let get_dom id dom = StrSetMap.find (StrSetMap.find id synonyms) dom in - let domains = - let rec set_min id dom (visiting, visited, doms) = - if StrSetSet.mem id visited then (visiting, visited, doms) - else if StrSetSet.mem id visiting then - Errors.raise_error "there is a loop in the verif domain hierarchy" - else - let visiting = StrSetSet.add id visiting in - let visiting, visited, doms = - let parentMap = - let fold parentId map = - let parentDom = get_dom parentId doms in - let parentId = parentDom.Mir.vdom.dom_id in - StrSetMap.add parentId parentDom map - in - StrSetSet.fold fold dom.Mir.vdom.dom_min StrSetMap.empty - in - StrSetMap.fold set_min parentMap (visiting, visited, doms) - in - let dom_min = - let fold parentId res = - let parentDom = get_dom parentId doms in - let parentId = parentDom.Mir.vdom.dom_id in - StrSetSet.singleton parentId - |> StrSetSet.union parentDom.Mir.vdom.dom_min - |> StrSetSet.union res - in - StrSetSet.fold fold dom.Mir.vdom.dom_min StrSetSet.empty - in - let dom = Mir.{ dom with vdom = { dom.vdom with dom_min } } in - let doms = StrSetMap.add id dom doms in - let visiting = StrSetSet.remove id visiting in - let visited = StrSetSet.add id visited in - (visiting, visited, doms) - in - let init = (StrSetSet.empty, StrSetSet.empty, domains) in - let _, _, domains = StrSetMap.fold set_min domains init in - domains - in - let domains = - let set_max id dom doms = - let fold minId doms = - let minDom = StrSetMap.find minId doms in - let dom_max = StrSetSet.add id minDom.Mir.vdom.dom_max in - let minDom = Mir.{ minDom with vdom = { minDom.vdom with dom_max } } in - StrSetMap.add minId minDom doms - in - StrSetSet.fold fold dom.Mir.vdom.dom_min doms - in - StrSetMap.fold set_max domains domains - in - let domains = - match by_default with - | Some def_id -> - let fold _ dom doms = - let foldName name doms = StrSetMap.add name dom doms in - StrSetSet.fold foldName dom.Mir.vdom.dom_names doms - in - StrSetMap.empty - |> StrSetMap.fold fold domains - |> StrSetMap.add StrSet.empty (get_dom def_id domains) - | None -> Errors.raise_error "there are no default verif domain" + let dom_data = { Mir.vdom_auto_cc = decl.Mast.dom_data.vdom_auto_cc } in + Some (decl, dom_data) + | _ -> None in - (* let _ = let iter id dom = let pp_ss fmt ss = let iter s = Format.fprintf - fmt "<%s> " s in StrSet.iter iter ss in let pp_sss fmt sss = let iter ss = - Format.fprintf fmt "%a, " pp_ss ss in StrSetSet.iter iter sss in - Format.printf "XXX %a\n: min: %a\n: max: %a\n" pp_ss id pp_sss - dom.Mir.rdom.dom_min pp_sss dom.Mir.rdom.dom_max in StrSetMap.iter iter - domains; exit 0 in *) - domains + get_domains "verif" get_item p (** Main translation pass that deal with regular variable definition; returns a map whose keys are the variables being defined (with the execution number @@ -1589,8 +1513,7 @@ let get_rules_and_var_data (idmap : Mir.idmap) (Mir.Variable.t list * Mir.rov_id Pos.marked * string Pos.marked list Pos.marked - * Mast.chaining Pos.marked option - * Mast.chain_tag Pos.marked list) + * Mast.chaining Pos.marked option) Mir.RuleMap.t * Mir.variable_data Mir.VariableMap.t = List.fold_left @@ -1672,11 +1595,6 @@ let get_rules_and_var_data (idmap : Mir.idmap) data_to_add) ([], var_data, 0) r.Mast.rule_formulaes in - let rule_tags = - match r.rule_chaining with - | None -> r.rule_tags - | Some (chain, pos) -> (Mast.Custom chain, pos) :: r.rule_tags - in let rule_number = Pos.map_under_mark (fun n -> Mir.RuleID n) r.rule_number in @@ -1684,8 +1602,7 @@ let get_rules_and_var_data (idmap : Mir.idmap) ( List.rev rule_vars, rule_number, r.rule_tag_names, - r.rule_chaining, - rule_tags ) + r.rule_chaining ) in ( Mir.RuleMap.add (Pos.unmark rule_number) rule rule_data, var_data ) @@ -1732,120 +1649,131 @@ let add_dummy_definitions_for_variable_declarations var_data) var_decl_data var_data -(* Arbitrary behavior of legacy compiler *) -let verif_tag_policy verif_tags = - match verif_tags with - | [] -> [ (Mast.Primitif, Pos.no_pos); (Mast.Corrective, Pos.no_pos) ] - | [ (Mast.Custom _, _) ] as l -> - (Mast.Primitif, Pos.no_pos) :: (Mast.Corrective, Pos.no_pos) :: l - | l -> l - let get_conds (error_decls : Mir.Error.t list) (const_map : float Pos.marked ConstMap.t) (idmap : Mir.idmap) - (p : Mast.program) : Mir.condition_data Mir.VariableMap.t = - List.fold_left - (fun conds source_file -> - List.fold_left - (fun conds source_file_item -> - match Pos.unmark source_file_item with - | Mast.Verification verif - when belongs_to_iliad_app verif.Mast.verif_applications -> - let rule_number = Pos.unmark verif.verif_number in - let conds, _ = - List.fold_left - (fun (conds, id_offset) verif_cond -> - let rule_number = rule_number + id_offset in - let e = - translate_expression - { - idmap; - lc = None; - const_map; - table_definition = false; - exec_number = - { - Mir.rule_number; - Mir.seq_number = 0; - Mir.pos = Pos.get_position verif_cond; - }; - } - (Pos.unmark verif_cond).Mast.verif_cond_expr - in - let category = - (* Verifications are maped to a dummy variable, we use it - to store all the subtypes of variables appearing in its - expression to avoid going through it later when we sort - verifications chains out *) - Mir.fold_expr_var - (fun subtypes var -> - List.fold_left - (fun subtypes st -> - if List.mem st subtypes then subtypes - else st :: subtypes) - subtypes var.Mir.category) - [] (Pos.unmark e) - in - let err = - let err_name, err_var = - (Pos.unmark verif_cond).Mast.verif_cond_error + (p : Mast.program) : + Mir.verif_domain Mast.DomainIdMap.t * Mir.condition_data Mir.VariableMap.t = + let verif_domains = get_verif_domains p in + let conds = + List.fold_left + (fun conds source_file -> + List.fold_left + (fun conds source_file_item -> + match Pos.unmark source_file_item with + | Mast.Verification verif + when belongs_to_iliad_app verif.Mast.verif_applications -> + let rule_number = Pos.unmark verif.verif_number in + let conds, _ = + List.fold_left + (fun (conds, id_offset) verif_cond -> + let rule_number = rule_number + id_offset in + let cond_domain = + let vdom_id = + Mast.DomainId.from_marked_list + (Pos.unmark verif.verif_tag_names) + in + match + Mast.DomainIdMap.find_opt vdom_id verif_domains + with + | Some vdom -> vdom + | None -> + Errors.raise_spanned_error "Unknown verif domain" + (Pos.get_position verif.verif_tag_names) in - try - ( List.find - (fun e -> - String.equal - (Pos.unmark e.Mir.Error.name) - (Pos.unmark err_name)) - error_decls, - Option.map - (fun v -> - Mir.get_max_var_sorted_by_execution_number - Mir.sort_by_lowest_exec_number (Pos.unmark v) - idmap) - err_var ) - with Not_found -> - Errors.raise_error - (Format.asprintf "undeclared error %s %a" - (Pos.unmark err_name) Pos.format_position - (Pos.get_position err_name)) - in - let dummy_var = - Mir.Variable.new_var - (Pos.same_pos_as - (Format.sprintf "verification_condition_%d" - (Mir.Variable.fresh_id ())) - e) - None - (Pos.same_pos_as - (let () = - Pos.format_position Format.str_formatter - (Pos.get_position e) - in - Format.flush_str_formatter ()) - e) - { - Mir.rule_number; - Mir.seq_number = 0; - Mir.pos = Pos.get_position verif_cond; - } - ~attributes:[] ~origin:None ~category ~is_table:None - in - ( Mir.VariableMap.add dummy_var - { - Mir.cond_number = - Pos.same_pos_as (Mir.VerifID rule_number) - verif.verif_number; - Mir.cond_expr = e; - Mir.cond_error = err; - Mir.cond_tags = verif_tag_policy verif.Mast.verif_tags; - } - conds, - id_offset + 1 )) - (conds, 0) verif.Mast.verif_conditions - in - conds - | _ -> conds) - conds (List.rev source_file)) (* Order important for DGFiP *) - Mir.VariableMap.empty p + let e = + translate_expression + { + idmap; + lc = None; + const_map; + table_definition = false; + exec_number = + { + Mir.rule_number; + Mir.seq_number = 0; + Mir.pos = Pos.get_position verif_cond; + }; + } + (Pos.unmark verif_cond).Mast.verif_cond_expr + in + let category = + (* Verifications are maped to a dummy variable, we use + it to store all the subtypes of variables appearing + in its expression to avoid going through it later + when we sort verifications chains out *) + Mir.fold_expr_var + (fun subtypes var -> + List.fold_left + (fun subtypes st -> + if List.mem st subtypes then subtypes + else st :: subtypes) + subtypes var.Mir.category) + [] (Pos.unmark e) + in + let err = + let err_name, err_var = + (Pos.unmark verif_cond).Mast.verif_cond_error + in + try + ( List.find + (fun e -> + String.equal + (Pos.unmark e.Mir.Error.name) + (Pos.unmark err_name)) + error_decls, + Option.map + (fun v -> + Mir.get_max_var_sorted_by_execution_number + Mir.sort_by_lowest_exec_number (Pos.unmark v) + idmap) + err_var ) + with Not_found -> + Errors.raise_error + (Format.asprintf "undeclared error %s %a" + (Pos.unmark err_name) Pos.format_position + (Pos.get_position err_name)) + in + let dummy_var = + Mir.Variable.new_var + (Pos.same_pos_as + (Format.sprintf "verification_condition_%d" + (Mir.Variable.fresh_id ())) + e) + None + (Pos.same_pos_as + (let () = + Pos.format_position Format.str_formatter + (Pos.get_position e) + in + Format.flush_str_formatter ()) + e) + { + Mir.rule_number; + Mir.seq_number = 0; + Mir.pos = Pos.get_position verif_cond; + } + ~attributes:[] ~origin:None ~category ~is_table:None + in + ( Mir.VariableMap.add dummy_var + Mir. + { + cond_number = + Pos.same_pos_as (VerifID rule_number) + verif.verif_number; + cond_domain; + cond_expr = e; + cond_error = err; + } + conds, + id_offset + 1 )) + (conds, 0) verif.Mast.verif_conditions + in + conds + | _ -> conds) + conds (List.rev source_file)) (* Order important for DGFiP *) + Mir.VariableMap.empty p + in + (verif_domains, conds) let translate (p : Mast.program) : Mir.program = let const_map = get_constants p in @@ -1855,11 +1783,10 @@ let translate (p : Mast.program) : Mir.program = in let idmap = get_var_redefinitions p idmap const_map in let rule_domains = get_rule_domains p in - let rule_domain_by_default = StrSetMap.find StrSet.empty rule_domains in + let rule_domain_by_default = + Mast.DomainIdMap.find Mast.DomainId.empty rule_domains + in let rule_chains = get_rule_chains rule_domains p in - let verif_domains = get_verif_domains p in - (* let verif_domain_by_default = StrSetMap.find StrSet.empty verif_domains - in *) let rule_data, var_data = get_rules_and_var_data idmap var_decl_data const_map p in @@ -1868,12 +1795,13 @@ let translate (p : Mast.program) : Mir.program = in let rules, rule_vars = Mir.RuleMap.fold - (fun rule_id - (rule_vars, rule_number, rule_tag_names, rule_chaining, rule_tags) + (fun rule_id (rule_vars, rule_number, rule_tag_names, rule_chaining) (rules, vars) -> - let domain_id = StrSet.from_marked_list (Pos.unmark rule_tag_names) in + let domain_id = + Mast.DomainId.from_marked_list (Pos.unmark rule_tag_names) + in let rule_domain = - match StrSetMap.find_opt domain_id rule_domains with + match Mast.DomainIdMap.find_opt domain_id rule_domains with | Some domain -> domain | None -> Errors.raise_spanned_error "unknown rule domain" @@ -1884,7 +1812,7 @@ let translate (p : Mast.program) : Mir.program = | None -> None | Some mch -> let ch_name = Pos.unmark mch in - Some (ch_name, StrMap.find ch_name rule_chains) + Some (ch_name, Mast.ChainingMap.find ch_name rule_chains) in let rule_vars, vars = List.fold_left @@ -1894,9 +1822,8 @@ let translate (p : Mast.program) : Mir.program = Mir.VariableDict.add var vars )) ([], vars) (List.rev rule_vars) in - let rule_tags = List.map Pos.unmark rule_tags in let rule_data = - Mir.{ rule_domain; rule_chain; rule_vars; rule_number; rule_tags } + Mir.{ rule_domain; rule_chain; rule_vars; rule_number } in (Mir.RuleMap.add rule_id rule_data rules, vars)) rule_data @@ -1921,11 +1848,10 @@ let translate (p : Mast.program) : Mir.program = rule_chain = None; rule_vars = orphans; rule_number = (RuleID 0, Pos.no_pos); - rule_tags = []; } rules in - let conds = get_conds error_decls const_map idmap p in + let verif_domains, conds = get_conds error_decls const_map idmap p in { Mir.program_rule_domains = rule_domains; Mir.program_verif_domains = verif_domains; diff --git a/src/mlang/m_frontend/mast_to_mir.mli b/src/mlang/m_frontend/mast_to_mir.mli index ce8d35ca4..e10014d4b 100644 --- a/src/mlang/m_frontend/mast_to_mir.mli +++ b/src/mlang/m_frontend/mast_to_mir.mli @@ -78,7 +78,7 @@ val get_conds : float Pos.marked ConstMap.t -> Mir.idmap -> Mast.program -> - Mir.condition_data Mir.VariableMap.t + Mir.verif_domain Mast.DomainIdMap.t * Mir.condition_data Mir.VariableMap.t (** Returns a map whose keys are dummy variables and whose values are the verification conditions. *) diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index cac7cbc14..493a99eca 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -129,16 +129,16 @@ rule_domain_decl: in let init = None, None, None, None in let dno, dso, dco, dpdo = List.fold_left fold init rdom_params in - let rdom_names = + let dom_names = match dno with | None -> err "rule domain names must be defined" (mk_position $sloc) | Some dn -> dn in { - rdom_names; - rdom_parents = (match dso with None -> [] | Some ds -> ds); - rdom_computable = (match dco with None -> false | _ -> true); - rdom_by_default = (match dpdo with None -> false | _ -> true); + dom_names; + dom_parents = (match dso with None -> [] | Some ds -> ds); + dom_by_default = (match dpdo with None -> false | _ -> true); + dom_data = {rdom_computable = (match dco with None -> false | _ -> true)}; } } @@ -173,16 +173,16 @@ verif_domain_decl: in let init = None, None, None, None in let dno, dso, dao, dpdo = List.fold_left fold init vdom_params in - let vdom_names = + let dom_names = match dno with | None -> err "rule domain names must be defined" (mk_position $sloc) | Some dn -> dn in { - vdom_names; - vdom_parents = (match dso with None -> [] | Some ds -> ds); - vdom_auto_cc = (match dao with None -> false | _ -> true); - vdom_by_default = (match dpdo with None -> false | _ -> true); + dom_names; + dom_parents = (match dso with None -> [] | Some ds -> ds); + dom_by_default = (match dpdo with None -> false | _ -> true); + dom_data = {vdom_auto_cc = (match dao with None -> false | _ -> true);}; } } @@ -347,11 +347,9 @@ rule: "this rule doesn't have an execution number" (Pos.get_position num) in - let rule_tags = Mast.tags_of_name (Pos.unmark rule_tag_names) in { rule_number; rule_tag_names; - rule_tags; rule_applications = apps; rule_chaining = c; rule_formulaes = formulaes; @@ -412,11 +410,9 @@ verification: "this verification doesn't have an execution number" (Pos.get_position num) in - let verif_tags = Mast.tags_of_name (Pos.unmark verif_tag_names) in { verif_number; verif_tag_names; - verif_tags; verif_applications = apps; verif_conditions = conds; } } diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 3c8b20047..765041755 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -348,22 +348,24 @@ let fresh_rule_num = (** Special rule id for initial definition of variables *) let initial_undef_rule_id = RuleID (-1) -type domain = { - dom_id : StrSet.t; - dom_names : StrSetSet.t; +type 'a domain = { + dom_id : Mast.DomainId.t; + dom_names : Mast.DomainIdSet.t; dom_by_default : bool; - dom_min : StrSetSet.t; - dom_max : StrSetSet.t; + dom_min : Mast.DomainIdSet.t; + dom_max : Mast.DomainIdSet.t; + dom_data : 'a; } -type rule_domain = { rdom : domain; rdom_computable : bool } +type rule_domain_data = { rdom_computable : bool } + +type rule_domain = rule_domain_data domain type rule_data = { rule_domain : rule_domain; rule_chain : (string * rule_domain) option; rule_vars : (Variable.id * variable_data) list; rule_number : rov_id Pos.marked; - rule_tags : Mast.chain_tag list; } module RuleMap = MapExt.Make (struct @@ -372,15 +374,6 @@ module RuleMap = MapExt.Make (struct let compare = compare end) -module TagMap = MapExt.Make (struct - type t = Mast.chain_tag - - let compare t1 t2 = - match (t1, t2) with - | Mast.Custom s1, Mast.Custom s2 -> String.compare s1 s2 - | _ -> Stdlib.compare t1 t2 -end) - (**{1 Verification conditions}*) type error_descr = { @@ -458,24 +451,26 @@ module Error = struct let compare (var1 : t) (var2 : t) = compare var1.id var2.id end -type verif_domain = { vdom : domain; vdom_auto_cc : bool } +type verif_domain_data = { vdom_auto_cc : bool } + +type verif_domain = verif_domain_data domain type 'variable condition_data_ = { cond_number : rov_id Pos.marked; + cond_domain : verif_domain; cond_expr : 'variable expression_ Pos.marked; cond_error : (Error.t[@opaque]) * 'variable option; - cond_tags : Mast.chain_tag Pos.marked list; } let map_cond_data_var (f : 'v -> 'v2) (cond : 'v condition_data_) : 'v2 condition_data_ = { cond_number = cond.cond_number; + cond_domain = cond.cond_domain; cond_expr = Pos.map_under_mark (map_expr_var f) cond.cond_expr; cond_error = (let e, v = cond.cond_error in (e, Option.map f v)); - cond_tags = cond.cond_tags; } type condition_data = variable condition_data_ @@ -489,9 +484,9 @@ type idmap = Variable.t list Pos.VarNameToID.t type exec_pass = { exec_pass_set_variables : literal Pos.marked VariableMap.t } type program = { - program_rule_domains : rule_domain StrSetMap.t; - program_verif_domains : verif_domain StrSetMap.t; - program_chainings : rule_domain StrMap.t; + program_rule_domains : rule_domain Mast.DomainIdMap.t; + program_verif_domains : verif_domain Mast.DomainIdMap.t; + program_chainings : rule_domain Mast.ChainingMap.t; program_vars : VariableDict.t; (** A static register of all variables that can be used during a calculation *) @@ -614,89 +609,3 @@ let find_vars_by_io (p : program) (io_to_find : io) : VariableDict.t = then VariableDict.add var acc else acc) p VariableDict.empty - -let tag_to_rule_domain_id : Mast.chain_tag -> StrSet.t = function - | Mast.Primitif -> StrSet.from_list [ "primitive" ] - | Mast.Corrective -> StrSet.from_list [ "corrective" ] - | Mast.Isf -> StrSet.from_list [ "isf" ] - | Mast.Taux -> StrSet.from_list [ "taux" ] - | Mast.Irisf -> StrSet.from_list [ "irisf" ] - | Mast.Base_hr -> StrSet.from_list [ "corrective"; "base_HR" ] - | Mast.Base_tl -> StrSet.from_list [ "corrective"; "base_tl" ] - | Mast.Base_tl_init -> StrSet.from_list [ "corrective"; "base_tl_init" ] - | Mast.Base_tl_rect -> StrSet.from_list [ "corrective"; "base_tl_rect" ] - | Mast.Base_initial -> StrSet.from_list [ "corrective"; "base_INITIAL" ] - | Mast.Base_inr -> StrSet.from_list [ "corrective"; "base_INR" ] - | Mast.Base_inr_ref -> StrSet.from_list [ "corrective"; "base_inr_ref" ] - | Mast.Base_inr_tl -> StrSet.from_list [ "corrective"; "base_inr_tl" ] - | Mast.Base_inr_tl22 -> StrSet.from_list [ "corrective"; "base_inr_tl22" ] - | Mast.Base_inr_tl24 -> StrSet.from_list [ "corrective"; "base_inr_tl24" ] - | Mast.Base_inr_ntl -> StrSet.from_list [ "corrective"; "base_inr_ntl" ] - | Mast.Base_inr_ntl22 -> StrSet.from_list [ "corrective"; "base_inr_ntl22" ] - | Mast.Base_inr_ntl24 -> StrSet.from_list [ "corrective"; "base_inr_ntl24" ] - | Mast.Base_inr_inter22 -> - StrSet.from_list [ "corrective"; "base_inr_inter22" ] - | Mast.Base_inr_intertl -> - StrSet.from_list [ "corrective"; "base_inr_intertl" ] - | Mast.Base_inr_r9901 -> StrSet.from_list [ "corrective"; "base_inr_r9901" ] - | Mast.Base_inr_cimr07 -> StrSet.from_list [ "corrective"; "base_inr_cimr07" ] - | Mast.Base_inr_cimr24 -> StrSet.from_list [ "corrective"; "base_inr_cimr24" ] - | Mast.Base_inr_cimr99 -> StrSet.from_list [ "corrective"; "base_inr_cimr99" ] - | Mast.Base_inr_tlcimr07 -> - StrSet.from_list [ "corrective"; "base_inr_tlcimr07" ] - | Mast.Base_inr_tlcimr24 -> - StrSet.from_list [ "corrective"; "base_inr_tlcimr24" ] - | Mast.Base_abat98 -> StrSet.from_list [ "corrective"; "base_ABAT98" ] - | Mast.Base_abat99 -> StrSet.from_list [ "corrective"; "base_ABAT99" ] - | Mast.Base_majo -> StrSet.from_list [ "corrective"; "base_MAJO" ] - | Mast.Base_premier -> StrSet.from_list [ "corrective"; "base_premier" ] - | Mast.Base_anterieure -> StrSet.from_list [ "corrective"; "base_anterieure" ] - | Mast.Base_anterieure_cor -> - StrSet.from_list [ "corrective"; "base_anterieure_cor" ] - | Mast.Base_stratemajo -> StrSet.from_list [ "corrective"; "base_stratemajo" ] - | Mast.Non_auto_cc -> StrSet.from_list [ "non_auto_cc" ] - | Mast.Horizontale -> StrSet.from_list [ "horizontale" ] - | Mast.PrimCorr -> StrSet.from_list [ "irisf"; "corrective" ] - | Mast.Custom _ -> assert false -(* StrSet.from_list [ "custom"; ch ] *) - -let string_to_rule_domain_id : string -> StrSet.t = function - | "primitif" -> StrSet.from_list [ "primitive" ] - | "corrective" -> StrSet.from_list [ "corrective" ] - | "isf" -> StrSet.from_list [ "isf" ] - | "taux" -> StrSet.from_list [ "taux" ] - | "irisf" -> StrSet.from_list [ "irisf" ] - | "base_HR" -> StrSet.from_list [ "corrective"; "base_HR" ] - | "base_tl" -> StrSet.from_list [ "corrective"; "base_tl" ] - | "base_tl_init" -> StrSet.from_list [ "corrective"; "base_INITIAL" ] - | "base_tl_rect" -> StrSet.from_list [ "corrective"; "base_tl_rect" ] - | "base_INITIAL" -> StrSet.from_list [ "corrective"; "base_INITIAL" ] - | "base_INR" -> StrSet.from_list [ "corrective"; "base_INR" ] - | "base_inr_ref" -> StrSet.from_list [ "corrective"; "base_inr_ref" ] - | "base_inr_tl" -> StrSet.from_list [ "corrective"; "base_inr_tl" ] - | "base_inr_tl22" -> StrSet.from_list [ "corrective"; "base_inr_tl22" ] - | "base_inr_tl24" -> StrSet.from_list [ "corrective"; "base_inr_tl24" ] - | "base_inr_ntl" -> StrSet.from_list [ "corrective"; "base_inr_ntl" ] - | "base_inr_ntl22" -> StrSet.from_list [ "corrective"; "base_inr_ntl22" ] - | "base_inr_ntl24" -> StrSet.from_list [ "corrective"; "base_inr_ntl24" ] - | "base_inr_inter22" -> StrSet.from_list [ "corrective"; "base_inr_inter22" ] - | "base_inr_intertl" -> StrSet.from_list [ "corrective"; "base_inr_intertl" ] - | "base_inr_r9901" -> StrSet.from_list [ "corrective"; "base_inr_r9901" ] - | "base_inr_cimr07" -> StrSet.from_list [ "corrective"; "base_inr_cimr07" ] - | "base_inr_cimr24" -> StrSet.from_list [ "corrective"; "base_inr_cimr24" ] - | "base_inr_cimr99" -> StrSet.from_list [ "corrective"; "base_inr_cimr99" ] - | "base_inr_tlcimr07" -> - StrSet.from_list [ "corrective"; "base_inr_tlcimr07" ] - | "base_inr_tlcimr24" -> - StrSet.from_list [ "corrective"; "base_inr_tlcimr24" ] - | "base_ABAT98" -> StrSet.from_list [ "corrective"; "base_ABAT98" ] - | "base_ABAT99" -> StrSet.from_list [ "corrective"; "base_ABAT99" ] - | "base_MAJO" -> StrSet.from_list [ "corrective"; "base_MAJO" ] - | "base_premier" -> StrSet.from_list [ "corrective"; "base_premier" ] - | "base_anterieure" -> StrSet.from_list [ "corrective"; "base_anterieure" ] - | "base_anterieure_cor" -> - StrSet.from_list [ "corrective"; "base_anterieure_cor" ] - | "base_stratemajo" -> StrSet.from_list [ "corrective"; "base_stratemajo" ] - | "non_auto_cc" -> StrSet.from_list [ "non_auto_cc" ] - | "horizontale" -> StrSet.from_list [ "horizontale" ] - | _ -> raise Not_found diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 4f7b65f6f..f1af7cdba 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -140,26 +140,26 @@ type rov_id = RuleID of int | VerifID of int module RuleMap : MapExt.T with type key = rov_id -type domain = { - dom_id : StrSet.t; - dom_names : StrSetSet.t; +type 'a domain = { + dom_id : Mast.DomainId.t; + dom_names : Mast.DomainIdSet.t; dom_by_default : bool; - dom_min : StrSetSet.t; - dom_max : StrSetSet.t; + dom_min : Mast.DomainIdSet.t; + dom_max : Mast.DomainIdSet.t; + dom_data : 'a; } -type rule_domain = { rdom : domain; rdom_computable : bool } +type rule_domain_data = { rdom_computable : bool } + +type rule_domain = rule_domain_data domain type rule_data = { rule_domain : rule_domain; rule_chain : (string * rule_domain) option; rule_vars : (variable_id * variable_data) list; rule_number : rov_id Pos.marked; - rule_tags : Mast.chain_tag list; } -module TagMap : MapExt.T with type key = Mast.chain_tag - type error_descr = { kind : string Pos.marked; major_code : string Pos.marked; @@ -176,13 +176,15 @@ type error = { typ : Mast.error_typ; } -type verif_domain = { vdom : domain; vdom_auto_cc : bool } +type verif_domain_data = { vdom_auto_cc : bool } + +type verif_domain = verif_domain_data domain type 'variable condition_data_ = { cond_number : rov_id Pos.marked; + cond_domain : verif_domain; cond_expr : 'variable expression_ Pos.marked; cond_error : error * 'variable option; - cond_tags : Mast.chain_tag Pos.marked list; } type condition_data = variable condition_data_ @@ -195,9 +197,9 @@ type idmap = variable list Pos.VarNameToID.t type exec_pass = { exec_pass_set_variables : literal Pos.marked VariableMap.t } type program = { - program_rule_domains : rule_domain StrSetMap.t; - program_verif_domains : verif_domain StrSetMap.t; - program_chainings : rule_domain StrMap.t; + program_rule_domains : rule_domain Mast.DomainIdMap.t; + program_verif_domains : verif_domain Mast.DomainIdMap.t; + program_chainings : rule_domain Mast.ChainingMap.t; program_vars : VariableDict.t; (** A static register of all variables that can be used during a calculation *) @@ -334,7 +336,3 @@ val find_vars_by_io : program -> io -> VariableDict.t (** Returns a VariableDict.t containing all the variables that have a given io type, only one variable per name is entered in the VariableDict.t, this function chooses the one with the highest execution number*) - -val tag_to_rule_domain_id : Mast.chain_tag -> StrSet.t - -val string_to_rule_domain_id : string -> StrSet.t diff --git a/src/mlang/m_ir/mir_interface.ml b/src/mlang/m_ir/mir_interface.ml index 41d091e91..4cc1f517b 100644 --- a/src/mlang/m_ir/mir_interface.ml +++ b/src/mlang/m_ir/mir_interface.ml @@ -55,20 +55,20 @@ type chain_order = { type full_program = { program : Mir.program; - domains_orders : chain_order StrSetMap.t; - chainings_orders : chain_order StrMap.t; + domains_orders : chain_order Mast.DomainIdMap.t; + chainings_orders : chain_order Mast.ChainingMap.t; } let to_full_program (program : program) : full_program = let domains_orders = - StrSetMap.fold + Mast.DomainIdMap.fold (fun dom_id _ domains_orders -> let vars_to_rules, chain_rules = Mir.RuleMap.fold (fun rov_id rule (vars, rules) -> let rule_domain = rule.rule_domain in - let is_max = StrSetSet.mem dom_id rule_domain.rdom.dom_max in - let is_eq = rule_domain.rdom.dom_id = dom_id in + let is_max = Mast.DomainIdSet.mem dom_id rule_domain.dom_max in + let is_eq = rule_domain.dom_id = dom_id in let is_not_rule_0 = Pos.unmark rule.rule_number <> RuleID 0 in if is_not_rule_0 && (is_max || is_eq) then ( List.fold_left @@ -88,15 +88,17 @@ let to_full_program (program : program) : full_program = let execution_order = Mir_dependency_graph.get_rules_execution_order dep_graph in - StrSetMap.add dom_id { dep_graph; execution_order } domains_orders) - program.program_rule_domains StrSetMap.empty + Mast.DomainIdMap.add dom_id + { dep_graph; execution_order } + domains_orders) + program.program_rule_domains Mast.DomainIdMap.empty in let chainings_orders = let chainings_roots = - StrMap.map + Mast.ChainingMap.map (fun chain_dom -> let dep_graph = - (StrSetMap.find chain_dom.rdom.dom_id domains_orders).dep_graph + (Mast.DomainIdMap.find chain_dom.dom_id domains_orders).dep_graph in (dep_graph, [])) program.program_chainings @@ -106,18 +108,20 @@ let to_full_program (program : program) : full_program = (fun rov_id rule chainings_roots -> match rule.rule_chain with | Some (chain_id, _) -> - let g, rs = StrMap.find chain_id chainings_roots in - StrMap.add chain_id (g, rov_id :: rs) chainings_roots + let g, rs = Mast.ChainingMap.find chain_id chainings_roots in + Mast.ChainingMap.add chain_id (g, rov_id :: rs) chainings_roots | None -> chainings_roots) program.program_rules chainings_roots in - StrMap.fold + Mast.ChainingMap.fold (fun chain_id (dep_graph, chain_roots) chainings_orders -> let dep_graph, execution_order = Mir_dependency_graph.pull_rules_dependencies dep_graph chain_roots in - StrMap.add chain_id { dep_graph; execution_order } chainings_orders) - chainings_roots StrMap.empty + Mast.ChainingMap.add chain_id + { dep_graph; execution_order } + chainings_orders) + chainings_roots Mast.ChainingMap.empty in { program; domains_orders; chainings_orders } diff --git a/src/mlang/m_ir/mir_interface.mli b/src/mlang/m_ir/mir_interface.mli index 6f9693abb..b13b6ee58 100644 --- a/src/mlang/m_ir/mir_interface.mli +++ b/src/mlang/m_ir/mir_interface.mli @@ -28,8 +28,8 @@ type chain_order = { type full_program = { program : Mir.program; - domains_orders : chain_order StrSetMap.t; - chainings_orders : chain_order StrMap.t; + domains_orders : chain_order Mast.DomainIdMap.t; + chainings_orders : chain_order Mast.ChainingMap.t; } val to_full_program : Mir.program -> full_program diff --git a/src/mlang/mpp_frontend/mpp_frontend.ml b/src/mlang/mpp_frontend/mpp_frontend.ml index bdae72328..374b7ce79 100644 --- a/src/mlang/mpp_frontend/mpp_frontend.ml +++ b/src/mlang/mpp_frontend/mpp_frontend.ml @@ -69,7 +69,7 @@ let to_mpp_callable (cname : string Pos.marked) (args : string Pos.marked list) Errors.raise_spanned_error "Expected a chain to call" (Pos.get_position cname) | chain :: args -> - (Program (Mast.chain_tag_of_string (Pos.unmark chain)), args) + (Program (Dgfip_m.string_to_rule_domain_id (Pos.unmark chain)), args) end | "call_m_verif" -> begin match args with @@ -77,7 +77,7 @@ let to_mpp_callable (cname : string Pos.marked) (args : string Pos.marked list) Errors.raise_spanned_error "Expected a chain to call" (Pos.get_position cname) | chain :: args -> - let chain = Mast.chain_tag_of_string (Pos.unmark chain) in + let chain = Dgfip_m.string_to_verif_domain_id (Pos.unmark chain) in let filter = match args with | [] -> None diff --git a/src/mlang/mpp_ir/mpp_format.ml b/src/mlang/mpp_ir/mpp_format.ml index 827038049..c65900db7 100644 --- a/src/mlang/mpp_ir/mpp_format.ml +++ b/src/mlang/mpp_ir/mpp_format.ml @@ -33,10 +33,9 @@ let format_callable (fmt : formatter) (f : mpp_callable) = fprintf fmt "%s" (match f with | Program chain -> - Format.asprintf "evaluate_program(%a)" Format_mast.format_chain_tag - chain + Format.asprintf "evaluate_program(%a)" (Mast.DomainId.pp ()) chain | Verif (chain, filter) -> - Format.asprintf "verification(%a%a)" Format_mast.format_chain_tag chain + Format.asprintf "verification(%a%a)" (Mast.DomainId.pp ()) chain (pp_print_option format_var_filter) filter | MppFunction m -> m diff --git a/src/mlang/mpp_ir/mpp_ir.ml b/src/mlang/mpp_ir/mpp_ir.ml index ec5f0ae60..e7e598013 100644 --- a/src/mlang/mpp_ir/mpp_ir.ml +++ b/src/mlang/mpp_ir/mpp_ir.ml @@ -33,8 +33,8 @@ type mpp_compute_name = string type var_filter = Saisie of string option | Calculee of string option type mpp_callable = - | Program of Mast.chain_tag (* M codebase *) - | Verif of Mast.chain_tag * var_filter option (* M codebase *) + | Program of Mast.DomainId.t (* M codebase *) + | Verif of Mast.DomainId.t * var_filter option (* M codebase *) | MppFunction of mpp_compute_name | Present | Abs diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml index 34bb62ada..5f2dfe182 100644 --- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml +++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml @@ -17,8 +17,8 @@ type translation_ctx = { new_variables : Bir.variable StrMap.t; variables_used_as_inputs : Mir.VariableDict.t; - used_rule_domains : StrSetSet.t; - used_chainings : StrSet.t; + used_rule_domains : Mast.DomainIdSet.t; + used_chainings : Mast.ChainingSet.t; verif_seen : bool; } @@ -26,8 +26,8 @@ let empty_translation_ctx : translation_ctx = { new_variables = StrMap.empty; variables_used_as_inputs = Mir.VariableDict.empty; - used_rule_domains = StrSetSet.empty; - used_chainings = StrSet.empty; + used_rule_domains = Mast.DomainIdSet.empty; + used_chainings = Mast.ChainingSet.empty; verif_seen = false; } @@ -43,8 +43,9 @@ let ctx_join ctx1 ctx2 = Mir.VariableDict.union ctx1.variables_used_as_inputs ctx2.variables_used_as_inputs; used_rule_domains = - StrSetSet.union ctx1.used_rule_domains ctx2.used_rule_domains; - used_chainings = StrSet.union ctx1.used_chainings ctx2.used_chainings; + Mast.DomainIdSet.union ctx1.used_rule_domains ctx2.used_rule_domains; + used_chainings = + Mast.ChainingSet.union ctx1.used_chainings ctx2.used_chainings; verif_seen = ctx1.verif_seen || ctx2.verif_seen; } @@ -218,23 +219,23 @@ let generate_verif_cond (cond : Mir.condition_data) : Bir.stmt = (Bir.SVerif data, Pos.get_position data.cond_expr) let generate_verif_call (m_program : Mir_interface.full_program) - (chain_tag : Mast.chain_tag) (filter : Mpp_ir.var_filter option) : + (chain : Mast.DomainId.t) (filter : Mpp_ir.var_filter option) : Bir.stmt list = let is_verif_relevant var cond = (* specific restriction *) let test = - Mast.are_tags_part_of_verif_chain - (List.map Pos.unmark cond.Mir.cond_tags) - chain_tag - (* We use the constructed subtypes of the dummy variable built in - [Mast_to_mir] *) + let verif_domain = cond.Mir.cond_domain in + let is_max = Mast.DomainIdSet.mem chain verif_domain.dom_max in + let is_eq = verif_domain.dom_id = chain in + (is_max || is_eq) && match filter with | None -> true | Some filter -> var_filter_compatible_subtypes var.Mir.category filter in if - test && chain_tag <> Horizontale + test + && (not (Mast.DomainId.mem "horizontale" chain)) && List.exists (String.equal Mast.penality_category) var.Mir.category then Errors.raise_spanned_error "Penality variable used in verification" @@ -400,27 +401,38 @@ and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list) real_args ), pos ); ] ) - | Mpp_ir.Expr (Call (Program chain_tag, _args), _) -> + | Mpp_ir.Expr (Call (Program chain, _args), _) -> let order, ctx = let order, used_rule_domains, used_chainings = - match chain_tag with - | Custom ch -> - let order = StrMap.find ch m_program.chainings_orders in - (order, ctx.used_rule_domains, StrSet.add ch ctx.used_chainings) - | _ -> - let rdom_id = Mir.tag_to_rule_domain_id chain_tag in - let order = StrSetMap.find rdom_id m_program.domains_orders in - let dom = Mir.tag_to_rule_domain_id chain_tag in + match Mast.DomainIdMap.find_opt chain m_program.domains_orders with + | Some order -> ( order, - StrSetSet.add dom ctx.used_rule_domains, + Mast.DomainIdSet.add chain ctx.used_rule_domains, ctx.used_chainings ) + | None -> + if Mast.DomainId.cardinal chain = 1 then + let chain_id = Mast.DomainId.min_elt chain in + match + Mast.ChainingMap.find_opt chain_id m_program.chainings_orders + with + | Some order -> + ( order, + ctx.used_rule_domains, + Mast.ChainingSet.add chain_id ctx.used_chainings ) + | None -> + Errors.raise_error + (Format.asprintf "Unknown chaining: %s" chain_id) + else + Errors.raise_error + (Format.asprintf "Unknown rule domain: %a" + (Mast.DomainId.pp ()) chain) in (order, { ctx with used_rule_domains; used_chainings }) in wrap_m_code_call m_program order ctx - | Mpp_ir.Expr (Call (Verif (chain_tag, filter), _args), _) -> + | Mpp_ir.Expr (Call (Verif (chain, filter), _args), _) -> ( { ctx with verif_seen = true }, - generate_verif_call m_program chain_tag filter ) + generate_verif_call m_program chain filter ) | Mpp_ir.Partition (filter, body) -> let func_of_filter = match filter with Mpp_ir.VarIsTaxBenefit -> var_is_ "avfisc" @@ -500,16 +512,16 @@ let create_combined_program (m_program : Mir_interface.full_program) let rule_domain = rule_data.Mir.rule_domain in let has_max = not - (StrSetSet.disjoint ctx.used_rule_domains - rule_domain.rdom.dom_max) + (Mast.DomainIdSet.disjoint ctx.used_rule_domains + rule_domain.dom_max) in let has_used_domain = - StrSetSet.mem rule_domain.rdom.dom_id ctx.used_rule_domains + Mast.DomainIdSet.mem rule_domain.dom_id ctx.used_rule_domains in let has_used_chaining = match rule_data.Mir.rule_chain with | None -> false - | Some (ch, _) -> StrSet.mem ch ctx.used_chainings + | Some (ch, _) -> Mast.ChainingSet.mem ch ctx.used_chainings in let is_not_rule_0 = Pos.unmark rule_data.Mir.rule_number <> RuleID 0 From 89696094512c23e3c0c54872dbde4da52a9beea8 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 4 Jul 2023 15:58:24 +0200 Subject: [PATCH 11/26] =?UTF-8?q?Correction=20d'une=20erreur=20b=C3=AAte.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/dgfip_m.ml | 2 +- src/mlang/mpp_frontend/mpp_frontend.ml | 7 ++++++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/mlang/dgfip_m.ml b/src/mlang/dgfip_m.ml index 7d5e1b1bc..7a15982dc 100644 --- a/src/mlang/dgfip_m.ml +++ b/src/mlang/dgfip_m.ml @@ -232,7 +232,7 @@ let string_to_rule_domain_id : string -> Mast.DomainId.t = function | "irisf" -> Mast.DomainId.from_list [ "irisf" ] | "base_HR" -> Mast.DomainId.from_list [ "corrective"; "base_HR" ] | "base_tl" -> Mast.DomainId.from_list [ "corrective"; "base_tl" ] - | "base_tl_init" -> Mast.DomainId.from_list [ "corrective"; "base_INITIAL" ] + | "base_tl_init" -> Mast.DomainId.from_list [ "corrective"; "base_tl_init" ] | "base_tl_rect" -> Mast.DomainId.from_list [ "corrective"; "base_tl_rect" ] | "base_INITIAL" -> Mast.DomainId.from_list [ "corrective"; "base_INITIAL" ] | "base_INR" -> Mast.DomainId.from_list [ "corrective"; "base_INR" ] diff --git a/src/mlang/mpp_frontend/mpp_frontend.ml b/src/mlang/mpp_frontend/mpp_frontend.ml index 374b7ce79..63def93f8 100644 --- a/src/mlang/mpp_frontend/mpp_frontend.ml +++ b/src/mlang/mpp_frontend/mpp_frontend.ml @@ -69,7 +69,12 @@ let to_mpp_callable (cname : string Pos.marked) (args : string Pos.marked list) Errors.raise_spanned_error "Expected a chain to call" (Pos.get_position cname) | chain :: args -> - (Program (Dgfip_m.string_to_rule_domain_id (Pos.unmark chain)), args) + let dom_id = + let ch = Pos.unmark chain in + try Dgfip_m.string_to_rule_domain_id ch + with _ -> Mast.DomainId.singleton ch + in + (Program dom_id, args) end | "call_m_verif" -> begin match args with From d2087ebb9abd73e694c0d359356bdd0ab6a34589 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 6 Jul 2023 13:03:59 +0200 Subject: [PATCH 12/26] Modification du M++ pour tenir compte des domaines. --- mpp_specs/dgfip_base.mpp | 96 +++++++++++++------------- src/mlang/mpp_frontend/mpp_ast.ml | 3 + src/mlang/mpp_frontend/mpp_frontend.ml | 73 ++++++++++---------- src/mlang/mpp_frontend/mpp_lexer.mll | 3 + src/mlang/mpp_frontend/mpp_parser.mly | 31 +++++++-- src/mlang/mpp_ir/mpp_format.ml | 8 +-- src/mlang/mpp_ir/mpp_ir.ml | 5 +- src/mlang/mpp_ir/mpp_ir_to_bir.ml | 60 ++++++++-------- 8 files changed, 154 insertions(+), 125 deletions(-) diff --git a/mpp_specs/dgfip_base.mpp b/mpp_specs/dgfip_base.mpp index 697ffd216..4a0c30dc9 100644 --- a/mpp_specs/dgfip_base.mpp +++ b/mpp_specs/dgfip_base.mpp @@ -1,156 +1,156 @@ calcul_primitif(): - outputs <- call_m(primitif) + outputs <- call_m_rules(primitive) calcul_primitif_isf(): - outputs <- call_m(isf) + outputs <- call_m_rules(isf) calcul_primitif_taux(): - outputs <- call_m(taux) + outputs <- call_m_rules(taux) calcul_correctif(): - outputs <- call_m(corrective) + outputs <- call_m_rules(corrective) sauve_base_1728(): X = X -# outputs <- call_m(base_1728) +# outputs <- call_m_rules(base_1728 corrective) sauve_base_premier(): - outputs <- call_m(base_premier) + outputs <- call_m_rules(base_premier corrective) sauve_base_stratemajo(): - outputs <- call_m(base_stratemajo) + outputs <- call_m_rules(base_stratemajo corrective) sauve_base_anterieure(): - outputs <- call_m(base_anterieure) + outputs <- call_m_rules(base_anterieure corrective) sauve_base_anterieure_cor(): - outputs <- call_m(base_anterieure_cor) + outputs <- call_m_rules(base_anterieure_cor corrective) sauve_base_inr_tl(): - outputs <- call_m(base_inr_tl) + outputs <- call_m_rules(base_inr_tl corrective) sauve_base_inr_tl22(): - outputs <- call_m(base_inr_tl22) + outputs <- call_m_rules(base_inr_tl22 corrective) sauve_base_inr_tl24(): - outputs <- call_m(base_inr_tl24) + outputs <- call_m_rules(base_inr_tl24 corrective) sauve_base_inr_ntl(): - outputs <- call_m(base_inr_ntl) + outputs <- call_m_rules(base_inr_ntl corrective) sauve_base_inr_ntl22(): - outputs <- call_m(base_inr_ntl22) + outputs <- call_m_rules(base_inr_ntl22 corrective) sauve_base_inr_ntl24(): - outputs <- call_m(base_inr_ntl24) + outputs <- call_m_rules(base_inr_ntl24 corrective) sauve_base_inr_ref(): - outputs <- call_m(base_inr_ref) + outputs <- call_m_rules(base_inr_ref corrective) sauve_base_inr_r9901(): - outputs <- call_m(base_inr_r9901) + outputs <- call_m_rules(base_inr_r9901 corrective) sauve_base_inr_intertl(): - outputs <- call_m(base_inr_intertl) + outputs <- call_m_rules(base_inr_intertl corrective) sauve_base_inr_inter22(): - outputs <- call_m(base_inr_inter22) + outputs <- call_m_rules(base_inr_inter22 corrective) sauve_base_inr_cimr99(): - outputs <- call_m(base_inr_cimr99) + outputs <- call_m_rules(base_inr_cimr99 corrective) sauve_base_inr_cimr07(): - outputs <- call_m(base_inr_cimr07) + outputs <- call_m_rules(base_inr_cimr07 corrective) sauve_base_inr_cimr24(): - outputs <- call_m(base_inr_cimr24) + outputs <- call_m_rules(base_inr_cimr24 corrective) sauve_base_inr_tlcimr07(): - outputs <- call_m(base_inr_tlcimr07) + outputs <- call_m_rules(base_inr_tlcimr07 corrective) sauve_base_inr_tlcimr24(): - outputs <- call_m(base_inr_tlcimr24) + outputs <- call_m_rules(base_inr_tlcimr24 corrective) sauve_base_tlnunv(): X = X -# outputs <- call_m(base_tlnunv) +# outputs <- call_m_rules(base_tlnunv corrective) sauve_base_tl(): - outputs <- call_m(base_tl) + outputs <- call_m_rules(base_tl corrective) sauve_base_tl_init(): - outputs <- call_m(base_tl_init) + outputs <- call_m_rules(base_tl_init corrective) sauve_base_tl_rect(): - outputs <- call_m(base_tl_rect) + outputs <- call_m_rules(base_tl_rect corrective) sauve_base_initial(): - outputs <- call_m(base_INITIAL) + outputs <- call_m_rules(base_INITIAL corrective) sauve_base_abat98(): - outputs <- call_m(base_ABAT98) + outputs <- call_m_rules(base_ABAT98 corrective) sauve_base_abat99(): - outputs <- call_m(base_ABAT99) + outputs <- call_m_rules(base_ABAT99 corrective) sauve_base_majo(): - outputs <- call_m(base_MAJO) + outputs <- call_m_rules(base_MAJO corrective) sauve_base_inr(): - outputs <- call_m(base_INR) + outputs <- call_m_rules(base_INR corrective) sauve_base_HR(): - outputs <- call_m(base_HR) + outputs <- call_m_rules(base_HR corrective) ENCH_TL(): - outputs <- call_m(ENCH_TL) + outputs <- call_m_chain(ENCH_TL) verif_calcul_primitive_isf_raw(): - call_m_verif(isf,calculee) + call_m_verifs(isf,calculee) verif_calcul_primitive_raw(): verif_calcul_primitive_isf_raw() - call_m_verif(primitif,calculee) + call_m_verifs(primitive,calculee) verif_calcul_corrective_raw(): outputs <- calcul_primitif_isf() verif_calcul_primitive_isf_raw() - call_m_verif(corrective,calculee) + call_m_verifs(corrective,calculee) verif_saisie_cohe_primitive_isf_raw(): - call_m_verif(isf,saisie) + call_m_verifs(isf,saisie) verif_saisie_cohe_primitive_raw(): verif_saisie_cohe_primitive_isf_raw() outputs <- calcul_primitif_isf() verif_calcul_primitive_isf_raw() - call_m_verif(primitif,saisie) + call_m_verifs(primitive,saisie) verif_saisie_cohe_corrective_raw(): verif_saisie_cohe_primitive_isf_raw() - call_m_verif(corrective,saisie) + call_m_verifs(corrective,saisie) verif_cohe_horizontale_raw(): - call_m_verif(horizontale) + call_m_verifs(horizontale corrective) verif_contexte_cohe_primitive_raw(): - call_m_verif(primitive,contexte) + call_m_verifs(primitive,contexte) verif_contexte_cohe_corrective_raw(): - call_m_verif(corrective,contexte) + call_m_verifs(corrective,contexte) verif_famille_cohe_primitive_raw(): - call_m_verif(primitive,famille) + call_m_verifs(primitive,famille) verif_famille_cohe_corrective_raw(): - call_m_verif(corrective,famille) + call_m_verifs(corrective,famille) verif_revenu_cohe_primitive_raw(): - call_m_verif(primitive,revenu) + call_m_verifs(primitive,revenu) verif_revenu_cohe_corrective_raw(): - call_m_verif(corrective,revenu) + call_m_verifs(corrective,revenu) dgfip_calculation(): APPLI_OCEANS = 0 diff --git a/src/mlang/mpp_frontend/mpp_ast.ml b/src/mlang/mpp_frontend/mpp_ast.ml index bd04a4384..48f4906ac 100644 --- a/src/mlang/mpp_frontend/mpp_ast.ml +++ b/src/mlang/mpp_frontend/mpp_ast.ml @@ -16,6 +16,9 @@ and expr_kind = | Constant of int | Variable of var | Unop of unop * expr + | CallRules of string Pos.marked list Pos.marked * var Pos.marked list + | CallChain of var Pos.marked list + | CallVerifs of string Pos.marked list Pos.marked * var Pos.marked list | Call of callable Pos.marked * var Pos.marked list | Binop of expr * binop * expr diff --git a/src/mlang/mpp_frontend/mpp_frontend.ml b/src/mlang/mpp_frontend/mpp_frontend.ml index 63def93f8..05378e037 100644 --- a/src/mlang/mpp_frontend/mpp_frontend.ml +++ b/src/mlang/mpp_frontend/mpp_frontend.ml @@ -59,42 +59,6 @@ let to_mpp_callable (cname : string Pos.marked) (translated_names : string list) (Format.sprintf "unknown callable %s" x) (Pos.get_position cname) -let to_mpp_callable (cname : string Pos.marked) (args : string Pos.marked list) - (translated_names : string list) : mpp_callable * string Pos.marked list = - let name = Pos.unmark cname in - match name with - | "call_m" -> begin - match args with - | [] -> - Errors.raise_spanned_error "Expected a chain to call" - (Pos.get_position cname) - | chain :: args -> - let dom_id = - let ch = Pos.unmark chain in - try Dgfip_m.string_to_rule_domain_id ch - with _ -> Mast.DomainId.singleton ch - in - (Program dom_id, args) - end - | "call_m_verif" -> begin - match args with - | [] -> - Errors.raise_spanned_error "Expected a chain to call" - (Pos.get_position cname) - | chain :: args -> - let chain = Dgfip_m.string_to_verif_domain_id (Pos.unmark chain) in - let filter = - match args with - | [] -> None - | [ filter ] -> Some (filter_of_string filter) - | arg :: _ -> - Errors.raise_spanned_error "unexpected additional argument" - (Pos.get_position arg) - in - (Verif (chain, filter), args) - end - | _ -> (to_mpp_callable cname translated_names, args) - let rec to_mpp_expr (p : Mir.program) (translated_names : mpp_compute_name list) (scope : mpp_compute_name list) (e : Mpp_ast.expr) : mpp_expr * Mpp_ast.var list = @@ -110,8 +74,43 @@ let rec to_mpp_expr (p : Mir.program) (translated_names : mpp_compute_name list) | Unop (Minus, e) -> let e', scope = to_mpp_expr p translated_names scope e in (Unop (Minus, e'), scope) + | CallRules (dom, args) -> + let c' = + let dom_id = Mast.DomainId.from_marked_list (Pos.unmark dom) in + Rules dom_id + in + let new_scope = List.map Pos.unmark args in + let args' = List.map (to_scoped_var p) args in + (Call (c', args'), new_scope) + | CallChain args -> + let c', args = + match args with + | [] -> + Errors.raise_spanned_error "Expected a chain to call" + (Pos.get_position e) + | chain :: args -> (Chain (Pos.unmark chain), args) + in + let new_scope = List.map Pos.unmark args in + let args' = List.map (to_scoped_var p) args in + (Call (c', args'), new_scope) + | CallVerifs (dom, args) -> + let c' = + let dom_id = Mast.DomainId.from_marked_list (Pos.unmark dom) in + let filter = + match args with + | [] -> None + | [ filter ] -> Some (filter_of_string filter) + | arg :: _ -> + Errors.raise_spanned_error "unexpected additional argument" + (Pos.get_position arg) + in + Verifs (dom_id, filter) + in + let new_scope = List.map Pos.unmark args in + let args' = List.map (to_scoped_var p) args in + (Call (c', args'), new_scope) | Call (c, args) -> - let c', args = to_mpp_callable c args translated_names in + let c' = to_mpp_callable c translated_names in let new_scope = List.map Pos.unmark args in let args' = List.map (to_scoped_var p) args in (Call (c', args'), new_scope) diff --git a/src/mlang/mpp_frontend/mpp_lexer.mll b/src/mlang/mpp_frontend/mpp_lexer.mll index 50e9ca5b0..d6d620088 100644 --- a/src/mlang/mpp_frontend/mpp_lexer.mll +++ b/src/mlang/mpp_frontend/mpp_lexer.mll @@ -42,6 +42,9 @@ rule next_tokens = parse | "else" { [ELSE] } | "del" { [DELETE] } | "partition with" { [PARTITION] } + | "call_m_rules" { [CALL_M_RULES] } + | "call_m_chain" { [CALL_M_CHAIN] } + | "call_m_verifs" { [CALL_M_VERIFS] } | ':' { [COLON] } | integer as i { [INT (int_of_string i)] } | ['a'-'z' 'A'-'Z' '0'-'9' '_']+ as s diff --git a/src/mlang/mpp_frontend/mpp_parser.mly b/src/mlang/mpp_frontend/mpp_parser.mly index e779594a4..2ed9ed63a 100644 --- a/src/mlang/mpp_frontend/mpp_parser.mly +++ b/src/mlang/mpp_frontend/mpp_parser.mly @@ -12,6 +12,7 @@ %token EQUAL NEQ EQ LPAREN RPAREN LEFTARROW %token AND OR %token IF ELSE DELETE PARTITION COLON COMMA MINUS +%token CALL_M_RULES CALL_M_CHAIN CALL_M_VERIFS %left OR %left AND @@ -35,13 +36,35 @@ ident: | i = IDENT { (i, mk_position $sloc) } ; +ident_list: +| l = nonempty_list(ident) { (l, mk_position $sloc) } +; + +%inline domain_args: +| dom = ident_list { dom, [] } +| dom = ident_list COMMA args = separated_list(COMMA, ident) { dom, args } + stmt: -| args = separated_list(COMMA, ident) LEFTARROW var = ident LPAREN RPAREN NEWLINE { Expr(Call(var, args), mk_position $sloc), mk_position $sloc } -| args = separated_list(COMMA, ident) LEFTARROW var = ident LPAREN chain = ident RPAREN NEWLINE { Expr(Call(var, chain :: args), mk_position $sloc), mk_position $sloc } +| args = separated_list(COMMA, ident) LEFTARROW CALL_M_RULES LPAREN dom = ident_list RPAREN NEWLINE + { Expr(CallRules(dom, args), mk_position $sloc), mk_position $sloc } +| args = separated_list(COMMA, ident) LEFTARROW CALL_M_CHAIN LPAREN chain = ident RPAREN NEWLINE + { Expr(CallChain(chain :: args), mk_position $sloc), mk_position $sloc } +| args = separated_list(COMMA, ident) LEFTARROW CALL_M_VERIFS LPAREN dom = ident_list RPAREN NEWLINE + { Expr(CallVerifs(dom, args), mk_position $sloc), mk_position $sloc } +| args = separated_list(COMMA, ident) LEFTARROW var = ident LPAREN RPAREN NEWLINE + { Expr(Call(var, args), mk_position $sloc), mk_position $sloc } +| args = separated_list(COMMA, ident) LEFTARROW var = ident LPAREN chain = ident RPAREN NEWLINE + { Expr(Call(var, chain :: args), mk_position $sloc), mk_position $sloc } | var = IDENT EQ e = expr NEWLINE { Assign(var, e), mk_position $sloc } | DELETE var = IDENT NEWLINE { Delete var, mk_position $sloc } +| CALL_M_RULES LPAREN dom_args = domain_args RPAREN NEWLINE + { Expr(CallRules(fst dom_args, snd dom_args), mk_position $sloc), mk_position $sloc } +| CALL_M_CHAIN LPAREN args = separated_list(COMMA, ident) RPAREN NEWLINE + { Expr(CallChain(args), mk_position $sloc), mk_position $sloc } +| CALL_M_VERIFS LPAREN dom_args = domain_args RPAREN NEWLINE + { Expr(CallVerifs(fst dom_args, snd dom_args), mk_position $sloc), mk_position $sloc } | var = ident LPAREN args = separated_list(COMMA, ident) RPAREN NEWLINE - { Expr(Call(var, args), mk_position $sloc), mk_position $sloc } + { Expr(Call(var, args), mk_position $sloc), mk_position $sloc } | IF b = expr COLON t = new_block ELSE COLON f = new_block { Conditional(b, t, f), mk_position $sloc } | IF b = expr COLON t = new_block { Conditional(b, t, []), mk_position $sloc } | PARTITION var = IDENT COLON b = new_block { Partition(var, b), mk_position $sloc } @@ -67,6 +90,6 @@ expr: | var = IDENT { Variable var, mk_position $sloc } | MINUS e = expr { Unop(Minus, e), mk_position $sloc } | var = ident LPAREN args = separated_list(COMMA, ident) RPAREN - { Call(var, args), mk_position $sloc } + { Call(var, args), mk_position $sloc } | e1 = expr b = binop e2 = expr { Binop(e1, b, e2), mk_position $sloc } ; diff --git a/src/mlang/mpp_ir/mpp_format.ml b/src/mlang/mpp_ir/mpp_format.ml index c65900db7..bb173c540 100644 --- a/src/mlang/mpp_ir/mpp_format.ml +++ b/src/mlang/mpp_ir/mpp_format.ml @@ -32,10 +32,10 @@ let format_var_filter (fmt : formatter) (f : var_filter) : unit = let format_callable (fmt : formatter) (f : mpp_callable) = fprintf fmt "%s" (match f with - | Program chain -> - Format.asprintf "evaluate_program(%a)" (Mast.DomainId.pp ()) chain - | Verif (chain, filter) -> - Format.asprintf "verification(%a%a)" (Mast.DomainId.pp ()) chain + | Rules dom -> Format.asprintf "rules(%a)" (Mast.DomainId.pp ()) dom + | Chain chain -> Format.asprintf "chain(%s)" chain + | Verifs (dom, filter) -> + Format.asprintf "verifications(%a%a)" (Mast.DomainId.pp ()) dom (pp_print_option format_var_filter) filter | MppFunction m -> m diff --git a/src/mlang/mpp_ir/mpp_ir.ml b/src/mlang/mpp_ir/mpp_ir.ml index e7e598013..22e1bc985 100644 --- a/src/mlang/mpp_ir/mpp_ir.ml +++ b/src/mlang/mpp_ir/mpp_ir.ml @@ -33,8 +33,9 @@ type mpp_compute_name = string type var_filter = Saisie of string option | Calculee of string option type mpp_callable = - | Program of Mast.DomainId.t (* M codebase *) - | Verif of Mast.DomainId.t * var_filter option (* M codebase *) + | Rules of Mast.DomainId.t (* M codebase *) + | Chain of Mast.chaining (* M codebase *) + | Verifs of Mast.DomainId.t * var_filter option (* M codebase *) | MppFunction of mpp_compute_name | Present | Abs diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml index 5f2dfe182..c4c32fac8 100644 --- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml +++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml @@ -401,38 +401,38 @@ and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list) real_args ), pos ); ] ) - | Mpp_ir.Expr (Call (Program chain, _args), _) -> - let order, ctx = - let order, used_rule_domains, used_chainings = - match Mast.DomainIdMap.find_opt chain m_program.domains_orders with - | Some order -> - ( order, - Mast.DomainIdSet.add chain ctx.used_rule_domains, - ctx.used_chainings ) - | None -> - if Mast.DomainId.cardinal chain = 1 then - let chain_id = Mast.DomainId.min_elt chain in - match - Mast.ChainingMap.find_opt chain_id m_program.chainings_orders - with - | Some order -> - ( order, - ctx.used_rule_domains, - Mast.ChainingSet.add chain_id ctx.used_chainings ) - | None -> - Errors.raise_error - (Format.asprintf "Unknown chaining: %s" chain_id) - else - Errors.raise_error - (Format.asprintf "Unknown rule domain: %a" - (Mast.DomainId.pp ()) chain) - in - (order, { ctx with used_rule_domains; used_chainings }) + | Mpp_ir.Expr (Call (Rules dom, _args), _) -> + let order = + match Mast.DomainIdMap.find_opt dom m_program.domains_orders with + | Some order -> order + | None -> + Errors.raise_error + (Format.asprintf "Unknown rule domain: %a" (Mast.DomainId.pp ()) + dom) + in + let ctx = + { + ctx with + used_rule_domains = Mast.DomainIdSet.add dom ctx.used_rule_domains; + } + in + wrap_m_code_call m_program order ctx + | Mpp_ir.Expr (Call (Chain chain, _args), _) -> + let order = + match Mast.ChainingMap.find_opt chain m_program.chainings_orders with + | Some order -> order + | None -> + Errors.raise_error (Format.sprintf "Unknown chaining: %s" chain) + in + let ctx = + { + ctx with + used_chainings = Mast.ChainingSet.add chain ctx.used_chainings; + } in wrap_m_code_call m_program order ctx - | Mpp_ir.Expr (Call (Verif (chain, filter), _args), _) -> - ( { ctx with verif_seen = true }, - generate_verif_call m_program chain filter ) + | Mpp_ir.Expr (Call (Verifs (dom, filter), _args), _) -> + ({ ctx with verif_seen = true }, generate_verif_call m_program dom filter) | Mpp_ir.Partition (filter, body) -> let func_of_filter = match filter with Mpp_ir.VarIsTaxBenefit -> var_is_ "avfisc" From e4c19b92ee0a29380e2230bcb94851444c12246b Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 6 Jul 2023 13:17:02 +0200 Subject: [PATCH 13/26] Correction des fichiers .mpp. --- mpp_specs/2018_6_7.mpp | 8 ++++---- mpp_specs/2019_8_0.mpp | 8 ++++---- mpp_specs/2020_6_5.mpp | 6 +++--- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/mpp_specs/2018_6_7.mpp b/mpp_specs/2018_6_7.mpp index 43eec9d61..436642665 100644 --- a/mpp_specs/2018_6_7.mpp +++ b/mpp_specs/2018_6_7.mpp @@ -9,7 +9,7 @@ compute_benefits(): V_INDTEO = 1 V_CALCUL_NAPS = 1 partition with var_is_taxbenefit: - IAD11, INE, IRE <- call_m(primitif) + IAD11, INE, IRE <- call_m_rules(primitive) V_CALCUL_NAPS = 0 iad11 = cast(IAD11) ire = cast(IRE) @@ -41,9 +41,9 @@ compute_double_liquidation3(outputs): 8ZG = v_8ZG V_ACO_MTAP = 0 V_NEGACO = 0 - outputs <- call_m(isf) - outputs <- call_m(primitif) - outputs <- call_m(taux) + outputs <- call_m_rules(isf) + outputs <- call_m_rules(primitive) + outputs <- call_m_rules(taux) compute_double_liquidation_exit_taxe(outputs): annee = 2018 # FIXME diff --git a/mpp_specs/2019_8_0.mpp b/mpp_specs/2019_8_0.mpp index ded541d7f..b3020f08a 100644 --- a/mpp_specs/2019_8_0.mpp +++ b/mpp_specs/2019_8_0.mpp @@ -9,7 +9,7 @@ compute_benefits(): partition with var_is_taxbenefit: V_INDTEO = 1 V_CALCUL_NAPS = 1 - IAD11, INE, IRE <- call_m(primitif) + IAD11, INE, IRE <- call_m_rules(primitive) V_CALCUL_NAPS = 0 iad11 = cast(IAD11) ire = cast(IRE) @@ -41,9 +41,9 @@ compute_double_liquidation3(outputs): 8ZG = v_8ZG V_ACO_MTAP = 0 V_NEGACO = 0 - outputs <- call_m(isf) - outputs <- call_m(primitif) - outputs <- call_m(taux) + outputs <- call_m_rules(isf) + outputs <- call_m_rules(primitive) + outputs <- call_m_rules(taux) compute_double_liquidation_exit_taxe(outputs): annee = 2018 # FIXME diff --git a/mpp_specs/2020_6_5.mpp b/mpp_specs/2020_6_5.mpp index e98faa263..e84cc83d8 100644 --- a/mpp_specs/2020_6_5.mpp +++ b/mpp_specs/2020_6_5.mpp @@ -5,13 +5,13 @@ compute_article1731bis(): PREM8_11 = 1 calcul_primitif_isf(outputs): - outputs <- call_m(isf) + outputs <- call_m_rules(isf) calcul_primitif(outputs): - outputs <- call_m(primitif) + outputs <- call_m_rules(primitive) calcul_primitif_taux(outputs): - outputs <- call_m(taux) + outputs <- call_m_rules(taux) compute_benefits(): if exists_deposit_defined_variables() or exists_taxbenefit_ceiled_variables(): From c1afc0c45ec33755a0ce3f155c6be335dfe0965e Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 11 Jul 2023 17:04:41 +0200 Subject: [PATCH 14/26] =?UTF-8?q?Lecture=20des=20cat=C3=A9gories=20de=20va?= =?UTF-8?q?riables=20autoris=C3=A9es=20dans=20les=20domaines=20de=20v?= =?UTF-8?q?=C3=A9rifs.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/backend_ir/bir_interface.ml | 19 ++- src/mlang/dgfip_m.ml | 41 ++++--- src/mlang/driver.ml | 32 ++--- src/mlang/m_frontend/format_mast.ml | 15 ++- src/mlang/m_frontend/mast.ml | 10 +- src/mlang/m_frontend/mast_to_mir.ml | 165 +++++++++++++++++++++++--- src/mlang/m_frontend/mast_to_mir.mli | 1 + src/mlang/m_frontend/mlexer.mll | 6 + src/mlang/m_frontend/mparser.mly | 60 +++++++--- src/mlang/m_ir/mir.ml | 74 +++++++++++- src/mlang/m_ir/mir.mli | 15 ++- 11 files changed, 362 insertions(+), 76 deletions(-) diff --git a/src/mlang/backend_ir/bir_interface.ml b/src/mlang/backend_ir/bir_interface.ml index a6d8aa5d0..289c1eaa2 100644 --- a/src/mlang/backend_ir/bir_interface.ml +++ b/src/mlang/backend_ir/bir_interface.ml @@ -87,6 +87,19 @@ let const_var_set_from_list (p : Bir.program) acc) Bir.VariableMap.empty names +let simple_variable_categories = + let attrs = (StrMap.empty, Pos.no_pos) in + Mir.CatVarMap.empty + |> Mir.CatVarMap.add (Mir.CatComputed Mir.CatCompSet.empty) attrs + |> Mir.CatVarMap.add (Mir.CatComputed (Mir.CatCompSet.singleton Base)) attrs + |> Mir.CatVarMap.add + (Mir.CatComputed (Mir.CatCompSet.singleton GivenBack)) + attrs + |> Mir.CatVarMap.add + (Mir.CatComputed + (Mir.CatCompSet.singleton Base |> Mir.CatCompSet.add GivenBack)) + attrs + let translate_external_conditions idmap (conds : Mast.expression Pos.marked list) : Bir.condition_data Bir.VariableMap.t = @@ -150,15 +163,15 @@ let translate_external_conditions idmap dom_names = [ ([], Pos.no_pos) ]; dom_parents = []; dom_by_default = true; - dom_data = { vdom_auto_cc = false }; + dom_data = { vdom_auth = [ AuthAll ]; vdom_auto_cc = false }; }; ] in let _, conds = (* Leave a constant map empty is risky, it will fail if we allow tests to refer to M constants in their expressions *) - Mast_to_mir.get_conds [ test_error ] Mast_to_mir.ConstMap.empty idmap - [ program ] + Mast_to_mir.get_conds simple_variable_categories [ test_error ] + Mast_to_mir.ConstMap.empty idmap [ program ] in Mir.VariableMap.fold (fun v data acc -> diff --git a/src/mlang/dgfip_m.ml b/src/mlang/dgfip_m.ml index 7a15982dc..5c3f2de6b 100644 --- a/src/mlang/dgfip_m.ml +++ b/src/mlang/dgfip_m.ml @@ -183,39 +183,38 @@ domaine regle corrective base_inr_r9901 let verif_domains_declaration = {| domaine verif primitive corrective, isf corrective -#: autorise -# calculee *, -# saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, -# saisie variation +: autorise + calculee *, + saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, + saisie variation #: auto_cc contexte, famille, revenu, revenu corrective, variation : par_defaut; domaine verif primitive -#: autorise -# calculee *, -# saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, -# saisie variation +: autorise + calculee *, + saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, + saisie variation : specialise primitive corrective; domaine verif isf -#: autorise -# calculee *, -# saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, -# saisie variation -; +: autorise + calculee *, + saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, + saisie variation; domaine verif corrective -#: autorise -# calculee *, -# saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, -# saisie variation +: autorise + calculee *, + saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, + saisie variation : specialise primitive corrective; domaine verif corrective horizontale -#: autorise -# calculee *, -# saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, -# saisie variation, saisie penalite +: autorise + calculee *, + saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, + saisie variation, saisie penalite #: auto_cc penalite ; |} diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index e22dad74f..5d9cc0e33 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -135,21 +135,23 @@ let driver (files : string list) (without_dgfip_m : bool) (debug : bool) Cli.debug_print "Reading M files..."; let current_progress, finish = Cli.create_progress_bar "Parsing" in let m_program = - ref - (let filebuf = Lexing.from_string Dgfip_m.declarations in - current_progress "internal DGFiP M"; - let filebuf = - { - filebuf with - lex_curr_p = - { filebuf.lex_curr_p with pos_fname = "internal DGFiP M" }; - } - in - try - let commands = Mparser.source_file token filebuf in - [ commands ] - with Mparser.Error -> - Errors.raise_error "M syntax error in internal DGFiP M") + if without_dgfip_m then ref [] + else + ref + (let filebuf = Lexing.from_string Dgfip_m.declarations in + current_progress "internal DGFiP M"; + let filebuf = + { + filebuf with + lex_curr_p = + { filebuf.lex_curr_p with pos_fname = "internal DGFiP M" }; + } + in + try + let commands = Mparser.source_file token filebuf in + [ commands ] + with Mparser.Error -> + Errors.raise_error "M\n syntax error in internal DGFiP M") in if List.length !Cli.source_files = 0 then Errors.raise_error "please provide at least one M source file"; diff --git a/src/mlang/m_frontend/format_mast.ml b/src/mlang/m_frontend/format_mast.ml index 5ad869a3a..be2a13b99 100644 --- a/src/mlang/m_frontend/format_mast.ml +++ b/src/mlang/m_frontend/format_mast.ml @@ -309,8 +309,21 @@ let format_rule_domain fmt (rd : rule_domain_decl) = format_domain pp_data fmt rd let format_verif_domain fmt (vd : verif_domain_decl) = + let pp_auth fmt = function + | AuthInput l -> + Format.fprintf fmt "saisie %a" + (pp_unmark (pp_print_list_space (pp_unmark Format.pp_print_string))) + l + | AuthComputed l -> + Format.fprintf fmt "calculee %a" + (pp_unmark (pp_print_list_space (pp_unmark Format.pp_print_string))) + l + | AuthAll -> Format.fprintf fmt "*" + in let pp_data fmt data = - Format.fprintf fmt "%a" + Format.fprintf fmt "%a%a" + (pp_print_list_comma pp_auth) + data.vdom_auth (format_domain_attribute "auto_cc") data.vdom_auto_cc in diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index ee3e847a9..a1563d404 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -291,7 +291,15 @@ type verification = { verif_conditions : verification_condition Pos.marked list; } -type verif_domain_data = { vdom_auto_cc : bool } +type verif_auth_decl = + | AuthInput of string Pos.marked list Pos.marked + | AuthComputed of string Pos.marked list Pos.marked + | AuthAll + +type verif_domain_data = { + vdom_auth : verif_auth_decl list; + vdom_auto_cc : bool; +} type verif_domain_decl = verif_domain_data domain_decl diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index d75e8082c..d2951e85a 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -516,6 +516,56 @@ let get_var_categories (p : Mast.program) = in categories +let get_var_category_map (p : Mast.program) : + Pos.t StrMap.t Pos.marked Mir.CatVarMap.t = + List.fold_left + (fun cats source_file -> + List.fold_left + (fun cats source_file_item -> + match Pos.unmark source_file_item with + | Mast.VarCatDecl (catDecl, posDecl) -> ( + let attributes = + List.fold_left + (fun res (str, pos) -> + match StrMap.find_opt str res with + | None -> StrMap.add str pos res + | Some posAttr -> + Errors.raise_spanned_error + (Format.asprintf + "attribute \"%s\" defined more than once:@;\ + Already defined %a" str Pos.format_position + posAttr) + pos) + StrMap.empty catDecl.var_attributes + in + let add_cat cat cats = + match Mir.CatVarMap.find_opt cat cats with + | None -> Mir.CatVarMap.add cat (attributes, posDecl) cats + | Some (_, pos) -> + Errors.raise_spanned_error + (Format.asprintf + "Category \"%a\" defined more than once:@;\ + Already defined %a" Mir.pp_cat_variable cat + Pos.format_position pos) + posDecl + in + match catDecl.var_type with + | Mast.Input -> + let id = StrSet.from_marked_list catDecl.var_category in + add_cat (Mir.CatInput id) cats + | Mast.Computed -> + let base = Mir.CatCompSet.singleton Base in + let givenBack = Mir.CatCompSet.singleton GivenBack in + let baseAndGivenBack = base |> Mir.CatCompSet.add GivenBack in + cats + |> add_cat (Mir.CatComputed Mir.CatCompSet.empty) + |> add_cat (Mir.CatComputed base) + |> add_cat (Mir.CatComputed givenBack) + |> add_cat (Mir.CatComputed baseAndGivenBack)) + | _ -> cats) + cats source_file) + Mir.CatVarMap.empty p + let check_var_category (categories : Mast.var_category_decl Pos.marked list) (var : Mast.variable_decl) = let rec category_included_in cbase ctest = @@ -1494,10 +1544,85 @@ let get_rule_chains (domains : Mir.rule_domain Mast.DomainIdMap.t) let fold_sources chains source = List.fold_left fold_rules chains source in List.fold_left fold_sources Mast.ChainingMap.empty p -let get_verif_domains (p : Mast.program) : Mir.verif_domain Mast.DomainIdMap.t = +let cats_variable_from_decl_list cats l = + let rec aux res = function + | [] -> res + | Mast.AuthInput id :: t -> + let vcat = Mir.CatInput (StrSet.from_marked_list (Pos.unmark id)) in + aux (Mir.CatVarSet.add vcat res) t + | Mast.AuthComputed id :: t -> begin + match Pos.unmark id with + | [ ("base", _) ] -> + let base = Mir.CatCompSet.singleton Mir.Base in + let res = res |> Mir.CatVarSet.add (Mir.CatComputed base) in + aux res t + | [ ("base", _); ("*", _) ] -> + let base = Mir.CatCompSet.singleton Base in + let baseAndGivenBack = base |> Mir.CatCompSet.add GivenBack in + let res = + res + |> Mir.CatVarSet.add (Mir.CatComputed base) + |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) + in + aux res t + | [ ("restituee", _) ] -> + let givenBack = Mir.CatCompSet.singleton GivenBack in + let res = Mir.CatVarSet.add (Mir.CatComputed givenBack) res in + aux res t + | [ ("restituee", _); ("*", _) ] -> + let givenBack = Mir.CatCompSet.singleton GivenBack in + let baseAndGivenBack = givenBack |> Mir.CatCompSet.add Base in + let res = + res + |> Mir.CatVarSet.add (Mir.CatComputed givenBack) + |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) + in + aux res t + | [ ("base", _); ("restituee", _) ] | [ ("restituee", _); ("base", _) ] + -> + let baseAndGivenBack = + Mir.CatCompSet.singleton Base |> Mir.CatCompSet.add GivenBack + in + let res = + res |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) + in + aux res t + | [ ("*", _) ] -> + let base = Mir.CatCompSet.singleton Base in + let givenBack = Mir.CatCompSet.singleton GivenBack in + let baseAndGivenBack = base |> Mir.CatCompSet.add GivenBack in + let res = + res + |> Mir.CatVarSet.add (Mir.CatComputed base) + |> Mir.CatVarSet.add (Mir.CatComputed givenBack) + |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) + in + aux res t + | _ -> + Errors.raise_spanned_error "unlnown calculated variable category" + (Pos.get_position id) + end + | Mast.AuthAll :: t -> + let res = + Mir.CatVarMap.fold (fun c _ r -> Mir.CatVarSet.add c r) cats res + in + aux res t + in + aux Mir.CatVarSet.empty l + +let get_verif_domains (cats : 'a Mir.CatVarMap.t) (p : Mast.program) : + Mir.verif_domain Mast.DomainIdMap.t = let get_item = function | Mast.VerifDomDecl decl -> - let dom_data = { Mir.vdom_auto_cc = decl.Mast.dom_data.vdom_auto_cc } in + let catSet = + cats_variable_from_decl_list cats decl.Mast.dom_data.vdom_auth + in + let dom_data = + { + Mir.vdom_auth = catSet; + Mir.vdom_auto_cc = decl.Mast.dom_data.vdom_auto_cc; + } + in Some (decl, dom_data) | _ -> None in @@ -1649,11 +1774,11 @@ let add_dummy_definitions_for_variable_declarations var_data) var_decl_data var_data -let get_conds (error_decls : Mir.Error.t list) +let get_conds (cats : 'a Mir.CatVarMap.t) (error_decls : Mir.Error.t list) (const_map : float Pos.marked ConstMap.t) (idmap : Mir.idmap) (p : Mast.program) : Mir.verif_domain Mast.DomainIdMap.t * Mir.condition_data Mir.VariableMap.t = - let verif_domains = get_verif_domains p in + let verif_domains = get_verif_domains cats p in let conds = List.fold_left (fun conds source_file -> @@ -1778,6 +1903,12 @@ let get_conds (error_decls : Mir.Error.t list) let translate (p : Mast.program) : Mir.program = let const_map = get_constants p in let var_category_decls = get_var_categories p in + let var_category_map = get_var_category_map p in + let _ = + Mir.CatVarMap.pp + (fun fmt (attrs, _) -> StrMap.pp (fun _ _ -> ()) fmt attrs) + Format.std_formatter var_category_map + in let var_decl_data, error_decls, idmap = get_variables_decl p var_category_decls const_map in @@ -1851,14 +1982,18 @@ let translate (p : Mast.program) : Mir.program = } rules in - let verif_domains, conds = get_conds error_decls const_map idmap p in - { - Mir.program_rule_domains = rule_domains; - Mir.program_verif_domains = verif_domains; - Mir.program_chainings = rule_chains; - Mir.program_vars = var_data; - Mir.program_rules = rules; - Mir.program_conds = conds; - Mir.program_idmap = idmap; - Mir.program_exec_passes = []; - } + let verif_domains, conds = + get_conds var_category_map error_decls const_map idmap p + in + Mir. + { + program_var_categories = var_category_map; + program_rule_domains = rule_domains; + program_verif_domains = verif_domains; + program_chainings = rule_chains; + program_vars = var_data; + program_rules = rules; + program_conds = conds; + program_idmap = idmap; + program_exec_passes = []; + } diff --git a/src/mlang/m_frontend/mast_to_mir.mli b/src/mlang/m_frontend/mast_to_mir.mli index e10014d4b..1f014024c 100644 --- a/src/mlang/m_frontend/mast_to_mir.mli +++ b/src/mlang/m_frontend/mast_to_mir.mli @@ -74,6 +74,7 @@ val dummy_exec_number : Pos.t -> Mir.execution_number (** Dummy execution number used for variable declarations *) val get_conds : + 'a Mir.CatVarMap.t -> Mir.Error.t list -> float Pos.marked ConstMap.t -> Mir.idmap -> diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index af18cc685..0c14521f0 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -70,6 +70,10 @@ rule token = parse { RBRACKET } | "calculee" { COMPUTED } +| "base" + { BASE } +| "restituee" + { GIVEN_BACK } | "const" { CONST } | "alias" @@ -112,6 +116,8 @@ rule token = parse { DOMAIN } | "specialise" { SPECIALIZE } +| "autorise" + { AUTHORIZE } | "calculable" { COMPUTABLE } | "par_defaut" diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 493a99eca..c7760595d 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -49,7 +49,7 @@ along with this program. If not, see . %token COMPUTED CONST ALIAS INPUT FOR %token RULE IF THEN ELSE ENDIF ERROR VERIFICATION ANOMALY DISCORDANCE CONDITION %token INFORMATIVE OUTPUT FONCTION VARIABLE ATTRIBUT -%token DOMAIN SPECIALIZE COMPUTABLE BY_DEFAULT AUTO_CC NON_AUTO_CC +%token DOMAIN SPECIALIZE AUTHORIZE BASE GIVEN_BACK COMPUTABLE BY_DEFAULT AUTO_CC NON_AUTO_CC %token EOF @@ -156,23 +156,26 @@ verif_domain_decl: | DOMAIN VERIFICATION vdom_params = separated_nonempty_list(COLON, vdom_param_with_pos) SEMICOLON { let err msg pos = Errors.raise_spanned_error msg pos in - let fold (dno, dso, dao, dpdo) = function - | Some dn, _, _, _, pos -> - if dno = None then Some dn, dso, dao, dpdo + let fold (dno, dso, dvo, dao, dpdo) = function + | Some dn, _, _, _, _, pos -> + if dno = None then Some dn, dso, dvo, dao, dpdo else err "verif domain names are already defined" pos - | _, Some ds, _, _, pos -> - if dso = None then dno, Some ds, dao, dpdo + | _, Some ds, _, _, _, pos -> + if dso = None then dno, Some ds, dvo, dao, dpdo else err "verif domain specialization is already specified" pos - | _, _, Some da, _, pos -> - if dao = None then dno, dso, Some da, dpdo + | _, _, Some dv, _, _, pos -> + if dvo = None then dno, dso, Some dv, dao, dpdo + else err "verif domain authorization is already specified" pos + | _, _, _, Some da, _, pos -> + if dao = None then dno, dso, dvo, Some da, dpdo else err "verif domain is already auto-consistent" pos - | _, _, _, Some dpd, pos -> - if dpdo = None then dno, dso, dao, Some dpd + | _, _, _, _, Some dpd, pos -> + if dpdo = None then dno, dso, dvo, dao, Some dpd else err "verif domain is already defined by defaut" pos - | _, _, _, _, _ -> assert false + | _, _, _, _, _, _ -> assert false in - let init = None, None, None, None in - let dno, dso, dao, dpdo = List.fold_left fold init vdom_params in + let init = None, None, None, None, None in + let dno, dso, dvo, dao, dpdo = List.fold_left fold init vdom_params in let dom_names = match dno with | None -> err "rule domain names must be defined" (mk_position $sloc) @@ -182,19 +185,37 @@ verif_domain_decl: dom_names; dom_parents = (match dso with None -> [] | Some ds -> ds); dom_by_default = (match dpdo with None -> false | _ -> true); - dom_data = {vdom_auto_cc = (match dao with None -> false | _ -> true);}; + dom_data = { + vdom_auth = (match dvo with None -> [] | Some dv -> dv); + vdom_auto_cc = (match dao with None -> false | _ -> true); + }; } } +%inline var_computed_category: +| BASE { ("base", mk_position $sloc) } +| GIVEN_BACK { ("restituee", mk_position $sloc) } +| TIMES { ("*", mk_position $sloc) } + +%inline var_computed_category_list: +| l = var_computed_category* { (l, mk_position $sloc) } + +var_category_id: +| INPUT l = symbol_list_with_pos { AuthInput l } +| COMPUTED l = var_computed_category_list { AuthComputed l } +| TIMES { AuthAll } + vdom_param_with_pos: | vdom_names = separated_nonempty_list(COMMA, symbol_list_with_pos) - { (Some vdom_names, None, None, None, mk_position $sloc) } + { (Some vdom_names, None, None, None, None, mk_position $sloc) } | SPECIALIZE vdom_parents = separated_nonempty_list(COMMA, symbol_list_with_pos) - { (None, Some vdom_parents, None, None, mk_position $sloc) } + { (None, Some vdom_parents, None, None, None, mk_position $sloc) } +| AUTHORIZE vcats = separated_nonempty_list(COMMA, var_category_id) + { (None, None, Some vcats, None, None, mk_position $sloc) } | AUTO_CC - { (None, None, Some (), None, mk_position $sloc) } + { (None, None, None, Some (), None, mk_position $sloc) } | BY_DEFAULT - { (None, None, None, Some (), mk_position $sloc) } + { (None, None, None, None, Some (), mk_position $sloc) } fonction: | SYMBOL COLON FONCTION SYMBOL SEMICOLON { () } @@ -241,6 +262,8 @@ computed_variable_descr: computed_attr_or_subtyp: | attr = variable_attribute { let (x, y) = attr in Attr (x,y) } | cat = symbol_with_pos { CompSubTyp cat } +| BASE { CompSubTyp ("base", mk_position $sloc) } +| GIVEN_BACK { CompSubTyp ("restituee", mk_position $sloc) } computed_variable: | name = computed_variable_name size = computed_variable_table? COMPUTED @@ -269,6 +292,7 @@ descr = STRING { (parse_string descr, mk_position $sloc) } input_attr_or_category: | attr = variable_attribute { (None, Some attr) } | cat = symbol_with_pos { (Some cat, None) } +| GIVEN_BACK { Some ("restituee", mk_position $sloc), None } input_variable: | name = input_variable_name INPUT diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 765041755..fac1f8b28 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -58,6 +58,77 @@ let same_execution_number (en1 : execution_number) (en2 : execution_number) : bool = en1.rule_number = en2.rule_number && en1.seq_number = en2.seq_number +type cat_computed = Base | GivenBack + +let pp_cat_computed fmt = function + | Base -> Format.fprintf fmt "base" + | GivenBack -> Format.fprintf fmt "restituee" + +module CatCompSet = struct + include SetExt.Make (struct + type t = cat_computed + + let compare = compare + end) + + let pp ?(sep = " ") ?(pp_elt = pp_cat_computed) (_ : unit) + (fmt : Format.formatter) (set : t) : unit = + pp ~sep ~pp_elt () fmt set +end + +type cat_variable = CatInput of StrSet.t | CatComputed of CatCompSet.t + +let pp_cat_variable fmt = function + | CatInput id -> + let pp fmt set = + let foldSet elt first = + let _ = + if first then Format.fprintf fmt "%s" elt + else Format.fprintf fmt " %s" elt + in + false + in + ignore (StrSet.fold foldSet set true) + in + Format.fprintf fmt "saisie %a" pp id + | CatComputed id -> + let pp fmt set = + let foldSet elt first = + let _ = + if first then Format.fprintf fmt "%a" pp_cat_computed elt + else Format.fprintf fmt " %a" pp_cat_computed elt + in + false + in + ignore (CatCompSet.fold foldSet set true) + in + Format.fprintf fmt "calculee %a" pp id + +module CatVarSet = struct + include SetExt.Make (struct + type t = cat_variable + + let compare = compare + end) + + let pp ?(sep = ", ") ?(pp_elt = pp_cat_variable) (_ : unit) + (fmt : Format.formatter) (set : t) : unit = + pp ~sep ~pp_elt () fmt set +end + +module CatVarMap = struct + include MapExt.Make (struct + type t = cat_variable + + let compare = compare + end) + + let pp ?(sep = "; ") ?(pp_key = pp_cat_variable) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map +end + type variable_id = int (** Each variable has an unique ID *) @@ -451,7 +522,7 @@ module Error = struct let compare (var1 : t) (var2 : t) = compare var1.id var2.id end -type verif_domain_data = { vdom_auto_cc : bool } +type verif_domain_data = { vdom_auth : CatVarSet.t; vdom_auto_cc : bool } type verif_domain = verif_domain_data domain @@ -484,6 +555,7 @@ type idmap = Variable.t list Pos.VarNameToID.t type exec_pass = { exec_pass_set_variables : literal Pos.marked VariableMap.t } type program = { + program_var_categories : Pos.t StrMap.t Pos.marked CatVarMap.t; program_rule_domains : rule_domain Mast.DomainIdMap.t; program_verif_domains : verif_domain Mast.DomainIdMap.t; program_chainings : rule_domain Mast.ChainingMap.t; diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index f1af7cdba..53ce64416 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -21,6 +21,18 @@ type execution_number = { pos : Pos.t; } +type cat_computed = Base | GivenBack + +module CatCompSet : SetExt.T with type elt = cat_computed + +type cat_variable = CatInput of StrSet.t | CatComputed of CatCompSet.t + +val pp_cat_variable : Format.formatter -> cat_variable -> unit + +module CatVarSet : SetExt.T with type elt = cat_variable + +module CatVarMap : MapExt.T with type key = cat_variable + type variable_id = int (** Each variable has an unique ID *) @@ -176,7 +188,7 @@ type error = { typ : Mast.error_typ; } -type verif_domain_data = { vdom_auto_cc : bool } +type verif_domain_data = { vdom_auth : CatVarSet.t; vdom_auto_cc : bool } type verif_domain = verif_domain_data domain @@ -197,6 +209,7 @@ type idmap = variable list Pos.VarNameToID.t type exec_pass = { exec_pass_set_variables : literal Pos.marked VariableMap.t } type program = { + program_var_categories : Pos.t StrMap.t Pos.marked CatVarMap.t; program_rule_domains : rule_domain Mast.DomainIdMap.t; program_verif_domains : verif_domain Mast.DomainIdMap.t; program_chainings : rule_domain Mast.ChainingMap.t; From 5848fd33cb47bee6f0d54ef86f3ed998a6e4a23d Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 18 Jul 2023 18:51:07 +0200 Subject: [PATCH 15/26] =?UTF-8?q?R=C3=A9=C3=A9criture=20des=20filtres=20de?= =?UTF-8?q?=20v=C3=A9rifs=20avec=20des=20domaines.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../backend_compilers/dgfip_gen_files.ml | 12 +-- src/mlang/backend_ir/bir_interface.ml | 22 ++---- src/mlang/backend_ir/bir_interface.mli | 1 + src/mlang/m_frontend/mast.ml | 2 + src/mlang/m_frontend/mast_to_mir.ml | 73 +++++++++++++++--- src/mlang/m_frontend/mparser.mly | 33 ++++---- src/mlang/m_ir/mir.ml | 25 +++++-- src/mlang/m_ir/mir.mli | 6 ++ src/mlang/mpp_frontend/mpp_frontend.ml | 75 ++++++++++++++++++- src/mlang/mpp_ir/mpp_format.ml | 15 ++-- src/mlang/mpp_ir/mpp_ir.ml | 4 +- src/mlang/mpp_ir/mpp_ir_to_bir.ml | 65 +++++++++++----- src/mlang/test_framework/test_interpreter.ml | 3 +- 13 files changed, 248 insertions(+), 88 deletions(-) diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index fad928f8d..cbc5c5638 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -149,15 +149,9 @@ let computed_var_subtype cv : var_subtype = in if is_base then Base else Computed -let computed_var_is_output cv = - List.exists - (fun st -> String.equal (Pos.unmark st) Mast.givenback_category) - cv.Mast.comp_category - -let input_var_is_output iv = - List.exists - (fun st -> String.equal (Pos.unmark st) Mast.givenback_category) - iv.Mast.input_category +let computed_var_is_output cv = cv.Mast.comp_is_givenback + +let input_var_is_output iv = iv.Mast.input_is_givenback let consider_output is_ebcdic attribs = is_ebcdic = false diff --git a/src/mlang/backend_ir/bir_interface.ml b/src/mlang/backend_ir/bir_interface.ml index 289c1eaa2..14d12ca04 100644 --- a/src/mlang/backend_ir/bir_interface.ml +++ b/src/mlang/backend_ir/bir_interface.ml @@ -87,20 +87,7 @@ let const_var_set_from_list (p : Bir.program) acc) Bir.VariableMap.empty names -let simple_variable_categories = - let attrs = (StrMap.empty, Pos.no_pos) in - Mir.CatVarMap.empty - |> Mir.CatVarMap.add (Mir.CatComputed Mir.CatCompSet.empty) attrs - |> Mir.CatVarMap.add (Mir.CatComputed (Mir.CatCompSet.singleton Base)) attrs - |> Mir.CatVarMap.add - (Mir.CatComputed (Mir.CatCompSet.singleton GivenBack)) - attrs - |> Mir.CatVarMap.add - (Mir.CatComputed - (Mir.CatCompSet.singleton Base |> Mir.CatCompSet.add GivenBack)) - attrs - -let translate_external_conditions idmap +let translate_external_conditions var_cats idmap (conds : Mast.expression Pos.marked list) : Bir.condition_data Bir.VariableMap.t = let check_boolean (mexpr : Mast.expression Pos.marked) = @@ -170,8 +157,8 @@ let translate_external_conditions idmap let _, conds = (* Leave a constant map empty is risky, it will fail if we allow tests to refer to M constants in their expressions *) - Mast_to_mir.get_conds simple_variable_categories [ test_error ] - Mast_to_mir.ConstMap.empty idmap [ program ] + Mast_to_mir.get_conds var_cats [ test_error ] Mast_to_mir.ConstMap.empty + idmap [ program ] in Mir.VariableMap.fold (fun v data acc -> @@ -243,7 +230,8 @@ let read_function_from_spec (p : Bir.program) (spec_file : string) : func_outputs = var_set_from_variable_name_list p func_spec.Mast.spec_outputs; func_conds = - translate_external_conditions p.idmap func_spec.Mast.spec_conditions; + translate_external_conditions p.mir_program.program_var_categories + p.idmap func_spec.Mast.spec_conditions; } with | Errors.StructuredError e -> diff --git a/src/mlang/backend_ir/bir_interface.mli b/src/mlang/backend_ir/bir_interface.mli index 1bba70619..8507b465e 100644 --- a/src/mlang/backend_ir/bir_interface.mli +++ b/src/mlang/backend_ir/bir_interface.mli @@ -25,6 +25,7 @@ type bir_function = { (** Input-output data necessary to interpret a BIR program*) val translate_external_conditions : + Pos.t StrMap.t Pos.marked Mir.CatVarMap.t -> Mir.idmap -> Mast.expression Pos.marked list -> Bir.condition_data Bir.VariableMap.t diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index a1563d404..325b61c88 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -227,6 +227,7 @@ type input_variable = { input_category : string Pos.marked list; input_attributes : variable_attribute list; input_alias : variable_name Pos.marked; (** Unused for now *) + input_is_givenback : bool; input_description : string Pos.marked; input_typ : value_typ Pos.marked option; } @@ -238,6 +239,7 @@ type computed_variable = { comp_attributes : variable_attribute list; comp_category : string Pos.marked list; comp_typ : value_typ Pos.marked option; + comp_is_givenback : bool; comp_description : string Pos.marked; } diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index d2951e85a..662354dc3 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -721,12 +721,32 @@ let get_variables_decl (p : Mast.program) Mast.computed_category :: List.map Pos.unmark cvar.comp_category in + let cat = + let comp_set = + List.fold_left + (fun res (str, pos) -> + let elt = + match str with + | "base" -> Mir.Base + | "restituee" -> Mir.GivenBack + | _ -> + Errors.raise_spanned_error + "unknown computed category (must be \ + \"base\" or \"restituee\")" + pos + in + Mir.CatCompSet.add elt res) + Mir.CatCompSet.empty cvar.comp_category + in + Mir.CatComputed comp_set + in let new_var = Mir.Variable.new_var cvar.Mast.comp_name None cvar.Mast.comp_description (dummy_exec_number (Pos.get_position cvar.Mast.comp_name)) ~attributes:cvar.comp_attributes ~category + ~cats:(Mir.CatVarSet.singleton cat) ~origin:None ~is_table:(Pos.unmark_option cvar.Mast.comp_table) in @@ -751,13 +771,8 @@ let get_variables_decl (p : Mast.program) [ new_var ] idmap in let new_out_list = - if - List.exists - (fun x -> - String.equal (Pos.unmark x) - Mast.givenback_category) - cvar.Mast.comp_category - then cvar.Mast.comp_name :: out_list + if cvar.Mast.comp_is_givenback then + cvar.Mast.comp_name :: out_list else out_list in (new_vars, new_idmap, errors, new_out_list) @@ -767,6 +782,14 @@ let get_variables_decl (p : Mast.program) Mast.input_category :: List.map Pos.unmark ivar.input_category in + let cat = + let input_set = + List.fold_left + (fun res (str, _pos) -> StrSet.add str res) + StrSet.empty ivar.input_category + in + Mir.CatInput input_set + in let new_var = Mir.Variable.new_var ivar.Mast.input_name (Some (Pos.unmark ivar.Mast.input_alias)) @@ -774,7 +797,9 @@ let get_variables_decl (p : Mast.program) (dummy_exec_number (Pos.get_position ivar.Mast.input_name)) ~attributes:ivar.input_attributes ~origin:None - ~category ~is_table:None + ~category + ~cats:(Mir.CatVarSet.singleton cat) + ~is_table:None (* Input variables also have a low order *) in let new_var_data = @@ -939,7 +964,7 @@ let duplicate_var (var : Mir.Variable.t) (exec_number : Mir.execution_number) local variables *) in Mir.Variable.new_var var.name None var.descr exec_number - ~attributes:var.attributes ~origin ~category:var.category + ~attributes:var.attributes ~origin ~category:var.category ~cats:var.cats ~is_table:var.is_table (** Linear pass that fills [idmap] with all the variable assignments along with @@ -1552,6 +1577,11 @@ let cats_variable_from_decl_list cats l = aux (Mir.CatVarSet.add vcat res) t | Mast.AuthComputed id :: t -> begin match Pos.unmark id with + | [] -> + let res = + res |> Mir.CatVarSet.add (Mir.CatComputed Mir.CatCompSet.empty) + in + aux res t | [ ("base", _) ] -> let base = Mir.CatCompSet.singleton Mir.Base in let res = res |> Mir.CatVarSet.add (Mir.CatComputed base) in @@ -1593,6 +1623,7 @@ let cats_variable_from_decl_list cats l = let baseAndGivenBack = base |> Mir.CatCompSet.add GivenBack in let res = res + |> Mir.CatVarSet.add (Mir.CatComputed Mir.CatCompSet.empty) |> Mir.CatVarSet.add (Mir.CatComputed base) |> Mir.CatVarSet.add (Mir.CatComputed givenBack) |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) @@ -1835,6 +1866,26 @@ let get_conds (cats : 'a Mir.CatVarMap.t) (error_decls : Mir.Error.t list) subtypes var.Mir.category) [] (Pos.unmark e) in + let cond_cats = + Mir.fold_expr_var + (fun subtypes (var : Mir.variable) -> + Mir.CatVarSet.fold + (fun c res -> + if + Mir.CatVarSet.mem c + cond_domain.dom_data.vdom_auth + then Mir.CatVarSet.add c res + else + Errors.raise_error + (Format.asprintf + "forbidden variable \"%s\" of category \ + \"%a\" in verif %d of domain \"%a\"" + (Pos.unmark var.Mir.name) + Mir.pp_cat_variable c rule_number + (Mast.DomainId.pp ()) cond_domain.dom_id)) + var.Mir.cats subtypes) + Mir.CatVarSet.empty (Pos.unmark e) + in let err = let err_name, err_var = (Pos.unmark verif_cond).Mast.verif_cond_error @@ -1877,7 +1928,8 @@ let get_conds (cats : 'a Mir.CatVarMap.t) (error_decls : Mir.Error.t list) Mir.seq_number = 0; Mir.pos = Pos.get_position verif_cond; } - ~attributes:[] ~origin:None ~category ~is_table:None + ~attributes:[] ~origin:None ~category ~cats:cond_cats + ~is_table:None in ( Mir.VariableMap.add dummy_var Mir. @@ -1888,6 +1940,7 @@ let get_conds (cats : 'a Mir.CatVarMap.t) (error_decls : Mir.Error.t list) cond_domain; cond_expr = e; cond_error = err; + cond_cats; } conds, id_offset + 1 )) diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index c7760595d..9aca67692 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -276,6 +276,7 @@ computed_variable: (List.filter (fun x -> match x with Attr _ -> true | _ -> false) subtyp); comp_category = List.map (fun x -> match x with CompSubTyp x -> x | _ -> assert false (* should not happen *)) (List.filter (fun x -> match x with CompSubTyp _ -> true | _ -> false) subtyp); + comp_is_givenback = List.exists (fun x -> match x with CompSubTyp ("restituee", _) -> true | _ -> false) subtyp; comp_description = descr; comp_typ = typ; }, mk_position $sloc) } @@ -290,30 +291,32 @@ input_descr: descr = STRING { (parse_string descr, mk_position $sloc) } input_attr_or_category: -| attr = variable_attribute { (None, Some attr) } -| cat = symbol_with_pos { (Some cat, None) } -| GIVEN_BACK { Some ("restituee", mk_position $sloc), None } +| attr = variable_attribute { (None, Some attr, false) } +| cat = symbol_with_pos { (Some cat, None, false) } +| GIVEN_BACK { None, None, true } input_variable: | name = input_variable_name INPUT category_attrs = input_attr_or_category* alias = input_variable_alias COLON descr = input_descr typ = value_type? SEMICOLON { - let (category, attrs) = List.split category_attrs in + let (category, attrs, givenback) = + List.fold_left + (fun (category, attrs, givenback) (c, a, r) -> + match c, a, r with + | Some x, _, _ -> x :: category, attrs, givenback + | _, Some x, _ -> category, x :: attrs, givenback + | _, _, true -> category, attrs, true + | _, _, _ -> category, attrs, givenback) + ([], [], false) + category_attrs + in InputVar ({ input_name = name; - input_category = - List.map - (fun x -> match x with None -> assert false (* should not happen *) | Some x -> x) - (List.filter (fun x -> x <> None) category); - input_attributes = begin - let attrs = - List.map (fun x -> match x with None -> assert false (* should not happen *) | Some x -> x) - (List.filter (fun x -> x <> None) attrs) - in - attrs - end; + input_category = category; + input_attributes = attrs; input_alias = alias; + input_is_givenback = givenback; input_typ = typ; input_description = descr; }, mk_position $sloc) } diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index fac1f8b28..e4809530c 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -90,25 +90,32 @@ let pp_cat_variable fmt = function in ignore (StrSet.fold foldSet set true) in - Format.fprintf fmt "saisie %a" pp id + Format.fprintf fmt "saisie(%a)" pp id | CatComputed id -> let pp fmt set = let foldSet elt first = let _ = if first then Format.fprintf fmt "%a" pp_cat_computed elt - else Format.fprintf fmt " %a" pp_cat_computed elt + else Format.fprintf fmt ", %a" pp_cat_computed elt in false in ignore (CatCompSet.fold foldSet set true) in - Format.fprintf fmt "calculee %a" pp id + Format.fprintf fmt "calculee(%a)" pp id + +let compare_cat_variable a b = + match (a, b) with + | CatInput _, CatComputed _ -> 1 + | CatComputed _, CatInput _ -> -1 + | CatInput id0, CatInput id1 -> StrSet.compare id0 id1 + | CatComputed c0, CatComputed c1 -> CatCompSet.compare c0 c1 module CatVarSet = struct include SetExt.Make (struct type t = cat_variable - let compare = compare + let compare = compare_cat_variable end) let pp ?(sep = ", ") ?(pp_elt = pp_cat_variable) (_ : unit) @@ -120,7 +127,7 @@ module CatVarMap = struct include MapExt.Make (struct type t = cat_variable - let compare = compare + let compare = compare_cat_variable end) let pp ?(sep = "; ") ?(pp_key = pp_cat_variable) ?(assoc = " => ") @@ -146,6 +153,7 @@ type variable = { (** If the variable is an SSA duplication, refers to the original (declared) variable *) category : string list; + cats : CatVarSet.t; is_table : int option; } @@ -166,6 +174,7 @@ module Variable = struct (** If the variable is an SSA duplication, refers to the original (declared) variable *) category : string list; + cats : CatVarSet.t; is_table : int option; } @@ -179,7 +188,8 @@ module Variable = struct let new_var (name : string Pos.marked) (alias : string option) (descr : string Pos.marked) (execution_number : execution_number) ~(attributes : Mast.variable_attribute list) ~(origin : t option) - ~(category : string list) ~(is_table : int option) : t = + ~(category : string list) ~(cats : CatVarSet.t) ~(is_table : int option) : + t = { name; id = fresh_id (); @@ -189,6 +199,7 @@ module Variable = struct attributes; origin; category; + cats; is_table; } @@ -531,6 +542,7 @@ type 'variable condition_data_ = { cond_domain : verif_domain; cond_expr : 'variable expression_ Pos.marked; cond_error : (Error.t[@opaque]) * 'variable option; + cond_cats : CatVarSet.t; } let map_cond_data_var (f : 'v -> 'v2) (cond : 'v condition_data_) : @@ -542,6 +554,7 @@ let map_cond_data_var (f : 'v -> 'v2) (cond : 'v condition_data_) : cond_error = (let e, v = cond.cond_error in (e, Option.map f v)); + cond_cats = cond.cond_cats; } type condition_data = variable condition_data_ diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 53ce64416..90b1d5409 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -29,6 +29,8 @@ type cat_variable = CatInput of StrSet.t | CatComputed of CatCompSet.t val pp_cat_variable : Format.formatter -> cat_variable -> unit +val compare_cat_variable : cat_variable -> cat_variable -> int + module CatVarSet : SetExt.T with type elt = cat_variable module CatVarMap : MapExt.T with type key = cat_variable @@ -50,6 +52,7 @@ type variable = { (** If the variable is an SSA duplication, refers to the original (declared) variable *) category : string list; + cats : CatVarSet.t; is_table : int option; } @@ -197,6 +200,7 @@ type 'variable condition_data_ = { cond_domain : verif_domain; cond_expr : 'variable expression_ Pos.marked; cond_error : error * 'variable option; + cond_cats : CatVarSet.t; } type condition_data = variable condition_data_ @@ -243,6 +247,7 @@ module Variable : sig (** If the variable is an SSA duplication, refers to the original (declared) variable *) category : string list; + cats : CatVarSet.t; is_table : int option; } @@ -256,6 +261,7 @@ module Variable : sig attributes:Mast.variable_attribute list -> origin:variable option -> category:string list -> + cats:CatVarSet.t -> is_table:int option -> variable diff --git a/src/mlang/mpp_frontend/mpp_frontend.ml b/src/mlang/mpp_frontend/mpp_frontend.ml index 05378e037..d60935340 100644 --- a/src/mlang/mpp_frontend/mpp_frontend.ml +++ b/src/mlang/mpp_frontend/mpp_frontend.ml @@ -35,6 +35,70 @@ let filter_of_string (s : string Pos.marked) : var_filter = (Format.sprintf "unknown variable category %s" unknown) (Pos.get_position s) +let filter2_of_string (cats : Mir.CatVarSet.t) (s : string Pos.marked) : + Mir.CatVarSet.t * Mir.CatVarSet.t = + let us = Pos.unmark s in + match us with + | "saisie" -> + let incl = + Mir.CatVarSet.fold + (fun cv res -> + match cv with + | Mir.CatInput _ -> Mir.CatVarSet.add cv res + | _ -> res) + cats Mir.CatVarSet.empty + in + let excl = + Mir.CatVarSet.fold + (fun cv res -> + match cv with + | Mir.CatComputed _ -> Mir.CatVarSet.add cv res + | _ -> res) + cats Mir.CatVarSet.empty + in + (incl, excl) + | "calculee" -> + let incl = + Mir.CatVarSet.fold + (fun cv res -> + match cv with + | Mir.CatComputed _ -> Mir.CatVarSet.add cv res + | _ -> res) + cats Mir.CatVarSet.empty + in + (incl, Mir.CatVarSet.empty) + | "contexte" | "famille" | "revenu" | "penalite" -> + let incl = Mir.CatVarSet.singleton (Mir.CatInput (StrSet.singleton us)) in + let excl = + Mir.CatVarSet.fold + (fun cv res -> + match cv with + | Mir.CatComputed _ -> Mir.CatVarSet.add cv res + | _ -> res) + cats Mir.CatVarSet.empty + in + (incl, excl) + | "base" -> + let base = Mir.CatCompSet.singleton Mir.Base in + let baseAndGivenBack = Mir.CatCompSet.add Mir.GivenBack base in + let incl = + Mir.CatVarSet.singleton (Mir.CatComputed base) + |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) + in + (incl, Mir.CatVarSet.empty) + | "restituee" -> + let givenBack = Mir.CatCompSet.singleton Mir.GivenBack in + let baseAndGivenBack = Mir.CatCompSet.add Mir.Base givenBack in + let incl = + Mir.CatVarSet.singleton (Mir.CatComputed givenBack) + |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) + in + (incl, Mir.CatVarSet.empty) + | unknown -> + Errors.raise_spanned_error + (Format.sprintf "unknown variable category %s" unknown) + (Pos.get_position s) + let to_scoped_var ?(scope = Input) (p : Mir.program) (var : Mpp_ast.var Pos.marked) : scoped_var = let var_s = Pos.unmark var in @@ -97,9 +161,16 @@ let rec to_mpp_expr (p : Mir.program) (translated_names : mpp_compute_name list) let c' = let dom_id = Mast.DomainId.from_marked_list (Pos.unmark dom) in let filter = + let cats = + Mir.CatVarMap.fold + (fun cv _ res -> Mir.CatVarSet.add cv res) + p.program_var_categories Mir.CatVarSet.empty + in match args with - | [] -> None - | [ filter ] -> Some (filter_of_string filter) + | [] -> (None, cats, Mir.CatVarSet.empty) + | [ filter ] -> + let incl, excl = filter2_of_string cats filter in + (Some (filter_of_string filter), incl, excl) | arg :: _ -> Errors.raise_spanned_error "unexpected additional argument" (Pos.get_position arg) diff --git a/src/mlang/mpp_ir/mpp_format.ml b/src/mlang/mpp_ir/mpp_format.ml index bb173c540..1fc5e335f 100644 --- a/src/mlang/mpp_ir/mpp_format.ml +++ b/src/mlang/mpp_ir/mpp_format.ml @@ -23,21 +23,20 @@ let format_scoped_var (fmt : formatter) (sv : scoped_var) : unit = | Local s -> s | Mbased (v, _) -> Pos.unmark v.Mir.Variable.name) -let format_var_filter (fmt : formatter) (f : var_filter) : unit = - match f with - | Saisie None -> pp_print_string fmt Mast.input_category - | Calculee None -> pp_print_string fmt Mast.computed_category - | Calculee (Some st) | Saisie (Some st) -> fprintf fmt "%s" st - let format_callable (fmt : formatter) (f : mpp_callable) = fprintf fmt "%s" (match f with | Rules dom -> Format.asprintf "rules(%a)" (Mast.DomainId.pp ()) dom | Chain chain -> Format.asprintf "chain(%s)" chain | Verifs (dom, filter) -> + let pp_filter fmt = function + | None, _, _ -> () + | Some _l, cvsIncl, cvsExcl -> + Format.fprintf fmt ",incl: %a,excl:%a" (Mir.CatVarSet.pp ()) + cvsIncl (Mir.CatVarSet.pp ()) cvsExcl + in Format.asprintf "verifications(%a%a)" (Mast.DomainId.pp ()) dom - (pp_print_option format_var_filter) - filter + pp_filter filter | MppFunction m -> m | Present -> "present" | Abs -> "abs" diff --git a/src/mlang/mpp_ir/mpp_ir.ml b/src/mlang/mpp_ir/mpp_ir.ml index 22e1bc985..40491cc25 100644 --- a/src/mlang/mpp_ir/mpp_ir.ml +++ b/src/mlang/mpp_ir/mpp_ir.ml @@ -35,7 +35,9 @@ type var_filter = Saisie of string option | Calculee of string option type mpp_callable = | Rules of Mast.DomainId.t (* M codebase *) | Chain of Mast.chaining (* M codebase *) - | Verifs of Mast.DomainId.t * var_filter option (* M codebase *) + | Verifs of + Mast.DomainId.t * (var_filter option * Mir.CatVarSet.t * Mir.CatVarSet.t) + (* M codebase *) | MppFunction of mpp_compute_name | Present | Abs diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml index c4c32fac8..29e84bbac 100644 --- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml +++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml @@ -219,28 +219,54 @@ let generate_verif_cond (cond : Mir.condition_data) : Bir.stmt = (Bir.SVerif data, Pos.get_position data.cond_expr) let generate_verif_call (m_program : Mir_interface.full_program) - (chain : Mast.DomainId.t) (filter : Mpp_ir.var_filter option) : + (chain : Mast.DomainId.t) + (filter : Mpp_ir.var_filter option * Mir.CatVarSet.t * Mir.CatVarSet.t) : Bir.stmt list = let is_verif_relevant var cond = (* specific restriction *) - let test = - let verif_domain = cond.Mir.cond_domain in - let is_max = Mast.DomainIdSet.mem chain verif_domain.dom_max in - let is_eq = verif_domain.dom_id = chain in - (is_max || is_eq) - && - match filter with - | None -> true - | Some filter -> var_filter_compatible_subtypes var.Mir.category filter + let verif_domain = cond.Mir.cond_domain in + let is_max = Mast.DomainIdSet.mem chain verif_domain.dom_max in + let is_eq = verif_domain.dom_id = chain in + let is_var_compatible = + Mir.CatVarSet.subset var.Mir.cats verif_domain.dom_data.vdom_auth in - if - test - && (not (Mast.DomainId.mem "horizontale" chain)) - && List.exists (String.equal Mast.penality_category) var.Mir.category - then - Errors.raise_spanned_error "Penality variable used in verification" - (Pos.get_position cond.Mir.cond_expr) - else test + (is_max || is_eq) && is_var_compatible + && + match filter with + | None, _, _ -> true + | Some filter, incl, excl -> + let t1 = var_filter_compatible_subtypes var.Mir.category filter in + let t2 = + (not + (Mir.CatVarSet.equal Mir.CatVarSet.empty + (Mir.CatVarSet.inter var.Mir.cats incl))) + && Mir.CatVarSet.equal Mir.CatVarSet.empty + (Mir.CatVarSet.inter var.Mir.cats excl) + in + if t1 <> t2 then + let pp_filter fmt = function + | Mpp_ir.Saisie None -> Format.fprintf fmt "saisie *" + | Mpp_ir.Saisie (Some us) -> Format.fprintf fmt "saisie %s" us + | Mpp_ir.Calculee None -> Format.fprintf fmt "calculee *" + | Mpp_ir.Calculee (Some us) -> Format.fprintf fmt "calculee %s" us + in + Errors.raise_error + (Format.asprintf + "t1 = %b t2 = %b@\n\ + cat = %a -- filter = %a@\n\ + cats = %a@\n\ + -- incl = %a@\n\ + -- excl = %a@\n" + t1 t2 + (Format_mast.pp_print_list_comma Format.pp_print_string) + var.Mir.category pp_filter filter + (Mir.CatVarSet.pp ~sep:", " ()) + var.Mir.cats + (Mir.CatVarSet.pp ~sep:", " ()) + incl + (Mir.CatVarSet.pp ~sep:", " ()) + excl) + else t1 in let relevant_verifs = Mir.VariableMap.filter is_verif_relevant m_program.program.program_conds @@ -330,7 +356,8 @@ and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list) ("mpp_" ^ l, pos) None ("", pos) (Mast_to_mir.dummy_exec_number pos) - ~attributes:[] ~origin:None ~category:[] ~is_table:None + ~attributes:[] ~origin:None ~category:[] + ~cats:Mir.CatVarSet.empty ~is_table:None |> Bir.(var_from_mir default_tgv) in let ctx = diff --git a/src/mlang/test_framework/test_interpreter.ml b/src/mlang/test_framework/test_interpreter.ml index abab5a065..723cdc266 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -80,7 +80,8 @@ let to_MIR_function_and_inputs (program : Bir.program) (t : test_file) (* some output variables are actually input, so we don't declare any for now *) let func_conds = - Bir_interface.translate_external_conditions program.idmap + Bir_interface.translate_external_conditions + program.mir_program.program_var_categories program.idmap (List.map (fun (var, value, pos) -> (* sometimes test outputs mention aliases so we have to catch thos From 42b093e09e68d1e8dbf0d50b28d2d0914c6ea513 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 20 Jul 2023 14:13:56 +0200 Subject: [PATCH 16/26] Gestion des positions dans le M DGFiP interne. --- src/mlang/dgfip_m.ml | 96 ++++++++++++----------------- src/mlang/dgfip_m.mli | 6 +- src/mlang/driver.ml | 14 +++-- src/mlang/m_frontend/mast_to_mir.ml | 20 +++--- src/mlang/m_ir/mir.ml | 24 ++------ src/mlang/utils/pos.ml | 42 +++++++++++-- 6 files changed, 104 insertions(+), 98 deletions(-) diff --git a/src/mlang/dgfip_m.ml b/src/mlang/dgfip_m.ml index 5c3f2de6b..b38b628c7 100644 --- a/src/mlang/dgfip_m.ml +++ b/src/mlang/dgfip_m.ml @@ -1,3 +1,5 @@ +let internal_m = "internal DGFiP M" + let variable_domains_declaration = {| variable saisie contexte @@ -223,60 +225,40 @@ let declarations = Format.sprintf "%s%s%s" variable_domains_declaration rule_domains_declaration verif_domains_declaration -let string_to_rule_domain_id : string -> Mast.DomainId.t = function - | "primitif" -> Mast.DomainId.from_list [ "primitive" ] - | "corrective" -> Mast.DomainId.from_list [ "corrective" ] - | "isf" -> Mast.DomainId.from_list [ "isf" ] - | "taux" -> Mast.DomainId.from_list [ "taux" ] - | "irisf" -> Mast.DomainId.from_list [ "irisf" ] - | "base_HR" -> Mast.DomainId.from_list [ "corrective"; "base_HR" ] - | "base_tl" -> Mast.DomainId.from_list [ "corrective"; "base_tl" ] - | "base_tl_init" -> Mast.DomainId.from_list [ "corrective"; "base_tl_init" ] - | "base_tl_rect" -> Mast.DomainId.from_list [ "corrective"; "base_tl_rect" ] - | "base_INITIAL" -> Mast.DomainId.from_list [ "corrective"; "base_INITIAL" ] - | "base_INR" -> Mast.DomainId.from_list [ "corrective"; "base_INR" ] - | "base_inr_ref" -> Mast.DomainId.from_list [ "corrective"; "base_inr_ref" ] - | "base_inr_tl" -> Mast.DomainId.from_list [ "corrective"; "base_inr_tl" ] - | "base_inr_tl22" -> Mast.DomainId.from_list [ "corrective"; "base_inr_tl22" ] - | "base_inr_tl24" -> Mast.DomainId.from_list [ "corrective"; "base_inr_tl24" ] - | "base_inr_ntl" -> Mast.DomainId.from_list [ "corrective"; "base_inr_ntl" ] - | "base_inr_ntl22" -> - Mast.DomainId.from_list [ "corrective"; "base_inr_ntl22" ] - | "base_inr_ntl24" -> - Mast.DomainId.from_list [ "corrective"; "base_inr_ntl24" ] - | "base_inr_inter22" -> - Mast.DomainId.from_list [ "corrective"; "base_inr_inter22" ] - | "base_inr_intertl" -> - Mast.DomainId.from_list [ "corrective"; "base_inr_intertl" ] - | "base_inr_r9901" -> - Mast.DomainId.from_list [ "corrective"; "base_inr_r9901" ] - | "base_inr_cimr07" -> - Mast.DomainId.from_list [ "corrective"; "base_inr_cimr07" ] - | "base_inr_cimr24" -> - Mast.DomainId.from_list [ "corrective"; "base_inr_cimr24" ] - | "base_inr_cimr99" -> - Mast.DomainId.from_list [ "corrective"; "base_inr_cimr99" ] - | "base_inr_tlcimr07" -> - Mast.DomainId.from_list [ "corrective"; "base_inr_tlcimr07" ] - | "base_inr_tlcimr24" -> - Mast.DomainId.from_list [ "corrective"; "base_inr_tlcimr24" ] - | "base_ABAT98" -> Mast.DomainId.from_list [ "corrective"; "base_ABAT98" ] - | "base_ABAT99" -> Mast.DomainId.from_list [ "corrective"; "base_ABAT99" ] - | "base_MAJO" -> Mast.DomainId.from_list [ "corrective"; "base_MAJO" ] - | "base_premier" -> Mast.DomainId.from_list [ "corrective"; "base_premier" ] - | "base_anterieure" -> - Mast.DomainId.from_list [ "corrective"; "base_anterieure" ] - | "base_anterieure_cor" -> - Mast.DomainId.from_list [ "corrective"; "base_anterieure_cor" ] - | "base_stratemajo" -> - Mast.DomainId.from_list [ "corrective"; "base_stratemajo" ] - | "non_auto_cc" -> Mast.DomainId.from_list [] - | "horizontale" -> Mast.DomainId.from_list [ "horizontale" ] - | str -> Errors.raise_error (Format.sprintf "Unknown rule tag: %s" str) - -let string_to_verif_domain_id : string -> Mast.DomainId.t = function - | "primitif" | "primitive" -> Mast.DomainId.from_list [ "primitive" ] - | "corrective" -> Mast.DomainId.from_list [ "corrective" ] - | "isf" -> Mast.DomainId.from_list [ "isf" ] - | "horizontale" -> Mast.DomainId.from_list [ "corrective"; "horizontale" ] - | str -> Errors.raise_error (Format.sprintf "Unknown verif tag: %s" str) +let string_to_rule_domain_id : string -> string list = function + | "primitif" -> [ "primitive" ] + | "corrective" -> [ "corrective" ] + | "isf" -> [ "isf" ] + | "taux" -> [ "taux" ] + | "irisf" -> [ "irisf" ] + | "base_HR" -> [ "corrective"; "base_HR" ] + | "base_tl" -> [ "corrective"; "base_tl" ] + | "base_tl_init" -> [ "corrective"; "base_tl_init" ] + | "base_tl_rect" -> [ "corrective"; "base_tl_rect" ] + | "base_INITIAL" -> [ "corrective"; "base_INITIAL" ] + | "base_INR" -> [ "corrective"; "base_INR" ] + | "base_inr_ref" -> [ "corrective"; "base_inr_ref" ] + | "base_inr_tl" -> [ "corrective"; "base_inr_tl" ] + | "base_inr_tl22" -> [ "corrective"; "base_inr_tl22" ] + | "base_inr_tl24" -> [ "corrective"; "base_inr_tl24" ] + | "base_inr_ntl" -> [ "corrective"; "base_inr_ntl" ] + | "base_inr_ntl22" -> [ "corrective"; "base_inr_ntl22" ] + | "base_inr_ntl24" -> [ "corrective"; "base_inr_ntl24" ] + | "base_inr_inter22" -> [ "corrective"; "base_inr_inter22" ] + | "base_inr_intertl" -> [ "corrective"; "base_inr_intertl" ] + | "base_inr_r9901" -> [ "corrective"; "base_inr_r9901" ] + | "base_inr_cimr07" -> [ "corrective"; "base_inr_cimr07" ] + | "base_inr_cimr24" -> [ "corrective"; "base_inr_cimr24" ] + | "base_inr_cimr99" -> [ "corrective"; "base_inr_cimr99" ] + | "base_inr_tlcimr07" -> [ "corrective"; "base_inr_tlcimr07" ] + | "base_inr_tlcimr24" -> [ "corrective"; "base_inr_tlcimr24" ] + | "base_ABAT98" -> [ "corrective"; "base_ABAT98" ] + | "base_ABAT99" -> [ "corrective"; "base_ABAT99" ] + | "base_MAJO" -> [ "corrective"; "base_MAJO" ] + | "base_premier" -> [ "corrective"; "base_premier" ] + | "base_anterieure" -> [ "corrective"; "base_anterieure" ] + | "base_anterieure_cor" -> [ "corrective"; "base_anterieure_cor" ] + | "base_stratemajo" -> [ "corrective"; "base_stratemajo" ] + | "non_auto_cc" -> [] + | "horizontale" -> [ "horizontale" ] + | _ -> raise Not_found diff --git a/src/mlang/dgfip_m.mli b/src/mlang/dgfip_m.mli index a51adae1b..4ab7d2230 100644 --- a/src/mlang/dgfip_m.mli +++ b/src/mlang/dgfip_m.mli @@ -1,3 +1,5 @@ +val internal_m : string + val variable_domains_declaration : string val rule_domains_declaration : string @@ -6,6 +8,4 @@ val verif_domains_declaration : string val declarations : string -val string_to_rule_domain_id : string -> Mast.DomainId.t - -val string_to_verif_domain_id : string -> Mast.DomainId.t +val string_to_rule_domain_id : string -> string list diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index 5d9cc0e33..f685ca77c 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -139,19 +139,20 @@ let driver (files : string list) (without_dgfip_m : bool) (debug : bool) else ref (let filebuf = Lexing.from_string Dgfip_m.declarations in - current_progress "internal DGFiP M"; + current_progress Dgfip_m.internal_m; let filebuf = { filebuf with lex_curr_p = - { filebuf.lex_curr_p with pos_fname = "internal DGFiP M" }; + { filebuf.lex_curr_p with pos_fname = Dgfip_m.internal_m }; } in try let commands = Mparser.source_file token filebuf in [ commands ] with Mparser.Error -> - Errors.raise_error "M\n syntax error in internal DGFiP M") + Errors.raise_error + (Format.sprintf "M\n syntax error in %s" Dgfip_m.internal_m)) in if List.length !Cli.source_files = 0 then Errors.raise_error "please provide at least one M source file"; @@ -221,7 +222,12 @@ let driver (files : string list) (without_dgfip_m : bool) (debug : bool) in let order = try - let rdom_id = Dgfip_m.string_to_rule_domain_id chain in + let rdom_id = + try + Mast.DomainId.from_list (Dgfip_m.string_to_rule_domain_id chain) + with Not_found -> + Errors.raise_error (Format.sprintf "Unknown rule tag: %s" chain) + in match Mast.DomainIdMap.find_opt rdom_id full_m_program.domains_orders with diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 662354dc3..a47c8cda5 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -491,14 +491,18 @@ let get_var_categories (p : Mast.program) = begin match already_defined with | None -> () - | Some (_decl, pos) -> - Cli.warning_print - "Category \"%s\" defined more than once:@;\ - Already defined %a" - (String.concat " " - (Format_mast.format_var_type normalized_decl.var_type - :: List.map Pos.unmark normalized_decl.var_category)) - Pos.format_position pos + | Some (_decl, posDecl) -> + Errors.raise_spanned_error + (Format.asprintf + "Category \"%s\" defined more than once:@;\ + Already defined %a" + (String.concat " " + (Format_mast.format_var_type + normalized_decl.var_type + :: List.map Pos.unmark + normalized_decl.var_category)) + Pos.format_position posDecl) + pos end; (normalized_decl, pos) :: decls | _ -> decls) diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index e4809530c..4231a5fd8 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -80,29 +80,13 @@ type cat_variable = CatInput of StrSet.t | CatComputed of CatCompSet.t let pp_cat_variable fmt = function | CatInput id -> - let pp fmt set = - let foldSet elt first = - let _ = - if first then Format.fprintf fmt "%s" elt - else Format.fprintf fmt " %s" elt - in - false - in - ignore (StrSet.fold foldSet set true) - in - Format.fprintf fmt "saisie(%a)" pp id + let pp fmt set = StrSet.iter (Format.fprintf fmt " %s") set in + Format.fprintf fmt "saisie%a" pp id | CatComputed id -> let pp fmt set = - let foldSet elt first = - let _ = - if first then Format.fprintf fmt "%a" pp_cat_computed elt - else Format.fprintf fmt ", %a" pp_cat_computed elt - in - false - in - ignore (CatCompSet.fold foldSet set true) + CatCompSet.iter (Format.fprintf fmt " %a" pp_cat_computed) set in - Format.fprintf fmt "calculee(%a)" pp id + Format.fprintf fmt "calculee%a" pp id let compare_cat_variable a b = match (a, b) with diff --git a/src/mlang/utils/pos.ml b/src/mlang/utils/pos.ml index 969eeccd6..52438e6a4 100644 --- a/src/mlang/utils/pos.ml +++ b/src/mlang/utils/pos.ml @@ -120,16 +120,46 @@ let retrieve_loc_text (pos : t) : string = else let sline = get_start_line pos in let eline = get_end_line pos in - let oc = - try open_in filename + let oc, input_line_opt = + try + if filename == Dgfip_m.internal_m then + let input_line_opt : unit -> string option = + let curr = ref 0 in + let src = Dgfip_m.declarations in + let lng = String.length src in + let rec new_curr () = + if !curr < lng then + if src.[!curr] = '\n' || src.[!curr] = '\r' || !curr = lng then ( + let res = !curr in + while src.[!curr] = '\n' || src.[!curr] = '\r' do + incr curr + done; + Some res) + else ( + incr curr; + new_curr ()) + else None + in + function + | () -> ( + let p0 = !curr in + match new_curr () with + | None -> None + | Some p1 -> Some (String.sub Dgfip_m.declarations p0 (p1 - p0)) + ) + in + (None, input_line_opt) + else + let ocf = open_in filename in + let input_line_opt () : string option = + try Some (input_line ocf) with End_of_file -> None + in + (Some ocf, input_line_opt) with Sys_error _ -> Cli.error_print "File not found for displaying position : \"%s\"" filename; exit (-1) in - let input_line_opt () : string option = - try Some (input_line oc) with End_of_file -> None - in let print_matched_line (line : string) (line_no : int) : string = let line_indent = indent_number line in let error_indicator_style = [ ANSITerminal.red; ANSITerminal.Bold ] in @@ -169,7 +199,7 @@ let retrieve_loc_text (pos : t) : string = in let pos_lines = get_lines 1 in let spaces = int_of_float (log10 (float_of_int eline)) + 1 in - close_in oc; + (match oc with Some ocf -> close_in ocf | _ -> ()); Cli.format_with_style blue_style "%*s--> %s\n%s" spaces "" filename (Cli.add_prefix_to_each_line (Printf.sprintf "\n%s" (String.concat "\n" pos_lines)) From 0f7f581c1d441c6328220651c6ef3b92946ee248 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 20 Jul 2023 17:06:32 +0200 Subject: [PATCH 17/26] =?UTF-8?q?Suppression=20des=20variables=20"dummy"?= =?UTF-8?q?=20dans=20les=20v=C3=A9rifs.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/backend_ir/bir_interface.ml | 20 +++--- src/mlang/backend_ir/bir_interface.mli | 4 +- src/mlang/m_frontend/mast_to_mir.ml | 85 ++++++++++--------------- src/mlang/m_frontend/mast_to_mir.mli | 2 +- src/mlang/m_ir/format_mir.ml | 4 +- src/mlang/m_ir/format_mir.mli | 2 +- src/mlang/m_ir/mir.ml | 11 +++- src/mlang/m_ir/mir.mli | 7 ++- src/mlang/m_ir/mir_typechecker.ml | 6 +- src/mlang/mpp_frontend/mpp_frontend.ml | 24 +------ src/mlang/mpp_ir/mpp_format.ml | 3 +- src/mlang/mpp_ir/mpp_ir.ml | 5 +- src/mlang/mpp_ir/mpp_ir_to_bir.ml | 87 +++++--------------------- 13 files changed, 83 insertions(+), 177 deletions(-) diff --git a/src/mlang/backend_ir/bir_interface.ml b/src/mlang/backend_ir/bir_interface.ml index 14d12ca04..3393ec19c 100644 --- a/src/mlang/backend_ir/bir_interface.ml +++ b/src/mlang/backend_ir/bir_interface.ml @@ -18,7 +18,7 @@ type bir_function = { func_variable_inputs : unit Bir.VariableMap.t; func_constant_inputs : Bir.expression Pos.marked Bir.VariableMap.t; func_outputs : unit Bir.VariableMap.t; - func_conds : Bir.condition_data Bir.VariableMap.t; + func_conds : Bir.condition_data Mir.RuleMap.t; } let var_set_from_variable_name_list (p : Bir.program) @@ -88,8 +88,8 @@ let const_var_set_from_list (p : Bir.program) Bir.VariableMap.empty names let translate_external_conditions var_cats idmap - (conds : Mast.expression Pos.marked list) : - Bir.condition_data Bir.VariableMap.t = + (conds : Mast.expression Pos.marked list) : Bir.condition_data Mir.RuleMap.t + = let check_boolean (mexpr : Mast.expression Pos.marked) = match Pos.unmark mexpr with | Binop (((And | Or), _), _, _) -> true @@ -160,13 +160,9 @@ let translate_external_conditions var_cats idmap Mast_to_mir.get_conds var_cats [ test_error ] Mast_to_mir.ConstMap.empty idmap [ program ] in - Mir.VariableMap.fold - (fun v data acc -> - Bir.VariableMap.add - Bir.(var_from_mir default_tgv v) - (Mir.map_cond_data_var Bir.(var_from_mir default_tgv) data) - acc) - conds Bir.VariableMap.empty + Mir.RuleMap.map + (fun data -> Mir.map_cond_data_var Bir.(var_from_mir default_tgv) data) + conds let generate_function_all_vars (p : Bir.program) : bir_function = let output_vars = @@ -202,7 +198,7 @@ let generate_function_all_vars (p : Bir.program) : bir_function = func_variable_inputs = input_vars; func_constant_inputs = Bir.VariableMap.empty; func_outputs = output_vars; - func_conds = Bir.VariableMap.empty; + func_conds = Mir.RuleMap.empty; } let read_function_from_spec (p : Bir.program) (spec_file : string) : @@ -310,7 +306,7 @@ let adapt_program_to_function (p : Bir.program) (f : bir_function) : p.mir_program [] in let conds_stmts = - Bir.VariableMap.fold + Mir.RuleMap.fold (fun _ cond acc -> Pos.same_pos_as (Bir.SVerif cond) cond.cond_expr :: acc) f.func_conds [] diff --git a/src/mlang/backend_ir/bir_interface.mli b/src/mlang/backend_ir/bir_interface.mli index 8507b465e..3b347ee92 100644 --- a/src/mlang/backend_ir/bir_interface.mli +++ b/src/mlang/backend_ir/bir_interface.mli @@ -20,7 +20,7 @@ type bir_function = { func_variable_inputs : unit Bir.VariableMap.t; func_constant_inputs : Bir.expression Pos.marked Bir.VariableMap.t; func_outputs : unit Bir.VariableMap.t; - func_conds : Bir.condition_data Bir.VariableMap.t; + func_conds : Bir.condition_data Mir.RuleMap.t; } (** Input-output data necessary to interpret a BIR program*) @@ -28,7 +28,7 @@ val translate_external_conditions : Pos.t StrMap.t Pos.marked Mir.CatVarMap.t -> Mir.idmap -> Mast.expression Pos.marked list -> - Bir.condition_data Bir.VariableMap.t + Bir.condition_data Mir.RuleMap.t (** [translate_external_conditions idmap conditions] translates a series of boolean expressions [conditions] into M verification conditions ready to be added to a BIR program *) diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index a47c8cda5..d636313f7 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -1812,7 +1812,7 @@ let add_dummy_definitions_for_variable_declarations let get_conds (cats : 'a Mir.CatVarMap.t) (error_decls : Mir.Error.t list) (const_map : float Pos.marked ConstMap.t) (idmap : Mir.idmap) (p : Mast.program) : - Mir.verif_domain Mast.DomainIdMap.t * Mir.condition_data Mir.VariableMap.t = + Mir.verif_domain Mast.DomainIdMap.t * Mir.condition_data Mir.RuleMap.t = let verif_domains = get_verif_domains cats p in let conds = List.fold_left @@ -1856,20 +1856,6 @@ let get_conds (cats : 'a Mir.CatVarMap.t) (error_decls : Mir.Error.t list) } (Pos.unmark verif_cond).Mast.verif_cond_expr in - let category = - (* Verifications are maped to a dummy variable, we use - it to store all the subtypes of variables appearing - in its expression to avoid going through it later - when we sort verifications chains out *) - Mir.fold_expr_var - (fun subtypes var -> - List.fold_left - (fun subtypes st -> - if List.mem st subtypes then subtypes - else st :: subtypes) - subtypes var.Mir.category) - [] (Pos.unmark e) - in let cond_cats = Mir.fold_expr_var (fun subtypes (var : Mir.variable) -> @@ -1878,7 +1864,10 @@ let get_conds (cats : 'a Mir.CatVarMap.t) (error_decls : Mir.Error.t list) if Mir.CatVarSet.mem c cond_domain.dom_data.vdom_auth - then Mir.CatVarSet.add c res + then + Mir.CatVarMap.add c + (1 + Mir.CatVarMap.find c res) + res else Errors.raise_error (Format.asprintf @@ -1888,7 +1877,8 @@ let get_conds (cats : 'a Mir.CatVarMap.t) (error_decls : Mir.Error.t list) Mir.pp_cat_variable c rule_number (Mast.DomainId.pp ()) cond_domain.dom_id)) var.Mir.cats subtypes) - Mir.CatVarSet.empty (Pos.unmark e) + (Mir.CatVarMap.map (fun _ -> 0) cats) + (Pos.unmark e) in let err = let err_name, err_var = @@ -1913,47 +1903,36 @@ let get_conds (cats : 'a Mir.CatVarMap.t) (error_decls : Mir.Error.t list) (Pos.unmark err_name) Pos.format_position (Pos.get_position err_name)) in - let dummy_var = - Mir.Variable.new_var - (Pos.same_pos_as - (Format.sprintf "verification_condition_%d" - (Mir.Variable.fresh_id ())) - e) - None - (Pos.same_pos_as - (let () = - Pos.format_position Format.str_formatter - (Pos.get_position e) - in - Format.flush_str_formatter ()) - e) - { - Mir.rule_number; - Mir.seq_number = 0; - Mir.pos = Pos.get_position verif_cond; - } - ~attributes:[] ~origin:None ~category ~cats:cond_cats - ~is_table:None - in - ( Mir.VariableMap.add dummy_var - Mir. - { - cond_number = - Pos.same_pos_as (VerifID rule_number) - verif.verif_number; - cond_domain; - cond_expr = e; - cond_error = err; - cond_cats; - } - conds, - id_offset + 1 )) + let cond_seq_id = Mir.Variable.fresh_id () in + let rov = Mir.VerifID rule_number in + match Mir.RuleMap.find_opt rov conds with + | Some c -> + Errors.raise_spanned_error + (Format.asprintf + "verif number %d already defined: %a" rule_number + Pos.format_position + (Pos.get_position c.Mir.cond_number)) + (Pos.get_position verif.verif_number) + | None -> + ( Mir.RuleMap.add rov + Mir. + { + cond_seq_id; + cond_number = + Pos.same_pos_as rov verif.verif_number; + cond_domain; + cond_expr = e; + cond_error = err; + cond_cats; + } + conds, + id_offset + 1 )) (conds, 0) verif.Mast.verif_conditions in conds | _ -> conds) conds (List.rev source_file)) (* Order important for DGFiP *) - Mir.VariableMap.empty p + Mir.RuleMap.empty p in (verif_domains, conds) diff --git a/src/mlang/m_frontend/mast_to_mir.mli b/src/mlang/m_frontend/mast_to_mir.mli index 1f014024c..8225dbf3b 100644 --- a/src/mlang/m_frontend/mast_to_mir.mli +++ b/src/mlang/m_frontend/mast_to_mir.mli @@ -79,7 +79,7 @@ val get_conds : float Pos.marked ConstMap.t -> Mir.idmap -> Mast.program -> - Mir.verif_domain Mast.DomainIdMap.t * Mir.condition_data Mir.VariableMap.t + Mir.verif_domain Mast.DomainIdMap.t * Mir.condition_data Mir.RuleMap.t (** Returns a map whose keys are dummy variables and whose values are the verification conditions. *) diff --git a/src/mlang/m_ir/format_mir.ml b/src/mlang/m_ir/format_mir.ml index 8ee04792c..c028d5933 100644 --- a/src/mlang/m_ir/format_mir.ml +++ b/src/mlang/m_ir/format_mir.ml @@ -140,11 +140,11 @@ let format_program_rules fmt (vars : VariableDict.t) format_variables var_defs) rules -let format_program_conds fmt (conds : condition_data VariableMap.t) = +let format_program_conds fmt (conds : condition_data Mir.RuleMap.t) = Format_mast.pp_print_list_endline (fun fmt (_, cond) -> format_precondition fmt cond) fmt - (VariableMap.bindings conds) + (Mir.RuleMap.bindings conds) let format_program fmt (p : program) = Format.fprintf fmt "%a\n\n%a" diff --git a/src/mlang/m_ir/format_mir.mli b/src/mlang/m_ir/format_mir.mli index a9a9f2133..91606d9e6 100644 --- a/src/mlang/m_ir/format_mir.mli +++ b/src/mlang/m_ir/format_mir.mli @@ -42,7 +42,7 @@ val format_program_rules : Format.formatter -> Mir.VariableDict.t -> Mir.rule_data Mir.RuleMap.t -> unit val format_program_conds : - Format.formatter -> Mir.condition_data Mir.VariableMap.t -> unit + Format.formatter -> Mir.condition_data Mir.RuleMap.t -> unit val format_program : Format.formatter -> Mir.program -> unit diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 4231a5fd8..6876e276f 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -522,16 +522,18 @@ type verif_domain_data = { vdom_auth : CatVarSet.t; vdom_auto_cc : bool } type verif_domain = verif_domain_data domain type 'variable condition_data_ = { + cond_seq_id : int; cond_number : rov_id Pos.marked; cond_domain : verif_domain; cond_expr : 'variable expression_ Pos.marked; cond_error : (Error.t[@opaque]) * 'variable option; - cond_cats : CatVarSet.t; + cond_cats : int CatVarMap.t; } let map_cond_data_var (f : 'v -> 'v2) (cond : 'v condition_data_) : 'v2 condition_data_ = { + cond_seq_id = cond.cond_seq_id; cond_number = cond.cond_number; cond_domain = cond.cond_domain; cond_expr = Pos.map_under_mark (map_expr_var f) cond.cond_expr; @@ -541,6 +543,11 @@ let map_cond_data_var (f : 'v -> 'v2) (cond : 'v condition_data_) : cond_cats = cond.cond_cats; } +let cond_cats_to_set cats = + CatVarMap.fold + (fun cv nb res -> if nb > 0 then CatVarSet.add cv res else res) + cats CatVarSet.empty + type condition_data = variable condition_data_ type idmap = Variable.t list Pos.VarNameToID.t @@ -562,7 +569,7 @@ type program = { program_rules : rule_data RuleMap.t; (** Definitions of variables, some may be removed during optimization passes *) - program_conds : condition_data VariableMap.t; + program_conds : condition_data RuleMap.t; (** Conditions are affected to dummy variables *) program_idmap : idmap; program_exec_passes : exec_pass list; diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 90b1d5409..09a204a77 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -196,11 +196,12 @@ type verif_domain_data = { vdom_auth : CatVarSet.t; vdom_auto_cc : bool } type verif_domain = verif_domain_data domain type 'variable condition_data_ = { + cond_seq_id : int; cond_number : rov_id Pos.marked; cond_domain : verif_domain; cond_expr : 'variable expression_ Pos.marked; cond_error : error * 'variable option; - cond_cats : CatVarSet.t; + cond_cats : int CatVarMap.t; } type condition_data = variable condition_data_ @@ -223,7 +224,7 @@ type program = { program_rules : rule_data RuleMap.t; (** Definitions of variables, some may be removed during optimization passes *) - program_conds : condition_data VariableMap.t; + program_conds : condition_data RuleMap.t; (** Conditions are affected to dummy variables containing informations about actual variables in the conditions *) program_idmap : idmap; @@ -320,6 +321,8 @@ val map_var_def_var : ('v -> 'v2) -> 'v variable_def_ -> 'v2 variable_def_ val map_cond_data_var : ('v -> 'v2) -> 'v condition_data_ -> 'v2 condition_data_ +val cond_cats_to_set : int CatVarMap.t -> CatVarSet.t + val fold_vars : (variable -> variable_data -> 'a -> 'a) -> program -> 'a -> 'a val map_vars : diff --git a/src/mlang/m_ir/mir_typechecker.ml b/src/mlang/m_ir/mir_typechecker.ml index ff28ecf0c..e7a2c5e07 100644 --- a/src/mlang/m_ir/mir_typechecker.ml +++ b/src/mlang/m_ir/mir_typechecker.ml @@ -127,8 +127,8 @@ let determine_def_complete_cover (table_var : Mir.Variable.t) (size : int) defs_array; List.sort compare !undefined -let typecheck_program_conds (conds : condition_data VariableMap.t) = - VariableMap.iter +let typecheck_program_conds (conds : condition_data Mir.RuleMap.t) = + Mir.RuleMap.iter (fun _ cond -> typecheck_top_down ~in_generic_table:false cond.cond_expr) conds @@ -351,7 +351,7 @@ let expand_functions (p : Mir_interface.full_program) : { program with program_conds = - VariableMap.map + Mir.RuleMap.map (fun cond -> { cond with cond_expr = expand_functions_expr cond.cond_expr }) p.program.program_conds; diff --git a/src/mlang/mpp_frontend/mpp_frontend.ml b/src/mlang/mpp_frontend/mpp_frontend.ml index d60935340..e262d901b 100644 --- a/src/mlang/mpp_frontend/mpp_frontend.ml +++ b/src/mlang/mpp_frontend/mpp_frontend.ml @@ -19,23 +19,7 @@ open Mpp_ir -let filter_of_string (s : string Pos.marked) : var_filter = - let us = Pos.unmark s in - match us with - | "saisie" -> Saisie None - | "calculee" -> Calculee None - | "contexte" -> Saisie (Some us) - | "famille" -> Saisie (Some us) - | "revenu" -> Saisie (Some us) - | "penalite" -> Saisie (Some us) - | "base" -> Calculee (Some us) - | "restituee" -> Calculee (Some us) - | unknown -> - Errors.raise_spanned_error - (Format.sprintf "unknown variable category %s" unknown) - (Pos.get_position s) - -let filter2_of_string (cats : Mir.CatVarSet.t) (s : string Pos.marked) : +let filter_of_string (cats : Mir.CatVarSet.t) (s : string Pos.marked) : Mir.CatVarSet.t * Mir.CatVarSet.t = let us = Pos.unmark s in match us with @@ -167,10 +151,8 @@ let rec to_mpp_expr (p : Mir.program) (translated_names : mpp_compute_name list) p.program_var_categories Mir.CatVarSet.empty in match args with - | [] -> (None, cats, Mir.CatVarSet.empty) - | [ filter ] -> - let incl, excl = filter2_of_string cats filter in - (Some (filter_of_string filter), incl, excl) + | [] -> (cats, Mir.CatVarSet.empty) + | [ filter ] -> filter_of_string cats filter | arg :: _ -> Errors.raise_spanned_error "unexpected additional argument" (Pos.get_position arg) diff --git a/src/mlang/mpp_ir/mpp_format.ml b/src/mlang/mpp_ir/mpp_format.ml index 1fc5e335f..bb32e201a 100644 --- a/src/mlang/mpp_ir/mpp_format.ml +++ b/src/mlang/mpp_ir/mpp_format.ml @@ -30,8 +30,7 @@ let format_callable (fmt : formatter) (f : mpp_callable) = | Chain chain -> Format.asprintf "chain(%s)" chain | Verifs (dom, filter) -> let pp_filter fmt = function - | None, _, _ -> () - | Some _l, cvsIncl, cvsExcl -> + | cvsIncl, cvsExcl -> Format.fprintf fmt ",incl: %a,excl:%a" (Mir.CatVarSet.pp ()) cvsIncl (Mir.CatVarSet.pp ()) cvsExcl in diff --git a/src/mlang/mpp_ir/mpp_ir.ml b/src/mlang/mpp_ir/mpp_ir.ml index 40491cc25..4333f2d37 100644 --- a/src/mlang/mpp_ir/mpp_ir.ml +++ b/src/mlang/mpp_ir/mpp_ir.ml @@ -30,13 +30,10 @@ type scoped_var = type mpp_compute_name = string -type var_filter = Saisie of string option | Calculee of string option - type mpp_callable = | Rules of Mast.DomainId.t (* M codebase *) | Chain of Mast.chaining (* M codebase *) - | Verifs of - Mast.DomainId.t * (var_filter option * Mir.CatVarSet.t * Mir.CatVarSet.t) + | Verifs of Mast.DomainId.t * (Mir.CatVarSet.t * Mir.CatVarSet.t) (* M codebase *) | MppFunction of mpp_compute_name | Present diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml index 29e84bbac..dfa68e74f 100644 --- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml +++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml @@ -87,31 +87,6 @@ let generate_input_condition (crit : Mir.Variable.t -> bool) (fun var acc -> mk_or (mk_call_present var) acc) variables_to_check mk_false -let var_filter_compatible_subtypes (subtypes : string list) - (filter : Mpp_ir.var_filter) : bool = - match (filter : Mpp_ir.var_filter) with - | Saisie st -> - (match st with - | None -> - List.exists - (fun st -> - match st with - | "contexte" | "famille" | "revenu" | "penalite" | "saisie" -> - true - | _ -> false) - subtypes - | Some st -> List.mem st subtypes) - && List.for_all - (fun x -> not (String.equal Mast.computed_category x)) - subtypes - | Calculee st -> ( - match st with - | None -> - List.exists - (fun st -> match st with "base" | "calculee" -> true | _ -> false) - subtypes - | Some st -> List.mem st subtypes) - let var_is_ (attr : string) (v : Mir.Variable.t) : bool = List.exists (fun ((attr_name, _), (attr_value, _)) -> @@ -219,67 +194,35 @@ let generate_verif_cond (cond : Mir.condition_data) : Bir.stmt = (Bir.SVerif data, Pos.get_position data.cond_expr) let generate_verif_call (m_program : Mir_interface.full_program) - (chain : Mast.DomainId.t) - (filter : Mpp_ir.var_filter option * Mir.CatVarSet.t * Mir.CatVarSet.t) : - Bir.stmt list = - let is_verif_relevant var cond = + (chain : Mast.DomainId.t) ((incl, excl) : Mir.CatVarSet.t * Mir.CatVarSet.t) + : Bir.stmt list = + let is_verif_relevant _ cond = (* specific restriction *) + let cats = Mir.cond_cats_to_set cond.Mir.cond_cats in let verif_domain = cond.Mir.cond_domain in let is_max = Mast.DomainIdSet.mem chain verif_domain.dom_max in let is_eq = verif_domain.dom_id = chain in let is_var_compatible = - Mir.CatVarSet.subset var.Mir.cats verif_domain.dom_data.vdom_auth + Mir.CatVarSet.subset cats verif_domain.dom_data.vdom_auth in (is_max || is_eq) && is_var_compatible - && - match filter with - | None, _, _ -> true - | Some filter, incl, excl -> - let t1 = var_filter_compatible_subtypes var.Mir.category filter in - let t2 = - (not - (Mir.CatVarSet.equal Mir.CatVarSet.empty - (Mir.CatVarSet.inter var.Mir.cats incl))) - && Mir.CatVarSet.equal Mir.CatVarSet.empty - (Mir.CatVarSet.inter var.Mir.cats excl) - in - if t1 <> t2 then - let pp_filter fmt = function - | Mpp_ir.Saisie None -> Format.fprintf fmt "saisie *" - | Mpp_ir.Saisie (Some us) -> Format.fprintf fmt "saisie %s" us - | Mpp_ir.Calculee None -> Format.fprintf fmt "calculee *" - | Mpp_ir.Calculee (Some us) -> Format.fprintf fmt "calculee %s" us - in - Errors.raise_error - (Format.asprintf - "t1 = %b t2 = %b@\n\ - cat = %a -- filter = %a@\n\ - cats = %a@\n\ - -- incl = %a@\n\ - -- excl = %a@\n" - t1 t2 - (Format_mast.pp_print_list_comma Format.pp_print_string) - var.Mir.category pp_filter filter - (Mir.CatVarSet.pp ~sep:", " ()) - var.Mir.cats - (Mir.CatVarSet.pp ~sep:", " ()) - incl - (Mir.CatVarSet.pp ~sep:", " ()) - excl) - else t1 + && (not + (Mir.CatVarSet.equal Mir.CatVarSet.empty + (Mir.CatVarSet.inter cats incl))) + && Mir.CatVarSet.equal Mir.CatVarSet.empty (Mir.CatVarSet.inter cats excl) in let relevant_verifs = - Mir.VariableMap.filter is_verif_relevant m_program.program.program_conds + Mir.RuleMap.filter is_verif_relevant m_program.program.program_conds in let verifs = - Mir.VariableMap.bindings relevant_verifs - |> List.sort (fun (v1, cond1) (v2, cond2) -> + Mir.RuleMap.bindings relevant_verifs + |> List.sort (fun (_, cond1) (_, cond2) -> let res = Mast.compare_error_type (fst cond1.Mir.cond_error).typ (fst cond2.Mir.cond_error).typ in if res <> 0 then res - else Stdlib.compare v1.Mir.Variable.id v2.Mir.Variable.id) + else Stdlib.compare cond1.Mir.cond_seq_id cond2.Mir.cond_seq_id) |> List.map snd in List.map @@ -568,8 +511,8 @@ let create_combined_program (m_program : Mir_interface.full_program) m_program.program.program_rules Mir.RuleMap.empty in let rules_and_verifs = - Mir.VariableMap.fold - (fun _var cond_data rules -> + Mir.RuleMap.fold + (fun _ cond_data rules -> let rov_id = Pos.unmark cond_data.Mir.cond_number in let rov_name = Pos.same_pos_as From 7d0d21708a8607db8bef7c3493f54a54079117c1 Mon Sep 17 00:00:00 2001 From: david Date: Mon, 24 Jul 2023 21:50:48 +0200 Subject: [PATCH 18/26] =?UTF-8?q?Modifications=20du=20MPP=20pour=20le=20fi?= =?UTF-8?q?ltrage=20des=20v=C3=A9rifs=20(en=20cours).?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/mpp_frontend/mpp_ast.ml | 1 + src/mlang/mpp_frontend/mpp_frontend.ml | 47 ++++++++++++++++++++++++++ src/mlang/mpp_frontend/mpp_lexer.mll | 6 ++++ src/mlang/mpp_frontend/mpp_parser.mly | 18 ++++++++++ src/mlang/mpp_ir/mpp_format.ml | 2 ++ src/mlang/mpp_ir/mpp_ir.ml | 1 + 6 files changed, 75 insertions(+) diff --git a/src/mlang/mpp_frontend/mpp_ast.ml b/src/mlang/mpp_frontend/mpp_ast.ml index 48f4906ac..4bf8b4344 100644 --- a/src/mlang/mpp_frontend/mpp_ast.ml +++ b/src/mlang/mpp_frontend/mpp_ast.ml @@ -15,6 +15,7 @@ type expr = expr_kind Pos.marked and expr_kind = | Constant of int | Variable of var + | NbVarCategory of string list Pos.marked | Unop of unop * expr | CallRules of string Pos.marked list Pos.marked * var Pos.marked list | CallChain of var Pos.marked list diff --git a/src/mlang/mpp_frontend/mpp_frontend.ml b/src/mlang/mpp_frontend/mpp_frontend.ml index e262d901b..f92387b4b 100644 --- a/src/mlang/mpp_frontend/mpp_frontend.ml +++ b/src/mlang/mpp_frontend/mpp_frontend.ml @@ -119,6 +119,53 @@ let rec to_mpp_expr (p : Mir.program) (translated_names : mpp_compute_name list) ~scope:(if List.mem v scope then Output else Input) p (Pos.same_pos_as v e)), scope ) + | NbVarCategory l -> + let cats = + let filter_cats pred = + Mir.CatVarMap.fold + (fun cv _ res -> + if pred cv then Mir.CatVarSet.add cv res else res) + p.program_var_categories Mir.CatVarSet.empty + in + match Pos.unmark l with + | [ "*" ] -> filter_cats (fun _ -> true) + | [ "saisie"; "*" ] -> + filter_cats (fun cv -> + match cv with Mir.CatInput _ -> true | _ -> false) + | "saisie" :: strs -> + let cv = Mir.CatInput (StrSet.from_list strs) in + if Mir.CatVarMap.mem cv p.program_var_categories then + Mir.CatVarSet.singleton cv + else + Errors.raise_spanned_error "unknown variable category" + (Pos.get_position l) + | [ "calculee"; "*" ] -> + let base = Mir.CatCompSet.singleton Mir.Base in + let givenBack = Mir.CatCompSet.singleton Mir.GivenBack in + let baseAndGivenBack = Mir.CatCompSet.union base givenBack in + Mir.CatVarSet.singleton (Mir.CatComputed Mir.CatCompSet.empty) + |> Mir.CatVarSet.add (Mir.CatComputed base) + |> Mir.CatVarSet.add (Mir.CatComputed givenBack) + |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) + | [ "calculee"; "base"; "*" ] -> + let base = Mir.CatCompSet.singleton Mir.Base in + let baseAndGivenBack = Mir.CatCompSet.add Mir.GivenBack base in + Mir.CatVarSet.singleton (Mir.CatComputed base) + |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) + | [ "calculee"; "restituee"; "*" ] -> + let givenBack = Mir.CatCompSet.singleton Mir.GivenBack in + let baseAndGivenBack = Mir.CatCompSet.add Mir.Base givenBack in + Mir.CatVarSet.singleton (Mir.CatComputed givenBack) + |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) + | [ "calculee"; "base"; "restituee" ] -> + let baseAndGivenBack = + Mir.CatCompSet.singleton Mir.Base + |> Mir.CatCompSet.add Mir.GivenBack + in + Mir.CatVarSet.singleton (Mir.CatComputed baseAndGivenBack) + | _ -> assert false + in + (Call (NbVarCat cats, []), []) | Unop (Minus, e) -> let e', scope = to_mpp_expr p translated_names scope e in (Unop (Minus, e'), scope) diff --git a/src/mlang/mpp_frontend/mpp_lexer.mll b/src/mlang/mpp_frontend/mpp_lexer.mll index d6d620088..bb8a5ad66 100644 --- a/src/mlang/mpp_frontend/mpp_lexer.mll +++ b/src/mlang/mpp_frontend/mpp_lexer.mll @@ -42,9 +42,15 @@ rule next_tokens = parse | "else" { [ELSE] } | "del" { [DELETE] } | "partition with" { [PARTITION] } + | "saisie" { [INPUT] } + | "calculee" { [COMPUTED] } + | "base" { [BASE] } + | "restituee" { [GIVEN_BACK] } + | "*" { [STAR] } | "call_m_rules" { [CALL_M_RULES] } | "call_m_chain" { [CALL_M_CHAIN] } | "call_m_verifs" { [CALL_M_VERIFS] } + | "nb_category" { [NB_CATEGORY] } | ':' { [COLON] } | integer as i { [INT (int_of_string i)] } | ['a'-'z' 'A'-'Z' '0'-'9' '_']+ as s diff --git a/src/mlang/mpp_frontend/mpp_parser.mly b/src/mlang/mpp_frontend/mpp_parser.mly index 2ed9ed63a..2e28508f9 100644 --- a/src/mlang/mpp_frontend/mpp_parser.mly +++ b/src/mlang/mpp_frontend/mpp_parser.mly @@ -13,6 +13,7 @@ %token AND OR %token IF ELSE DELETE PARTITION COLON COMMA MINUS %token CALL_M_RULES CALL_M_CHAIN CALL_M_VERIFS +%token NB_CATEGORY INPUT COMPUTED BASE GIVEN_BACK STAR %left OR %left AND @@ -34,6 +35,10 @@ compute_functions: ident: | i = IDENT { (i, mk_position $sloc) } +| COMPUTED { ("calculee", mk_position $sloc) } +| INPUT { ("saisie", mk_position $sloc) } +| BASE { ("base", mk_position $sloc) } +| GIVEN_BACK { ("restituee", mk_position $sloc) } ; ident_list: @@ -85,8 +90,21 @@ new_block: | OR { Or } ; +var_category: +| STAR { (["*"], mk_position $sloc) } +| INPUT STAR { (["*"], mk_position $sloc) } +| INPUT l = nonempty_list(ident) { ("saisie" :: (List.map fst l), mk_position $sloc) } +| COMPUTED STAR { (["calculee"; "*"], mk_position $sloc) } +| COMPUTED BASE STAR { (["calulee"; "base"; "*"], mk_position $sloc) } +| COMPUTED GIVEN_BACK STAR { (["calulee"; "restituee"; "*"], mk_position $sloc) } +| COMPUTED BASE GIVEN_BACK | COMPUTED GIVEN_BACK BASE + { (["calulee"; "base"; "restituee"], mk_position $sloc) } +; + expr: | i = INT { Constant i, mk_position $sloc } +| NB_CATEGORY LPAREN cat = var_category RPAREN + { NbVarCategory(cat), mk_position $sloc } | var = IDENT { Variable var, mk_position $sloc } | MINUS e = expr { Unop(Minus, e), mk_position $sloc } | var = ident LPAREN args = separated_list(COMMA, ident) RPAREN diff --git a/src/mlang/mpp_ir/mpp_format.ml b/src/mlang/mpp_ir/mpp_format.ml index bb32e201a..d3e78abbe 100644 --- a/src/mlang/mpp_ir/mpp_format.ml +++ b/src/mlang/mpp_ir/mpp_format.ml @@ -36,6 +36,8 @@ let format_callable (fmt : formatter) (f : mpp_callable) = in Format.asprintf "verifications(%a%a)" (Mast.DomainId.pp ()) dom pp_filter filter + | NbVarCat cvs -> + Format.asprintf "nb_var_category(%a)" (Mir.CatVarSet.pp ()) cvs | MppFunction m -> m | Present -> "present" | Abs -> "abs" diff --git a/src/mlang/mpp_ir/mpp_ir.ml b/src/mlang/mpp_ir/mpp_ir.ml index 4333f2d37..4367be388 100644 --- a/src/mlang/mpp_ir/mpp_ir.ml +++ b/src/mlang/mpp_ir/mpp_ir.ml @@ -34,6 +34,7 @@ type mpp_callable = | Rules of Mast.DomainId.t (* M codebase *) | Chain of Mast.chaining (* M codebase *) | Verifs of Mast.DomainId.t * (Mir.CatVarSet.t * Mir.CatVarSet.t) + | NbVarCat of Mir.CatVarSet.t (* M codebase *) | MppFunction of mpp_compute_name | Present From 280a380c11cc114f7ed51a1811df2a487b0be39d Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 25 Jul 2023 13:43:01 +0200 Subject: [PATCH 19/26] =?UTF-8?q?Modification=20du=20MPP=20pour=20le=20fil?= =?UTF-8?q?trage=20des=20v=C3=A9rifs.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mpp_specs/dgfip_base.mpp | 24 +++++----- src/mlang/mpp_frontend/mpp_ast.ml | 2 +- src/mlang/mpp_frontend/mpp_frontend.ml | 22 ++------- src/mlang/mpp_frontend/mpp_parser.mly | 17 +++++-- src/mlang/mpp_ir/mpp_format.ml | 41 +++++++--------- src/mlang/mpp_ir/mpp_ir.ml | 28 +++++------ src/mlang/mpp_ir/mpp_ir_to_bir.ml | 65 +++++++++++++++++++++++--- 7 files changed, 120 insertions(+), 79 deletions(-) diff --git a/mpp_specs/dgfip_base.mpp b/mpp_specs/dgfip_base.mpp index 4a0c30dc9..8af4334e0 100644 --- a/mpp_specs/dgfip_base.mpp +++ b/mpp_specs/dgfip_base.mpp @@ -107,50 +107,50 @@ ENCH_TL(): outputs <- call_m_chain(ENCH_TL) verif_calcul_primitive_isf_raw(): - call_m_verifs(isf,calculee) + call_m_verifs(isf, nb_category(calculee *) > 0) verif_calcul_primitive_raw(): verif_calcul_primitive_isf_raw() - call_m_verifs(primitive,calculee) + call_m_verifs(primitive, nb_category(calculee *) > 0) verif_calcul_corrective_raw(): outputs <- calcul_primitif_isf() verif_calcul_primitive_isf_raw() - call_m_verifs(corrective,calculee) + call_m_verifs(corrective, nb_category(calculee *) > 0) verif_saisie_cohe_primitive_isf_raw(): - call_m_verifs(isf,saisie) + call_m_verifs(isf, nb_category(saisie *) > 0 and nb_category(calculee *) == 0) verif_saisie_cohe_primitive_raw(): verif_saisie_cohe_primitive_isf_raw() outputs <- calcul_primitif_isf() verif_calcul_primitive_isf_raw() - call_m_verifs(primitive,saisie) + call_m_verifs(primitive, nb_category(saisie *) > 0 and nb_category(calculee *) == 0) verif_saisie_cohe_corrective_raw(): verif_saisie_cohe_primitive_isf_raw() - call_m_verifs(corrective,saisie) + call_m_verifs(corrective, nb_category(saisie *) > 0 and nb_category(calculee *) == 0) verif_cohe_horizontale_raw(): call_m_verifs(horizontale corrective) verif_contexte_cohe_primitive_raw(): - call_m_verifs(primitive,contexte) + call_m_verifs(primitive, nb_category(saisie contexte) > 0 and nb_category(calculee *) == 0) verif_contexte_cohe_corrective_raw(): - call_m_verifs(corrective,contexte) + call_m_verifs(corrective, nb_category(saisie contexte) > 0 and nb_category(calculee *) == 0) verif_famille_cohe_primitive_raw(): - call_m_verifs(primitive,famille) + call_m_verifs(primitive, nb_category(saisie famille) > 0 and nb_category(calculee *) == 0) verif_famille_cohe_corrective_raw(): - call_m_verifs(corrective,famille) + call_m_verifs(corrective, nb_category(saisie famille) > 0 and nb_category(calculee *) == 0) verif_revenu_cohe_primitive_raw(): - call_m_verifs(primitive,revenu) + call_m_verifs(primitive, nb_category(saisie revenu) > 0 and nb_category(calculee *) == 0) verif_revenu_cohe_corrective_raw(): - call_m_verifs(corrective,revenu) + call_m_verifs(corrective, nb_category(saisie revenu) > 0 and nb_category(calculee *) == 0) dgfip_calculation(): APPLI_OCEANS = 0 diff --git a/src/mlang/mpp_frontend/mpp_ast.ml b/src/mlang/mpp_frontend/mpp_ast.ml index 4bf8b4344..a2838513f 100644 --- a/src/mlang/mpp_frontend/mpp_ast.ml +++ b/src/mlang/mpp_frontend/mpp_ast.ml @@ -19,7 +19,7 @@ and expr_kind = | Unop of unop * expr | CallRules of string Pos.marked list Pos.marked * var Pos.marked list | CallChain of var Pos.marked list - | CallVerifs of string Pos.marked list Pos.marked * var Pos.marked list + | CallVerifs of string Pos.marked list Pos.marked * expr | Call of callable Pos.marked * var Pos.marked list | Binop of expr * binop * expr diff --git a/src/mlang/mpp_frontend/mpp_frontend.ml b/src/mlang/mpp_frontend/mpp_frontend.ml index f92387b4b..35e09219c 100644 --- a/src/mlang/mpp_frontend/mpp_frontend.ml +++ b/src/mlang/mpp_frontend/mpp_frontend.ml @@ -19,7 +19,7 @@ open Mpp_ir -let filter_of_string (cats : Mir.CatVarSet.t) (s : string Pos.marked) : +let _filter_of_string (cats : Mir.CatVarSet.t) (s : string Pos.marked) : Mir.CatVarSet.t * Mir.CatVarSet.t = let us = Pos.unmark s in match us with @@ -188,27 +188,13 @@ let rec to_mpp_expr (p : Mir.program) (translated_names : mpp_compute_name list) let new_scope = List.map Pos.unmark args in let args' = List.map (to_scoped_var p) args in (Call (c', args'), new_scope) - | CallVerifs (dom, args) -> + | CallVerifs (dom, expr) -> let c' = let dom_id = Mast.DomainId.from_marked_list (Pos.unmark dom) in - let filter = - let cats = - Mir.CatVarMap.fold - (fun cv _ res -> Mir.CatVarSet.add cv res) - p.program_var_categories Mir.CatVarSet.empty - in - match args with - | [] -> (cats, Mir.CatVarSet.empty) - | [ filter ] -> filter_of_string cats filter - | arg :: _ -> - Errors.raise_spanned_error "unexpected additional argument" - (Pos.get_position arg) - in + let filter = fst (to_mpp_expr p translated_names scope expr) in Verifs (dom_id, filter) in - let new_scope = List.map Pos.unmark args in - let args' = List.map (to_scoped_var p) args in - (Call (c', args'), new_scope) + (Call (c', []), scope) | Call (c, args) -> let c' = to_mpp_callable c translated_names in let new_scope = List.map Pos.unmark args in diff --git a/src/mlang/mpp_frontend/mpp_parser.mly b/src/mlang/mpp_frontend/mpp_parser.mly index 2e28508f9..081525226 100644 --- a/src/mlang/mpp_frontend/mpp_parser.mly +++ b/src/mlang/mpp_frontend/mpp_parser.mly @@ -48,14 +48,23 @@ ident_list: %inline domain_args: | dom = ident_list { dom, [] } | dom = ident_list COMMA args = separated_list(COMMA, ident) { dom, args } +; + +%inline domain_expr: +| dom = ident_list + { + let no_pos e = (e, Pos.no_pos) in + let true_expr = no_pos (Binop (no_pos (Constant 0), Eq, no_pos (Constant 0))) in + dom, true_expr + } +| dom = ident_list COMMA expr = expr { dom, expr } +; stmt: | args = separated_list(COMMA, ident) LEFTARROW CALL_M_RULES LPAREN dom = ident_list RPAREN NEWLINE { Expr(CallRules(dom, args), mk_position $sloc), mk_position $sloc } | args = separated_list(COMMA, ident) LEFTARROW CALL_M_CHAIN LPAREN chain = ident RPAREN NEWLINE { Expr(CallChain(chain :: args), mk_position $sloc), mk_position $sloc } -| args = separated_list(COMMA, ident) LEFTARROW CALL_M_VERIFS LPAREN dom = ident_list RPAREN NEWLINE - { Expr(CallVerifs(dom, args), mk_position $sloc), mk_position $sloc } | args = separated_list(COMMA, ident) LEFTARROW var = ident LPAREN RPAREN NEWLINE { Expr(Call(var, args), mk_position $sloc), mk_position $sloc } | args = separated_list(COMMA, ident) LEFTARROW var = ident LPAREN chain = ident RPAREN NEWLINE @@ -66,8 +75,8 @@ stmt: { Expr(CallRules(fst dom_args, snd dom_args), mk_position $sloc), mk_position $sloc } | CALL_M_CHAIN LPAREN args = separated_list(COMMA, ident) RPAREN NEWLINE { Expr(CallChain(args), mk_position $sloc), mk_position $sloc } -| CALL_M_VERIFS LPAREN dom_args = domain_args RPAREN NEWLINE - { Expr(CallVerifs(fst dom_args, snd dom_args), mk_position $sloc), mk_position $sloc } +| CALL_M_VERIFS LPAREN dom_expr = domain_expr RPAREN NEWLINE + { Expr(CallVerifs(fst dom_expr, snd dom_expr), mk_position $sloc), mk_position $sloc } | var = ident LPAREN args = separated_list(COMMA, ident) RPAREN NEWLINE { Expr(Call(var, args), mk_position $sloc), mk_position $sloc } | IF b = expr COLON t = new_block ELSE COLON f = new_block { Conditional(b, t, f), mk_position $sloc } diff --git a/src/mlang/mpp_ir/mpp_format.ml b/src/mlang/mpp_ir/mpp_format.ml index d3e78abbe..e171fb0c7 100644 --- a/src/mlang/mpp_ir/mpp_format.ml +++ b/src/mlang/mpp_ir/mpp_format.ml @@ -23,29 +23,6 @@ let format_scoped_var (fmt : formatter) (sv : scoped_var) : unit = | Local s -> s | Mbased (v, _) -> Pos.unmark v.Mir.Variable.name) -let format_callable (fmt : formatter) (f : mpp_callable) = - fprintf fmt "%s" - (match f with - | Rules dom -> Format.asprintf "rules(%a)" (Mast.DomainId.pp ()) dom - | Chain chain -> Format.asprintf "chain(%s)" chain - | Verifs (dom, filter) -> - let pp_filter fmt = function - | cvsIncl, cvsExcl -> - Format.fprintf fmt ",incl: %a,excl:%a" (Mir.CatVarSet.pp ()) - cvsIncl (Mir.CatVarSet.pp ()) cvsExcl - in - Format.asprintf "verifications(%a%a)" (Mast.DomainId.pp ()) dom - pp_filter filter - | NbVarCat cvs -> - Format.asprintf "nb_var_category(%a)" (Mir.CatVarSet.pp ()) cvs - | MppFunction m -> m - | Present -> "present" - | Abs -> "abs" - | Cast -> "cast" - | DepositDefinedVariables -> "DepositDefinedVariables" - | TaxbenefitCeiledVariables -> "TaxbenefitCeiledVariables" - | TaxbenefitDefinedVariables -> "TaxbenefitDefinedVariables") - let format_binop (fmt : formatter) (b : Mpp_ast.binop) : unit = fprintf fmt "%s" (match b with @@ -78,6 +55,24 @@ let rec format_expression (fmt : formatter) (expr : mpp_expr_kind Pos.marked) : fprintf fmt "(%a %a %a)" format_expression e1 format_binop b format_expression e2 +and format_callable (fmt : formatter) (f : mpp_callable) = + fprintf fmt "%s" + (match f with + | Rules dom -> Format.asprintf "rules(%a)" (Mast.DomainId.pp ()) dom + | Chain chain -> Format.asprintf "chain(%s)" chain + | Verifs (dom, filter) -> + Format.asprintf "verifications(%a%a)" (Mast.DomainId.pp ()) dom + format_expression filter + | NbVarCat cvs -> + Format.asprintf "nb_var_category(%a)" (Mir.CatVarSet.pp ()) cvs + | MppFunction m -> m + | Present -> "present" + | Abs -> "abs" + | Cast -> "cast" + | DepositDefinedVariables -> "DepositDefinedVariables" + | TaxbenefitCeiledVariables -> "TaxbenefitCeiledVariables" + | TaxbenefitDefinedVariables -> "TaxbenefitDefinedVariables") + let rec format_stmt (fmt : formatter) (stmt : mpp_stmt) : unit = match Pos.unmark stmt with | Assign (sv, e) -> diff --git a/src/mlang/mpp_ir/mpp_ir.ml b/src/mlang/mpp_ir/mpp_ir.ml index 4367be388..f57cd1750 100644 --- a/src/mlang/mpp_ir/mpp_ir.ml +++ b/src/mlang/mpp_ir/mpp_ir.ml @@ -30,20 +30,6 @@ type scoped_var = type mpp_compute_name = string -type mpp_callable = - | Rules of Mast.DomainId.t (* M codebase *) - | Chain of Mast.chaining (* M codebase *) - | Verifs of Mast.DomainId.t * (Mir.CatVarSet.t * Mir.CatVarSet.t) - | NbVarCat of Mir.CatVarSet.t - (* M codebase *) - | MppFunction of mpp_compute_name - | Present - | Abs - | Cast (* cast undefined to 0, identity function otherwise *) - | DepositDefinedVariables - | TaxbenefitCeiledVariables - | TaxbenefitDefinedVariables - type mpp_filter = VarIsTaxBenefit type unop = Minus @@ -59,6 +45,20 @@ and mpp_expr_kind = | Call of mpp_callable * scoped_var list | Binop of mpp_expr * binop * mpp_expr +and mpp_callable = + | Rules of Mast.DomainId.t (* M codebase *) + | Chain of Mast.chaining (* M codebase *) + | Verifs of Mast.DomainId.t * mpp_expr + | NbVarCat of Mir.CatVarSet.t + (* M codebase *) + | MppFunction of mpp_compute_name + | Present + | Abs + | Cast (* cast undefined to 0, identity function otherwise *) + | DepositDefinedVariables + | TaxbenefitCeiledVariables + | TaxbenefitDefinedVariables + type mpp_stmt = mpp_stmt_kind Pos.marked and mpp_stmt_kind = diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml index dfa68e74f..529f9328b 100644 --- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml +++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml @@ -193,9 +193,63 @@ let generate_verif_cond (cond : Mir.condition_data) : Bir.stmt = let data = Mir.map_cond_data_var Bir.(var_from_mir default_tgv) cond in (Bir.SVerif data, Pos.get_position data.cond_expr) +type filter_val = Int of int | Bool of bool + let generate_verif_call (m_program : Mir_interface.full_program) - (chain : Mast.DomainId.t) ((incl, excl) : Mir.CatVarSet.t * Mir.CatVarSet.t) - : Bir.stmt list = + (chain : Mast.DomainId.t) (filter : Mpp_ir.mpp_expr) : Bir.stmt list = + let rec to_filter expr cond = + match Pos.unmark expr with + | Mpp_ir.Constant i -> Int i + | Mpp_ir.Variable _ -> + Errors.raise_spanned_error "forbidden subexpression" + (Pos.get_position expr) + | Mpp_ir.Unop (Mpp_ir.Minus, e) -> begin + match to_filter e cond with + | Int i -> Int (-i) + | Bool _ -> + Errors.raise_spanned_error "integer expression expected" + (Pos.get_position e) + end + | Mpp_ir.Call (Mpp_ir.NbVarCat cvs, _) -> + let i = + Mir.CatVarSet.fold + (fun cv res -> + match Mir.CatVarMap.find_opt cv cond.Mir.cond_cats with + | Some i -> i + res + | None -> + Errors.raise_spanned_error "unknown variable category" + (Pos.get_position expr)) + cvs 0 + in + Int i + | Mpp_ir.Call (_, _) -> + Errors.raise_spanned_error "forbidden function" (Pos.get_position expr) + | Mpp_ir.Binop (e1, b, e2) -> begin + let r1 = to_filter e1 cond in + let r2 = to_filter e2 cond in + match (r1, b, r2) with + | Bool b1, Mpp_ast.And, Bool b2 -> Bool (b1 && b2) + | Bool b1, Mpp_ast.Or, Bool b2 -> Bool (b1 || b2) + | Int i1, Mpp_ast.Gt, Int i2 -> Bool (i1 > i2) + | Int i1, Mpp_ast.Gte, Int i2 -> Bool (i1 >= i2) + | Int i1, Mpp_ast.Lt, Int i2 -> Bool (i1 < i2) + | Int i1, Mpp_ast.Lte, Int i2 -> Bool (i1 <= i2) + | Int i1, Mpp_ast.Eq, Int i2 -> Bool (i1 = i2) + | Int i1, Mpp_ast.Neq, Int i2 -> Bool (i1 <> i2) + | Int _, Mpp_ast.(And | Or), _ -> + Errors.raise_spanned_error "boolean expression expected" + (Pos.get_position e1) + | _, Mpp_ast.(And | Or), Int _ -> + Errors.raise_spanned_error "boolean expression expected" + (Pos.get_position e2) + | Bool _, Mpp_ast.(Gt | Gte | Lt | Lte | Eq | Neq), _ -> + Errors.raise_spanned_error "integer expression expected" + (Pos.get_position e1) + | _, Mpp_ast.(Gt | Gte | Lt | Lte | Eq | Neq), Bool _ -> + Errors.raise_spanned_error "integer expression expected" + (Pos.get_position e2) + end + in let is_verif_relevant _ cond = (* specific restriction *) let cats = Mir.cond_cats_to_set cond.Mir.cond_cats in @@ -205,11 +259,8 @@ let generate_verif_call (m_program : Mir_interface.full_program) let is_var_compatible = Mir.CatVarSet.subset cats verif_domain.dom_data.vdom_auth in - (is_max || is_eq) && is_var_compatible - && (not - (Mir.CatVarSet.equal Mir.CatVarSet.empty - (Mir.CatVarSet.inter cats incl))) - && Mir.CatVarSet.equal Mir.CatVarSet.empty (Mir.CatVarSet.inter cats excl) + let is_kept = to_filter filter cond = Bool true in + (is_max || is_eq) && is_var_compatible && is_kept in let relevant_verifs = Mir.RuleMap.filter is_verif_relevant m_program.program.program_conds From 438b7dfc20ab3c637b68514f78c21d12173d8c62 Mon Sep 17 00:00:00 2001 From: david Date: Wed, 26 Jul 2023 19:59:14 +0200 Subject: [PATCH 20/26] =?UTF-8?q?nsformation=20de=20"non=5Fauto=5Fcc"=20en?= =?UTF-8?q?=20un=20domaine=20de=20v=C3=A9rif=20par=20d=C3=A9faut.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/backend_ir/bir_interface.ml | 2 +- src/mlang/dgfip_m.ml | 8 ++--- src/mlang/m_frontend/format_mast.ml | 6 +--- src/mlang/m_frontend/mast.ml | 5 +-- src/mlang/m_frontend/mast_to_mir.ml | 7 +--- src/mlang/m_frontend/mlexer.mll | 4 --- src/mlang/m_frontend/mparser.mly | 46 +++++++++++---------------- src/mlang/m_ir/mir.ml | 2 +- src/mlang/m_ir/mir.mli | 2 +- 9 files changed, 27 insertions(+), 55 deletions(-) diff --git a/src/mlang/backend_ir/bir_interface.ml b/src/mlang/backend_ir/bir_interface.ml index 3393ec19c..668d1473e 100644 --- a/src/mlang/backend_ir/bir_interface.ml +++ b/src/mlang/backend_ir/bir_interface.ml @@ -150,7 +150,7 @@ let translate_external_conditions var_cats idmap dom_names = [ ([], Pos.no_pos) ]; dom_parents = []; dom_by_default = true; - dom_data = { vdom_auth = [ AuthAll ]; vdom_auto_cc = false }; + dom_data = { vdom_auth = [ AuthAll ] }; }; ] in diff --git a/src/mlang/dgfip_m.ml b/src/mlang/dgfip_m.ml index b38b628c7..8e6e9b4d6 100644 --- a/src/mlang/dgfip_m.ml +++ b/src/mlang/dgfip_m.ml @@ -184,12 +184,11 @@ domaine regle corrective base_inr_r9901 let verif_domains_declaration = {| -domaine verif primitive corrective, isf corrective +domaine verif primitive corrective, isf corrective, non_auto_cc : autorise calculee *, saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, saisie variation -#: auto_cc contexte, famille, revenu, revenu corrective, variation : par_defaut; domaine verif primitive @@ -216,9 +215,7 @@ domaine verif corrective horizontale : autorise calculee *, saisie contexte, saisie famille, saisie revenu, saisie revenu corrective, - saisie variation, saisie penalite -#: auto_cc penalite -; + saisie variation, saisie penalite; |} let declarations = @@ -259,6 +256,5 @@ let string_to_rule_domain_id : string -> string list = function | "base_anterieure" -> [ "corrective"; "base_anterieure" ] | "base_anterieure_cor" -> [ "corrective"; "base_anterieure_cor" ] | "base_stratemajo" -> [ "corrective"; "base_stratemajo" ] - | "non_auto_cc" -> [] | "horizontale" -> [ "horizontale" ] | _ -> raise Not_found diff --git a/src/mlang/m_frontend/format_mast.ml b/src/mlang/m_frontend/format_mast.ml index be2a13b99..bd3392b53 100644 --- a/src/mlang/m_frontend/format_mast.ml +++ b/src/mlang/m_frontend/format_mast.ml @@ -321,11 +321,7 @@ let format_verif_domain fmt (vd : verif_domain_decl) = | AuthAll -> Format.fprintf fmt "*" in let pp_data fmt data = - Format.fprintf fmt "%a%a" - (pp_print_list_comma pp_auth) - data.vdom_auth - (format_domain_attribute "auto_cc") - data.vdom_auto_cc + Format.fprintf fmt "%a" (pp_print_list_comma pp_auth) data.vdom_auth in format_domain pp_data fmt vd diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index 325b61c88..9aab7cc6b 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -298,10 +298,7 @@ type verif_auth_decl = | AuthComputed of string Pos.marked list Pos.marked | AuthAll -type verif_domain_data = { - vdom_auth : verif_auth_decl list; - vdom_auto_cc : bool; -} +type verif_domain_data = { vdom_auth : verif_auth_decl list } type verif_domain_decl = verif_domain_data domain_decl diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index d636313f7..98bd3fe45 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -1652,12 +1652,7 @@ let get_verif_domains (cats : 'a Mir.CatVarMap.t) (p : Mast.program) : let catSet = cats_variable_from_decl_list cats decl.Mast.dom_data.vdom_auth in - let dom_data = - { - Mir.vdom_auth = catSet; - Mir.vdom_auto_cc = decl.Mast.dom_data.vdom_auto_cc; - } - in + let dom_data = { Mir.vdom_auth = catSet } in Some (decl, dom_data) | _ -> None in diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index 0c14521f0..61e42289f 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -148,10 +148,6 @@ rule token = parse { OUTPUT } | "fonction" { FONCTION } -| "auto_cc" - { AUTO_CC } -| "non_auto_cc" - { NON_AUTO_CC } | '"' [^'"']* '"' as s { STRING s } | ['a'-'z'] as s diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 9aca67692..2a86c8b21 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -49,7 +49,7 @@ along with this program. If not, see . %token COMPUTED CONST ALIAS INPUT FOR %token RULE IF THEN ELSE ENDIF ERROR VERIFICATION ANOMALY DISCORDANCE CONDITION %token INFORMATIVE OUTPUT FONCTION VARIABLE ATTRIBUT -%token DOMAIN SPECIALIZE AUTHORIZE BASE GIVEN_BACK COMPUTABLE BY_DEFAULT AUTO_CC NON_AUTO_CC +%token DOMAIN SPECIALIZE AUTHORIZE BASE GIVEN_BACK COMPUTABLE BY_DEFAULT %token EOF @@ -156,26 +156,23 @@ verif_domain_decl: | DOMAIN VERIFICATION vdom_params = separated_nonempty_list(COLON, vdom_param_with_pos) SEMICOLON { let err msg pos = Errors.raise_spanned_error msg pos in - let fold (dno, dso, dvo, dao, dpdo) = function - | Some dn, _, _, _, _, pos -> - if dno = None then Some dn, dso, dvo, dao, dpdo + let fold (dno, dso, dvo, dpdo) = function + | Some dn, _, _, _, pos -> + if dno = None then Some dn, dso, dvo, dpdo else err "verif domain names are already defined" pos - | _, Some ds, _, _, _, pos -> - if dso = None then dno, Some ds, dvo, dao, dpdo + | _, Some ds, _, _, pos -> + if dso = None then dno, Some ds, dvo, dpdo else err "verif domain specialization is already specified" pos - | _, _, Some dv, _, _, pos -> - if dvo = None then dno, dso, Some dv, dao, dpdo + | _, _, Some dv, _, pos -> + if dvo = None then dno, dso, Some dv, dpdo else err "verif domain authorization is already specified" pos - | _, _, _, Some da, _, pos -> - if dao = None then dno, dso, dvo, Some da, dpdo - else err "verif domain is already auto-consistent" pos - | _, _, _, _, Some dpd, pos -> - if dpdo = None then dno, dso, dvo, dao, Some dpd + | _, _, _, Some dpd, pos -> + if dpdo = None then dno, dso, dvo, Some dpd else err "verif domain is already defined by defaut" pos - | _, _, _, _, _, _ -> assert false + | _, _, _, _, _ -> assert false in - let init = None, None, None, None, None in - let dno, dso, dvo, dao, dpdo = List.fold_left fold init vdom_params in + let init = None, None, None, None in + let dno, dso, dvo, dpdo = List.fold_left fold init vdom_params in let dom_names = match dno with | None -> err "rule domain names must be defined" (mk_position $sloc) @@ -185,10 +182,7 @@ verif_domain_decl: dom_names; dom_parents = (match dso with None -> [] | Some ds -> ds); dom_by_default = (match dpdo with None -> false | _ -> true); - dom_data = { - vdom_auth = (match dvo with None -> [] | Some dv -> dv); - vdom_auto_cc = (match dao with None -> false | _ -> true); - }; + dom_data = { vdom_auth = (match dvo with None -> [] | Some dv -> dv) }; } } @@ -207,15 +201,13 @@ var_category_id: vdom_param_with_pos: | vdom_names = separated_nonempty_list(COMMA, symbol_list_with_pos) - { (Some vdom_names, None, None, None, None, mk_position $sloc) } + { (Some vdom_names, None, None, None, mk_position $sloc) } | SPECIALIZE vdom_parents = separated_nonempty_list(COMMA, symbol_list_with_pos) - { (None, Some vdom_parents, None, None, None, mk_position $sloc) } + { (None, Some vdom_parents, None, None, mk_position $sloc) } | AUTHORIZE vcats = separated_nonempty_list(COMMA, var_category_id) - { (None, None, Some vcats, None, None, mk_position $sloc) } -| AUTO_CC - { (None, None, None, Some (), None, mk_position $sloc) } + { (None, None, Some vcats, None, mk_position $sloc) } | BY_DEFAULT - { (None, None, None, None, Some (), mk_position $sloc) } + { (None, None, None, Some (), mk_position $sloc) } fonction: | SYMBOL COLON FONCTION SYMBOL SEMICOLON { () } @@ -412,7 +404,7 @@ verification_name: | name = SYMBOL { (name, mk_position $sloc) } verification: -| VERIFICATION NON_AUTO_CC? name = symbol_list_with_pos COLON apps = application_reference +| VERIFICATION name = symbol_list_with_pos COLON apps = application_reference SEMICOLON conds = verification_condition* { let num, verif_tag_names = let uname = Pos.unmark name in diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 6876e276f..bb7b8a2f5 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -517,7 +517,7 @@ module Error = struct let compare (var1 : t) (var2 : t) = compare var1.id var2.id end -type verif_domain_data = { vdom_auth : CatVarSet.t; vdom_auto_cc : bool } +type verif_domain_data = { vdom_auth : CatVarSet.t } type verif_domain = verif_domain_data domain diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 09a204a77..c07a61113 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -191,7 +191,7 @@ type error = { typ : Mast.error_typ; } -type verif_domain_data = { vdom_auth : CatVarSet.t; vdom_auto_cc : bool } +type verif_domain_data = { vdom_auth : CatVarSet.t } type verif_domain = verif_domain_data domain From 5aaf051675f960449d2ac1e5c9aaad5851e2b676 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 27 Jul 2023 10:44:20 +0200 Subject: [PATCH 21/26] Petit nettoyage --- src/mlang/m_frontend/mast_to_mir.ml | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 98bd3fe45..10209632b 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -1504,7 +1504,6 @@ let get_domains (cat_str : string) in Mast.DomainIdMap.fold set_max domains domains in - let domains = match by_default with | Some def_id -> let fold _ dom doms = @@ -1517,14 +1516,6 @@ let get_domains (cat_str : string) | None -> Errors.raise_error (Format.sprintf "there are no default %s domain" cat_str) - in - (* let _ = let iter id dom = let pp_ss fmt ss = let iter s = Format.fprintf - fmt "<%s> " s in Mast.DomainId.iter iter ss in let pp_sss fmt sss = let - iter ss = Format.fprintf fmt "%a, " pp_ss ss in Mast.DomainIdSet.iter iter - sss in Format.printf "XXX %a\n: min: %a\n: max: %a\n" pp_ss id pp_sss - dom.Mir.dom_min pp_sss dom.Mir.dom_max in Mast.DomainIdMap.iter iter - domains; exit 0 in *) - domains let get_rule_domains (p : Mast.program) : Mir.rule_domain Mast.DomainIdMap.t = let get_item = function From e42b8b8d331ad28caf8cd2db446d1f1ff4dc3383 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 27 Jul 2023 10:57:04 +0200 Subject: [PATCH 22/26] Indentation --- src/mlang/m_frontend/mast_to_mir.ml | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 10209632b..7993fd5fa 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -1504,18 +1504,18 @@ let get_domains (cat_str : string) in Mast.DomainIdMap.fold set_max domains domains in - match by_default with - | Some def_id -> - let fold _ dom doms = - let foldName name doms = Mast.DomainIdMap.add name dom doms in - Mast.DomainIdSet.fold foldName dom.Mir.dom_names doms - in - Mast.DomainIdMap.empty - |> Mast.DomainIdMap.fold fold domains - |> Mast.DomainIdMap.add Mast.DomainId.empty (get_dom def_id domains) - | None -> - Errors.raise_error - (Format.sprintf "there are no default %s domain" cat_str) + match by_default with + | Some def_id -> + let fold _ dom doms = + let foldName name doms = Mast.DomainIdMap.add name dom doms in + Mast.DomainIdSet.fold foldName dom.Mir.dom_names doms + in + Mast.DomainIdMap.empty + |> Mast.DomainIdMap.fold fold domains + |> Mast.DomainIdMap.add Mast.DomainId.empty (get_dom def_id domains) + | None -> + Errors.raise_error + (Format.sprintf "there are no default %s domain" cat_str) let get_rule_domains (p : Mast.program) : Mir.rule_domain Mast.DomainIdMap.t = let get_item = function From e2089e3c88dea25ba98a1847897f150af4cf9fa8 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Fri, 4 Aug 2023 15:01:49 +0200 Subject: [PATCH 23/26] Factorisation et nettoyage du code. --- .../backend_compilers/dgfip_gen_files.ml | 8 +- src/mlang/backend_ir/bir_interface.ml | 2 +- src/mlang/m_frontend/format_mast.ml | 17 +-- src/mlang/m_frontend/mast.ml | 13 +-- src/mlang/m_frontend/mast_to_mir.ml | 90 +------------- src/mlang/m_frontend/mparser.mly | 9 +- src/mlang/m_ir/mir.ml | 73 ++++++++++++ src/mlang/m_ir/mir.mli | 6 + src/mlang/mpp_frontend/mpp_ast.ml | 2 +- src/mlang/mpp_frontend/mpp_frontend.ml | 110 +----------------- src/mlang/mpp_frontend/mpp_parser.mly | 16 +-- 11 files changed, 113 insertions(+), 233 deletions(-) diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index cbc5c5638..6316e2f16 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -165,12 +165,12 @@ let consider_output is_ebcdic attribs = (* Used to generated the array names *) let subtype_name subtyp = match subtyp with - | Context -> Mast.context_category - | Family -> Mast.family_category - | Income -> Mast.income_category + | Context -> "contexte" + | Family -> "famille" + | Income -> "revenu" | CorrIncome -> "revenu_correc" | Variation -> "variation" - | Penality -> Mast.penality_category + | Penality -> "penalite" | Base -> assert false (* never used *) | Computed -> assert false (* never used *) diff --git a/src/mlang/backend_ir/bir_interface.ml b/src/mlang/backend_ir/bir_interface.ml index 668d1473e..c8c37955d 100644 --- a/src/mlang/backend_ir/bir_interface.ml +++ b/src/mlang/backend_ir/bir_interface.ml @@ -150,7 +150,7 @@ let translate_external_conditions var_cats idmap dom_names = [ ([], Pos.no_pos) ]; dom_parents = []; dom_by_default = true; - dom_data = { vdom_auth = [ AuthAll ] }; + dom_data = { vdom_auth = [ ([ ("*", Pos.no_pos) ], Pos.no_pos) ] }; }; ] in diff --git a/src/mlang/m_frontend/format_mast.ml b/src/mlang/m_frontend/format_mast.ml index bd3392b53..42c71954a 100644 --- a/src/mlang/m_frontend/format_mast.ml +++ b/src/mlang/m_frontend/format_mast.ml @@ -209,7 +209,7 @@ let format_input_attribute fmt ((n, v) : variable_attribute) = let format_input_variable fmt (v : input_variable) = Format.fprintf fmt "%a %s %a %a %a : %s%a;" format_variable_name - (Pos.unmark v.input_name) input_category + (Pos.unmark v.input_name) Mast.input_category (pp_print_list_space Format.pp_print_string) (List.map Pos.unmark v.input_category) (pp_print_list_space format_input_attribute) @@ -310,18 +310,21 @@ let format_rule_domain fmt (rd : rule_domain_decl) = let format_verif_domain fmt (vd : verif_domain_decl) = let pp_auth fmt = function - | AuthInput l -> + | ("saisie", _) :: l -> Format.fprintf fmt "saisie %a" - (pp_unmark (pp_print_list_space (pp_unmark Format.pp_print_string))) + (pp_print_list_space (pp_unmark Format.pp_print_string)) l - | AuthComputed l -> + | ("calculee", _) :: l -> Format.fprintf fmt "calculee %a" - (pp_unmark (pp_print_list_space (pp_unmark Format.pp_print_string))) + (pp_print_list_space (pp_unmark Format.pp_print_string)) l - | AuthAll -> Format.fprintf fmt "*" + | [ ("*", _) ] -> Format.fprintf fmt "*" + | _ -> assert false in let pp_data fmt data = - Format.fprintf fmt "%a" (pp_print_list_comma pp_auth) data.vdom_auth + Format.fprintf fmt "%a" + (pp_print_list_comma (pp_unmark pp_auth)) + data.vdom_auth in format_domain pp_data fmt vd diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index 9aab7cc6b..06495f4df 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -266,14 +266,6 @@ let base_category = "base" let givenback_category = "restituee" -let family_category = "famille" - -let income_category = "revenu" - -let context_category = "contexte" - -let penality_category = "penalite" - (**{2 Verification clauses}*) (** These clauses are expression refering to the variables of the program. They @@ -293,10 +285,7 @@ type verification = { verif_conditions : verification_condition Pos.marked list; } -type verif_auth_decl = - | AuthInput of string Pos.marked list Pos.marked - | AuthComputed of string Pos.marked list Pos.marked - | AuthAll +type verif_auth_decl = string Pos.marked list Pos.marked type verif_domain_data = { vdom_auth : verif_auth_decl list } diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 7993fd5fa..29663ca94 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -809,21 +809,7 @@ let get_variables_decl (p : Mast.program) let new_var_data = { var_decl_typ = - begin - match - Pos.unmark_option ivar.Mast.input_typ - with - | Some x -> Some x - | None -> - if - List.exists - (fun t -> - String.equal Mast.income_category - (Pos.unmark t)) - ivar.input_category - then Some Mast.Real - else None - end; + Pos.unmark_option ivar.Mast.input_typ; var_decl_is_table = None; var_decl_descr = Some (Pos.unmark ivar.Mast.input_description); @@ -1567,72 +1553,9 @@ let get_rule_chains (domains : Mir.rule_domain Mast.DomainIdMap.t) let cats_variable_from_decl_list cats l = let rec aux res = function | [] -> res - | Mast.AuthInput id :: t -> - let vcat = Mir.CatInput (StrSet.from_marked_list (Pos.unmark id)) in - aux (Mir.CatVarSet.add vcat res) t - | Mast.AuthComputed id :: t -> begin - match Pos.unmark id with - | [] -> - let res = - res |> Mir.CatVarSet.add (Mir.CatComputed Mir.CatCompSet.empty) - in - aux res t - | [ ("base", _) ] -> - let base = Mir.CatCompSet.singleton Mir.Base in - let res = res |> Mir.CatVarSet.add (Mir.CatComputed base) in - aux res t - | [ ("base", _); ("*", _) ] -> - let base = Mir.CatCompSet.singleton Base in - let baseAndGivenBack = base |> Mir.CatCompSet.add GivenBack in - let res = - res - |> Mir.CatVarSet.add (Mir.CatComputed base) - |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) - in - aux res t - | [ ("restituee", _) ] -> - let givenBack = Mir.CatCompSet.singleton GivenBack in - let res = Mir.CatVarSet.add (Mir.CatComputed givenBack) res in - aux res t - | [ ("restituee", _); ("*", _) ] -> - let givenBack = Mir.CatCompSet.singleton GivenBack in - let baseAndGivenBack = givenBack |> Mir.CatCompSet.add Base in - let res = - res - |> Mir.CatVarSet.add (Mir.CatComputed givenBack) - |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) - in - aux res t - | [ ("base", _); ("restituee", _) ] | [ ("restituee", _); ("base", _) ] - -> - let baseAndGivenBack = - Mir.CatCompSet.singleton Base |> Mir.CatCompSet.add GivenBack - in - let res = - res |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) - in - aux res t - | [ ("*", _) ] -> - let base = Mir.CatCompSet.singleton Base in - let givenBack = Mir.CatCompSet.singleton GivenBack in - let baseAndGivenBack = base |> Mir.CatCompSet.add GivenBack in - let res = - res - |> Mir.CatVarSet.add (Mir.CatComputed Mir.CatCompSet.empty) - |> Mir.CatVarSet.add (Mir.CatComputed base) - |> Mir.CatVarSet.add (Mir.CatComputed givenBack) - |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) - in - aux res t - | _ -> - Errors.raise_spanned_error "unlnown calculated variable category" - (Pos.get_position id) - end - | Mast.AuthAll :: t -> - let res = - Mir.CatVarMap.fold (fun c _ r -> Mir.CatVarSet.add c r) cats res - in - aux res t + | l :: t -> + let vcats = Mir.mast_to_catvars cats l in + aux (Mir.CatVarSet.union vcats res) t in aux Mir.CatVarSet.empty l @@ -1926,11 +1849,6 @@ let translate (p : Mast.program) : Mir.program = let const_map = get_constants p in let var_category_decls = get_var_categories p in let var_category_map = get_var_category_map p in - let _ = - Mir.CatVarMap.pp - (fun fmt (attrs, _) -> StrMap.pp (fun _ _ -> ()) fmt attrs) - Format.std_formatter var_category_map - in let var_decl_data, error_decls, idmap = get_variables_decl p var_category_decls const_map in diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 2a86c8b21..f9b58b20b 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -191,13 +191,10 @@ verif_domain_decl: | GIVEN_BACK { ("restituee", mk_position $sloc) } | TIMES { ("*", mk_position $sloc) } -%inline var_computed_category_list: -| l = var_computed_category* { (l, mk_position $sloc) } - var_category_id: -| INPUT l = symbol_list_with_pos { AuthInput l } -| COMPUTED l = var_computed_category_list { AuthComputed l } -| TIMES { AuthAll } +| INPUT l = symbol_with_pos+ { (("saisie", Pos.no_pos) :: l, mk_position $sloc) } +| COMPUTED l = var_computed_category* { (("calculee", Pos.no_pos) :: l, mk_position $sloc) } +| TIMES { (["*", Pos.no_pos], mk_position $sloc) } vdom_param_with_pos: | vdom_names = separated_nonempty_list(COMMA, symbol_list_with_pos) diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index bb7b8a2f5..c2ee504af 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -685,3 +685,76 @@ let find_vars_by_io (p : program) (io_to_find : io) : VariableDict.t = then VariableDict.add var acc else acc) p VariableDict.empty + +let mast_to_catvars (cats : 'a CatVarMap.t) + (l : string Pos.marked list Pos.marked) : CatVarSet.t = + let filter_cats pred = + CatVarMap.fold + (fun cv _ res -> if pred cv then CatVarSet.add cv res else res) + cats CatVarSet.empty + in + match l with + | [ ("*", _) ], _ -> filter_cats (fun _ -> true) + | [ ("saisie", _); ("*", _) ], _ -> + filter_cats (fun cv -> match cv with CatInput _ -> true | _ -> false) + | ("saisie", _) :: id, pos -> + let vcat = CatInput (StrSet.from_marked_list id) in + if CatVarMap.mem vcat cats then CatVarSet.singleton vcat + else Errors.raise_spanned_error "unknown variable category" pos + | ("calculee", _) :: id, id_pos -> begin + match id with + | [] -> CatVarSet.singleton (CatComputed CatCompSet.empty) + | [ ("base", _) ] -> + let base = CatCompSet.singleton Base in + CatVarSet.singleton (CatComputed base) + | [ ("base", _); ("*", _) ] -> + let base = CatCompSet.singleton Base in + let baseAndGivenBack = base |> CatCompSet.add GivenBack in + CatVarSet.singleton (CatComputed base) + |> CatVarSet.add (CatComputed baseAndGivenBack) + | [ ("restituee", _) ] -> + let givenBack = CatCompSet.singleton GivenBack in + CatVarSet.singleton (CatComputed givenBack) + | [ ("restituee", _); ("*", _) ] -> + let givenBack = CatCompSet.singleton GivenBack in + let baseAndGivenBack = givenBack |> CatCompSet.add Base in + CatVarSet.singleton (CatComputed givenBack) + |> CatVarSet.add (CatComputed baseAndGivenBack) + | [ ("base", _); ("restituee", _) ] | [ ("restituee", _); ("base", _) ] -> + let baseAndGivenBack = + CatCompSet.singleton Base |> CatCompSet.add GivenBack + in + CatVarSet.singleton (CatComputed baseAndGivenBack) + | [ ("*", _) ] -> + let base = CatCompSet.singleton Base in + let givenBack = CatCompSet.singleton GivenBack in + let baseAndGivenBack = base |> CatCompSet.add GivenBack in + CatVarSet.singleton (CatComputed CatCompSet.empty) + |> CatVarSet.add (CatComputed base) + |> CatVarSet.add (CatComputed givenBack) + |> CatVarSet.add (CatComputed baseAndGivenBack) + | _ -> + Errors.raise_spanned_error "unlnown calculated variable category" + id_pos + end + | _ -> assert false + +let mast_to_catvar (cats : 'a CatVarMap.t) + (l : string Pos.marked list Pos.marked) : cat_variable = + match l with + | ("saisie", _) :: id, pos -> + let vcat = CatInput (StrSet.from_marked_list id) in + if CatVarMap.mem vcat cats then vcat + else Errors.raise_spanned_error "unknown variable category" pos + | ("calculee", _) :: id, id_pos -> begin + match id with + | [] -> CatComputed CatCompSet.empty + | [ ("base", _) ] -> CatComputed (CatCompSet.singleton Base) + | [ ("restituee", _) ] -> CatComputed (CatCompSet.singleton GivenBack) + | [ ("base", _); ("restituee", _) ] | [ ("restituee", _); ("base", _) ] -> + CatComputed (CatCompSet.singleton Base |> CatCompSet.add GivenBack) + | _ -> + Errors.raise_spanned_error "unlnown calculated variable category" + id_pos + end + | _, pos -> Errors.raise_spanned_error "unknown variable category" pos diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index c07a61113..8eb6c3438 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -358,3 +358,9 @@ val find_vars_by_io : program -> io -> VariableDict.t (** Returns a VariableDict.t containing all the variables that have a given io type, only one variable per name is entered in the VariableDict.t, this function chooses the one with the highest execution number*) + +val mast_to_catvars : + 'a CatVarMap.t -> string Pos.marked list Pos.marked -> CatVarSet.t + +val mast_to_catvar : + 'a CatVarMap.t -> string Pos.marked list Pos.marked -> cat_variable diff --git a/src/mlang/mpp_frontend/mpp_ast.ml b/src/mlang/mpp_frontend/mpp_ast.ml index a2838513f..17b82d492 100644 --- a/src/mlang/mpp_frontend/mpp_ast.ml +++ b/src/mlang/mpp_frontend/mpp_ast.ml @@ -15,7 +15,7 @@ type expr = expr_kind Pos.marked and expr_kind = | Constant of int | Variable of var - | NbVarCategory of string list Pos.marked + | NbVarCategory of string Pos.marked list Pos.marked | Unop of unop * expr | CallRules of string Pos.marked list Pos.marked * var Pos.marked list | CallChain of var Pos.marked list diff --git a/src/mlang/mpp_frontend/mpp_frontend.ml b/src/mlang/mpp_frontend/mpp_frontend.ml index 35e09219c..0ce69fdd2 100644 --- a/src/mlang/mpp_frontend/mpp_frontend.ml +++ b/src/mlang/mpp_frontend/mpp_frontend.ml @@ -19,70 +19,6 @@ open Mpp_ir -let _filter_of_string (cats : Mir.CatVarSet.t) (s : string Pos.marked) : - Mir.CatVarSet.t * Mir.CatVarSet.t = - let us = Pos.unmark s in - match us with - | "saisie" -> - let incl = - Mir.CatVarSet.fold - (fun cv res -> - match cv with - | Mir.CatInput _ -> Mir.CatVarSet.add cv res - | _ -> res) - cats Mir.CatVarSet.empty - in - let excl = - Mir.CatVarSet.fold - (fun cv res -> - match cv with - | Mir.CatComputed _ -> Mir.CatVarSet.add cv res - | _ -> res) - cats Mir.CatVarSet.empty - in - (incl, excl) - | "calculee" -> - let incl = - Mir.CatVarSet.fold - (fun cv res -> - match cv with - | Mir.CatComputed _ -> Mir.CatVarSet.add cv res - | _ -> res) - cats Mir.CatVarSet.empty - in - (incl, Mir.CatVarSet.empty) - | "contexte" | "famille" | "revenu" | "penalite" -> - let incl = Mir.CatVarSet.singleton (Mir.CatInput (StrSet.singleton us)) in - let excl = - Mir.CatVarSet.fold - (fun cv res -> - match cv with - | Mir.CatComputed _ -> Mir.CatVarSet.add cv res - | _ -> res) - cats Mir.CatVarSet.empty - in - (incl, excl) - | "base" -> - let base = Mir.CatCompSet.singleton Mir.Base in - let baseAndGivenBack = Mir.CatCompSet.add Mir.GivenBack base in - let incl = - Mir.CatVarSet.singleton (Mir.CatComputed base) - |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) - in - (incl, Mir.CatVarSet.empty) - | "restituee" -> - let givenBack = Mir.CatCompSet.singleton Mir.GivenBack in - let baseAndGivenBack = Mir.CatCompSet.add Mir.Base givenBack in - let incl = - Mir.CatVarSet.singleton (Mir.CatComputed givenBack) - |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) - in - (incl, Mir.CatVarSet.empty) - | unknown -> - Errors.raise_spanned_error - (Format.sprintf "unknown variable category %s" unknown) - (Pos.get_position s) - let to_scoped_var ?(scope = Input) (p : Mir.program) (var : Mpp_ast.var Pos.marked) : scoped_var = let var_s = Pos.unmark var in @@ -120,51 +56,7 @@ let rec to_mpp_expr (p : Mir.program) (translated_names : mpp_compute_name list) p (Pos.same_pos_as v e)), scope ) | NbVarCategory l -> - let cats = - let filter_cats pred = - Mir.CatVarMap.fold - (fun cv _ res -> - if pred cv then Mir.CatVarSet.add cv res else res) - p.program_var_categories Mir.CatVarSet.empty - in - match Pos.unmark l with - | [ "*" ] -> filter_cats (fun _ -> true) - | [ "saisie"; "*" ] -> - filter_cats (fun cv -> - match cv with Mir.CatInput _ -> true | _ -> false) - | "saisie" :: strs -> - let cv = Mir.CatInput (StrSet.from_list strs) in - if Mir.CatVarMap.mem cv p.program_var_categories then - Mir.CatVarSet.singleton cv - else - Errors.raise_spanned_error "unknown variable category" - (Pos.get_position l) - | [ "calculee"; "*" ] -> - let base = Mir.CatCompSet.singleton Mir.Base in - let givenBack = Mir.CatCompSet.singleton Mir.GivenBack in - let baseAndGivenBack = Mir.CatCompSet.union base givenBack in - Mir.CatVarSet.singleton (Mir.CatComputed Mir.CatCompSet.empty) - |> Mir.CatVarSet.add (Mir.CatComputed base) - |> Mir.CatVarSet.add (Mir.CatComputed givenBack) - |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) - | [ "calculee"; "base"; "*" ] -> - let base = Mir.CatCompSet.singleton Mir.Base in - let baseAndGivenBack = Mir.CatCompSet.add Mir.GivenBack base in - Mir.CatVarSet.singleton (Mir.CatComputed base) - |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) - | [ "calculee"; "restituee"; "*" ] -> - let givenBack = Mir.CatCompSet.singleton Mir.GivenBack in - let baseAndGivenBack = Mir.CatCompSet.add Mir.Base givenBack in - Mir.CatVarSet.singleton (Mir.CatComputed givenBack) - |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) - | [ "calculee"; "base"; "restituee" ] -> - let baseAndGivenBack = - Mir.CatCompSet.singleton Mir.Base - |> Mir.CatCompSet.add Mir.GivenBack - in - Mir.CatVarSet.singleton (Mir.CatComputed baseAndGivenBack) - | _ -> assert false - in + let cats = Mir.mast_to_catvars p.program_var_categories l in (Call (NbVarCat cats, []), []) | Unop (Minus, e) -> let e', scope = to_mpp_expr p translated_names scope e in diff --git a/src/mlang/mpp_frontend/mpp_parser.mly b/src/mlang/mpp_frontend/mpp_parser.mly index 081525226..7df2a4afd 100644 --- a/src/mlang/mpp_frontend/mpp_parser.mly +++ b/src/mlang/mpp_frontend/mpp_parser.mly @@ -100,14 +100,16 @@ new_block: ; var_category: -| STAR { (["*"], mk_position $sloc) } -| INPUT STAR { (["*"], mk_position $sloc) } -| INPUT l = nonempty_list(ident) { ("saisie" :: (List.map fst l), mk_position $sloc) } -| COMPUTED STAR { (["calculee"; "*"], mk_position $sloc) } -| COMPUTED BASE STAR { (["calulee"; "base"; "*"], mk_position $sloc) } -| COMPUTED GIVEN_BACK STAR { (["calulee"; "restituee"; "*"], mk_position $sloc) } +| STAR { (["*", Pos.no_pos], mk_position $sloc) } +| INPUT STAR { (["saisie", Pos.no_pos; "*", Pos.no_pos], mk_position $sloc) } +| INPUT l = nonempty_list(ident) { (("saisie", Pos.no_pos) :: l, mk_position $sloc) } +| COMPUTED STAR { (["calculee", Pos.no_pos; "*", Pos.no_pos], mk_position $sloc) } +| COMPUTED BASE STAR + { (["calulee", Pos.no_pos; "base", Pos.no_pos; "*", Pos.no_pos], mk_position $sloc) } +| COMPUTED GIVEN_BACK STAR + { (["calulee", Pos.no_pos; "restituee", Pos.no_pos; "*", Pos.no_pos], mk_position $sloc) } | COMPUTED BASE GIVEN_BACK | COMPUTED GIVEN_BACK BASE - { (["calulee"; "base"; "restituee"], mk_position $sloc) } + { (["calulee", Pos.no_pos; "base", Pos.no_pos; "restituee", Pos.no_pos], mk_position $sloc) } ; expr: From 35a7267c536eca1c942a507e0d1ef792c9a7f3a9 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 8 Aug 2023 17:12:18 +0200 Subject: [PATCH 24/26] Supression du doublon "category" - "cats". --- src/mlang/m_frontend/mast_to_mir.ml | 14 ++------------ src/mlang/m_ir/mir.ml | 6 +----- src/mlang/m_ir/mir.mli | 3 --- src/mlang/mpp_ir/mpp_ir_to_bir.ml | 4 ++-- 4 files changed, 5 insertions(+), 22 deletions(-) diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 29663ca94..d8bc18ac1 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -721,10 +721,6 @@ let get_variables_decl (p : Mast.program) match var_decl with | Mast.ComputedVar cvar -> let cvar = Pos.unmark cvar in - let category = - Mast.computed_category - :: List.map Pos.unmark cvar.comp_category - in let cat = let comp_set = List.fold_left @@ -749,7 +745,7 @@ let get_variables_decl (p : Mast.program) cvar.Mast.comp_description (dummy_exec_number (Pos.get_position cvar.Mast.comp_name)) - ~attributes:cvar.comp_attributes ~category + ~attributes:cvar.comp_attributes ~cats:(Mir.CatVarSet.singleton cat) ~origin:None ~is_table:(Pos.unmark_option cvar.Mast.comp_table) @@ -782,10 +778,6 @@ let get_variables_decl (p : Mast.program) (new_vars, new_idmap, errors, new_out_list) | Mast.InputVar ivar -> let ivar = Pos.unmark ivar in - let category = - Mast.input_category - :: List.map Pos.unmark ivar.input_category - in let cat = let input_set = List.fold_left @@ -801,7 +793,6 @@ let get_variables_decl (p : Mast.program) (dummy_exec_number (Pos.get_position ivar.Mast.input_name)) ~attributes:ivar.input_attributes ~origin:None - ~category ~cats:(Mir.CatVarSet.singleton cat) ~is_table:None (* Input variables also have a low order *) @@ -954,8 +945,7 @@ let duplicate_var (var : Mir.Variable.t) (exec_number : Mir.execution_number) local variables *) in Mir.Variable.new_var var.name None var.descr exec_number - ~attributes:var.attributes ~origin ~category:var.category ~cats:var.cats - ~is_table:var.is_table + ~attributes:var.attributes ~origin ~cats:var.cats ~is_table:var.is_table (** Linear pass that fills [idmap] with all the variable assignments along with their execution number. *) diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index c2ee504af..d5873e9c0 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -136,7 +136,6 @@ type variable = { origin : variable option; (** If the variable is an SSA duplication, refers to the original (declared) variable *) - category : string list; cats : CatVarSet.t; is_table : int option; } @@ -157,7 +156,6 @@ module Variable = struct origin : variable option; (** If the variable is an SSA duplication, refers to the original (declared) variable *) - category : string list; cats : CatVarSet.t; is_table : int option; } @@ -172,8 +170,7 @@ module Variable = struct let new_var (name : string Pos.marked) (alias : string option) (descr : string Pos.marked) (execution_number : execution_number) ~(attributes : Mast.variable_attribute list) ~(origin : t option) - ~(category : string list) ~(cats : CatVarSet.t) ~(is_table : int option) : - t = + ~(cats : CatVarSet.t) ~(is_table : int option) : t = { name; id = fresh_id (); @@ -182,7 +179,6 @@ module Variable = struct execution_number; attributes; origin; - category; cats; is_table; } diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 8eb6c3438..dc01271c1 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -51,7 +51,6 @@ type variable = { origin : variable option; (** If the variable is an SSA duplication, refers to the original (declared) variable *) - category : string list; cats : CatVarSet.t; is_table : int option; } @@ -247,7 +246,6 @@ module Variable : sig origin : variable option; (** If the variable is an SSA duplication, refers to the original (declared) variable *) - category : string list; cats : CatVarSet.t; is_table : int option; } @@ -261,7 +259,6 @@ module Variable : sig execution_number -> attributes:Mast.variable_attribute list -> origin:variable option -> - category:string list -> cats:CatVarSet.t -> is_table:int option -> variable diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml index 529f9328b..01e8f7da6 100644 --- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml +++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml @@ -350,8 +350,8 @@ and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list) ("mpp_" ^ l, pos) None ("", pos) (Mast_to_mir.dummy_exec_number pos) - ~attributes:[] ~origin:None ~category:[] - ~cats:Mir.CatVarSet.empty ~is_table:None + ~attributes:[] ~origin:None ~cats:Mir.CatVarSet.empty + ~is_table:None |> Bir.(var_from_mir default_tgv) in let ctx = From 64a12b96e408f649fa15b750038aef6a186ea0bb Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 10 Aug 2023 13:22:25 +0200 Subject: [PATCH 25/26] =?UTF-8?q?Suppression=20des=20constructions=20m?= =?UTF-8?q?=C3=A9tiers=20ad=20hoc=20du=20MPP.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mpp_specs/2018_6_7.mpp | 9 ++- mpp_specs/2019_8_0.mpp | 9 ++- mpp_specs/2020_6_5.mpp | 9 ++- src/mlang/mpp_frontend/mpp_ast.ml | 6 +- src/mlang/mpp_frontend/mpp_frontend.ml | 25 ++++--- src/mlang/mpp_frontend/mpp_lexer.mll | 5 +- src/mlang/mpp_frontend/mpp_parser.mly | 10 ++- src/mlang/mpp_ir/mpp_format.ml | 20 +++--- src/mlang/mpp_ir/mpp_ir.ml | 12 ++-- src/mlang/mpp_ir/mpp_ir_to_bir.ml | 91 ++++++++------------------ 10 files changed, 87 insertions(+), 109 deletions(-) diff --git a/mpp_specs/2018_6_7.mpp b/mpp_specs/2018_6_7.mpp index 436642665..5eccf4a8a 100644 --- a/mpp_specs/2018_6_7.mpp +++ b/mpp_specs/2018_6_7.mpp @@ -5,10 +5,13 @@ compute_article1731bis(): PREM8_11 = 1 compute_benefits(): - if exists_deposit_defined_variables() or exists_taxbenefit_ceiled_variables(): +# do not exist in the 2018 version: 7MA,7KM,7KG +# do not exist in the 2019 version: 7QD,7QB,7QC,7CN,7QE,7QF,7QG,7QH,7LS +# do not exist in the 2020 version: 7QK,7CM,7QI,7QJ,7QL + if exists_attribute_with(acompte, 1) or exists_aliases(4BA,4BY,4BB,4BC,7CL,7LG,7QM,2DC,7QP,7QS,7QN,7QO): V_INDTEO = 1 V_CALCUL_NAPS = 1 - partition with var_is_taxbenefit: + partition with avfisc == 1: IAD11, INE, IRE <- call_m_rules(primitive) V_CALCUL_NAPS = 0 iad11 = cast(IAD11) @@ -26,7 +29,7 @@ compute_double_liquidation3(outputs): V_DIFTEOREEL = 0 PREM8_11 = 0 compute_article1731bis() - calcul_avfisc = exists_taxbenefit_defined_variables() + calcul_avfisc = exists_attribute_with(avfisc, 1) v_8ZG = 8ZG if present(8ZG) and calcul_avfisc: del 8ZG diff --git a/mpp_specs/2019_8_0.mpp b/mpp_specs/2019_8_0.mpp index b3020f08a..3dfcabdca 100644 --- a/mpp_specs/2019_8_0.mpp +++ b/mpp_specs/2019_8_0.mpp @@ -5,8 +5,11 @@ compute_article1731bis(): PREM8_11 = 1 compute_benefits(): - if exists_deposit_defined_variables() or exists_taxbenefit_ceiled_variables(): - partition with var_is_taxbenefit: +# do not exist in the 2018 version: 7MA,7KM,7KG +# do not exist in the 2019 version: 7QD,7QB,7QC,7CN,7QE,7QF,7QG,7QH,7LS +# do not exist in the 2020 version: 7QK,7CM,7QI,7QJ,7QL + if exists_attribute_with(acompte, 1) or exists_aliases(4BA,4BY,4BB,4BC,7CL,7LG,7QM,2DC,7QP,7QS,7QN,7QO): + partition with avfisc == 1: V_INDTEO = 1 V_CALCUL_NAPS = 1 IAD11, INE, IRE <- call_m_rules(primitive) @@ -26,7 +29,7 @@ compute_double_liquidation3(outputs): V_DIFTEOREEL = 0 PREM8_11 = 0 compute_article1731bis() - calcul_avfisc = exists_taxbenefit_defined_variables() + calcul_avfisc = exists_attribute_with(avfisc, 1) v_8ZG = 8ZG if present(8ZG) and calcul_avfisc: del 8ZG diff --git a/mpp_specs/2020_6_5.mpp b/mpp_specs/2020_6_5.mpp index e84cc83d8..c64313a3d 100644 --- a/mpp_specs/2020_6_5.mpp +++ b/mpp_specs/2020_6_5.mpp @@ -14,8 +14,11 @@ calcul_primitif_taux(outputs): outputs <- call_m_rules(taux) compute_benefits(): - if exists_deposit_defined_variables() or exists_taxbenefit_ceiled_variables(): - partition with var_is_taxbenefit: +# do not exist in the 2018 version: 7MA,7KM,7KG +# do not exist in the 2019 version: 7QD,7QB,7QC,7CN,7QE,7QF,7QG,7QH,7LS +# do not exist in the 2020 version: 7QK,7CM,7QI,7QJ,7QL + if exists_attribute_with(acompte, 1) or exists_aliases(4BA,4BY,4BB,4BC,7CL,7LG,7QM,2DC,7QP,7QS,7QN,7QO): + partition with avfisc == 1: V_INDTEO = 1 V_CALCUL_NAPS = 1 IAD11, INE, IRE <- calcul_primitif() @@ -35,7 +38,7 @@ compute_double_liquidation3(outputs): V_DIFTEOREEL = 0 PREM8_11 = 0 compute_article1731bis() - calcul_avfisc = exists_taxbenefit_defined_variables() + calcul_avfisc = exists_attribute_with(avfisc, 1) v_8ZG = 8ZG if present(8ZG) and calcul_avfisc: del 8ZG diff --git a/src/mlang/mpp_frontend/mpp_ast.ml b/src/mlang/mpp_frontend/mpp_ast.ml index 17b82d492..b33e22426 100644 --- a/src/mlang/mpp_frontend/mpp_ast.ml +++ b/src/mlang/mpp_frontend/mpp_ast.ml @@ -4,8 +4,6 @@ type compute_name = string type callable = string -type filter = string - type unop = Minus type binop = And | Or | Gt | Gte | Lt | Lte | Eq | Neq @@ -16,6 +14,8 @@ and expr_kind = | Constant of int | Variable of var | NbVarCategory of string Pos.marked list Pos.marked + | ExistsAttrWith of (string Pos.marked * float) + | ExistsAliases of string Pos.marked list | Unop of unop * expr | CallRules of string Pos.marked list Pos.marked * var Pos.marked list | CallChain of var Pos.marked list @@ -33,7 +33,7 @@ and stmt_kind = (* | MultiAssign of var list * expr *) (* no multiassign: all assignments performed to input scope. Multiassign-ed variables would have output scope *) - | Partition of filter * stmt list + | Partition of string Pos.marked * float * stmt list type compute = { name : compute_name; args : var list; body : stmt list } diff --git a/src/mlang/mpp_frontend/mpp_frontend.ml b/src/mlang/mpp_frontend/mpp_frontend.ml index 0ce69fdd2..526b1940b 100644 --- a/src/mlang/mpp_frontend/mpp_frontend.ml +++ b/src/mlang/mpp_frontend/mpp_frontend.ml @@ -33,9 +33,6 @@ let to_mpp_callable (cname : string Pos.marked) (translated_names : string list) | "present" -> Present | "abs" -> Abs | "cast" -> Cast - | "exists_deposit_defined_variables" -> DepositDefinedVariables - | "exists_taxbenefit_defined_variables" -> TaxbenefitDefinedVariables - | "exists_taxbenefit_ceiled_variables" -> TaxbenefitCeiledVariables | x -> if List.mem x translated_names then MppFunction x else @@ -58,6 +55,15 @@ let rec to_mpp_expr (p : Mir.program) (translated_names : mpp_compute_name list) | NbVarCategory l -> let cats = Mir.mast_to_catvars p.program_var_categories l in (Call (NbVarCat cats, []), []) + | ExistsAttrWith (attr, value) -> + (Call (ExistsAttrWithVal (attr, value), []), []) + | ExistsAliases aliases -> + let aliasMap = + List.fold_left + (fun res (name, pos) -> StrMap.add name pos res) + StrMap.empty aliases + in + (Call (ExistsAliases aliasMap, []), []) | Unop (Minus, e) -> let e', scope = to_mpp_expr p translated_names scope e in (Unop (Minus, e'), scope) @@ -101,13 +107,6 @@ let rec to_mpp_expr (p : Mir.program) (translated_names : mpp_compute_name list) in (Pos.same_pos_as e' e, scope) -let to_mpp_filter (f : string Pos.marked) : mpp_filter = - if Pos.unmark f = "var_is_taxbenefit" then VarIsTaxBenefit - else - Errors.raise_spanned_error - (Format.asprintf "unknown filter %s" (Pos.unmark f)) - (Pos.get_position f) - let rec to_mpp_stmt (p : Mir.program) (translated_names : string list) (scope : mpp_compute_name list) (stmt : Mpp_ast.stmt) : mpp_stmt * Mpp_ast.var list = @@ -128,10 +127,8 @@ let rec to_mpp_stmt (p : Mir.program) (translated_names : string list) | Expr e -> let e', scope = to_mpp_expr p translated_names scope e in (Expr e', scope) - | Partition (f, body) -> - ( Partition - ( to_mpp_filter (Pos.same_pos_as f stmt), - to_mpp_stmts p translated_names ~scope body ), + | Partition (attr, value, body) -> + ( Partition (attr, value, to_mpp_stmts p translated_names ~scope body), scope ) in (Pos.same_pos_as stmt' stmt, scope) diff --git a/src/mlang/mpp_frontend/mpp_lexer.mll b/src/mlang/mpp_frontend/mpp_lexer.mll index bb8a5ad66..9061a7394 100644 --- a/src/mlang/mpp_frontend/mpp_lexer.mll +++ b/src/mlang/mpp_frontend/mpp_lexer.mll @@ -17,7 +17,8 @@ } let space = ' ' | '\t' -let comment = "#" [^'\n']* +let comment = "#" [^'\n']* | '/' '*' ([^')'] | ')' [^'#'])* '*' '/' + let endline = '\n' | '\r' | "\r\n" let integer = ['0'-'9']+ @@ -51,6 +52,8 @@ rule next_tokens = parse | "call_m_chain" { [CALL_M_CHAIN] } | "call_m_verifs" { [CALL_M_VERIFS] } | "nb_category" { [NB_CATEGORY] } + | "exists_attribute_with" { [EXISTS_ATTRIBUTE_WITH] } + | "exists_aliases" { [EXISTS_ALIASES] } | ':' { [COLON] } | integer as i { [INT (int_of_string i)] } | ['a'-'z' 'A'-'Z' '0'-'9' '_']+ as s diff --git a/src/mlang/mpp_frontend/mpp_parser.mly b/src/mlang/mpp_frontend/mpp_parser.mly index 7df2a4afd..5314445f0 100644 --- a/src/mlang/mpp_frontend/mpp_parser.mly +++ b/src/mlang/mpp_frontend/mpp_parser.mly @@ -14,6 +14,7 @@ %token IF ELSE DELETE PARTITION COLON COMMA MINUS %token CALL_M_RULES CALL_M_CHAIN CALL_M_VERIFS %token NB_CATEGORY INPUT COMPUTED BASE GIVEN_BACK STAR +%token EXISTS_ATTRIBUTE_WITH EXISTS_ALIASES %left OR %left AND @@ -81,7 +82,8 @@ stmt: { Expr(Call(var, args), mk_position $sloc), mk_position $sloc } | IF b = expr COLON t = new_block ELSE COLON f = new_block { Conditional(b, t, f), mk_position $sloc } | IF b = expr COLON t = new_block { Conditional(b, t, []), mk_position $sloc } -| PARTITION var = IDENT COLON b = new_block { Partition(var, b), mk_position $sloc } +| PARTITION attr = ident EQUAL value = INT COLON b = new_block + { Partition (attr, float value, b), mk_position $sloc } ; new_block: @@ -115,7 +117,11 @@ var_category: expr: | i = INT { Constant i, mk_position $sloc } | NB_CATEGORY LPAREN cat = var_category RPAREN - { NbVarCategory(cat), mk_position $sloc } + { NbVarCategory (cat), mk_position $sloc } +| EXISTS_ATTRIBUTE_WITH LPAREN attr = ident COMMA value = INT RPAREN + { ExistsAttrWith (attr, float value), mk_position $sloc } +| EXISTS_ALIASES LPAREN alias = separated_list(COMMA, ident) RPAREN + { ExistsAliases (alias), mk_position $sloc } | var = IDENT { Variable var, mk_position $sloc } | MINUS e = expr { Unop(Minus, e), mk_position $sloc } | var = ident LPAREN args = separated_list(COMMA, ident) RPAREN diff --git a/src/mlang/mpp_ir/mpp_format.ml b/src/mlang/mpp_ir/mpp_format.ml index e171fb0c7..c07b856dd 100644 --- a/src/mlang/mpp_ir/mpp_format.ml +++ b/src/mlang/mpp_ir/mpp_format.ml @@ -35,10 +35,6 @@ let format_binop (fmt : formatter) (b : Mpp_ast.binop) : unit = | Eq -> "==" | Neq -> "!=") -let format_filter (fmt : formatter) (f : mpp_filter) : unit = - assert (f = VarIsTaxBenefit); - fprintf fmt "VarIsTaxBenefit" - let rec format_expression (fmt : formatter) (expr : mpp_expr_kind Pos.marked) : unit = match Pos.unmark expr with @@ -65,13 +61,17 @@ and format_callable (fmt : formatter) (f : mpp_callable) = format_expression filter | NbVarCat cvs -> Format.asprintf "nb_var_category(%a)" (Mir.CatVarSet.pp ()) cvs + | ExistsAttrWithVal ((attr, _), value) -> + Format.asprintf "exists_attribute_with(%s, %f)" attr value + | ExistsAliases aliases -> + let pp_null _ _ = () in + Format.asprintf "exists_alias(%a)" + (StrMap.pp ~sep:", " ~assoc:"" pp_null) + aliases | MppFunction m -> m | Present -> "present" | Abs -> "abs" - | Cast -> "cast" - | DepositDefinedVariables -> "DepositDefinedVariables" - | TaxbenefitCeiledVariables -> "TaxbenefitCeiledVariables" - | TaxbenefitDefinedVariables -> "TaxbenefitDefinedVariables") + | Cast -> "cast") let rec format_stmt (fmt : formatter) (stmt : mpp_stmt) : unit = match Pos.unmark stmt with @@ -85,8 +85,8 @@ let rec format_stmt (fmt : formatter) (stmt : mpp_stmt) : unit = format_expression cond format_stmts t format_stmts f | Delete sv -> fprintf fmt "del %a" format_scoped_var sv | Expr e -> format_expression fmt e - | Partition (f, body) -> - fprintf fmt "partition with %a:@\n@[ %a@]" format_filter f + | Partition ((attr, _), value, body) -> + fprintf fmt "partition with %s == %f:@\n@[ %a@]" attr value format_stmts body and format_stmts (fmt : formatter) (stmts : mpp_stmt list) : unit = diff --git a/src/mlang/mpp_ir/mpp_ir.ml b/src/mlang/mpp_ir/mpp_ir.ml index f57cd1750..976eca0fe 100644 --- a/src/mlang/mpp_ir/mpp_ir.ml +++ b/src/mlang/mpp_ir/mpp_ir.ml @@ -30,8 +30,6 @@ type scoped_var = type mpp_compute_name = string -type mpp_filter = VarIsTaxBenefit - type unop = Minus type binop = Mpp_ast.binop @@ -50,14 +48,14 @@ and mpp_callable = | Chain of Mast.chaining (* M codebase *) | Verifs of Mast.DomainId.t * mpp_expr | NbVarCat of Mir.CatVarSet.t + | ExistsAttrWithVal of string Pos.marked * float + | ExistsAliases of Pos.t StrMap.t (* M codebase *) | MppFunction of mpp_compute_name | Present | Abs - | Cast (* cast undefined to 0, identity function otherwise *) - | DepositDefinedVariables - | TaxbenefitCeiledVariables - | TaxbenefitDefinedVariables + | Cast +(* cast undefined to 0, identity function otherwise *) type mpp_stmt = mpp_stmt_kind Pos.marked @@ -66,7 +64,7 @@ and mpp_stmt_kind = | Conditional of mpp_expr * mpp_stmt list * mpp_stmt list | Delete of scoped_var | Expr of mpp_expr - | Partition of mpp_filter * mpp_stmt list + | Partition of string Pos.marked * float * mpp_stmt list type mpp_compute = { name : mpp_compute_name; diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml index 01e8f7da6..a965005f2 100644 --- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml +++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml @@ -87,66 +87,33 @@ let generate_input_condition (crit : Mir.Variable.t -> bool) (fun var acc -> mk_or (mk_call_present var) acc) variables_to_check mk_false -let var_is_ (attr : string) (v : Mir.Variable.t) : bool = +let var_is_ (attr : string) (value : float) (v : Mir.Variable.t) : bool = List.exists (fun ((attr_name, _), (attr_value, _)) -> - attr_name = attr && attr_value = Mast.Float 1.) + attr_name = attr && attr_value = Mast.Float value) v.Mir.Variable.attributes -let cond_DepositDefinedVariables : - Mir_interface.full_program -> Pos.t -> Bir.expression Pos.marked = - generate_input_condition (var_is_ "acompte") +let check_attribute (p : Mir_interface.full_program) (attr : string) : bool = + Mir.CatVarMap.exists + (fun _ (attrs, _) -> StrMap.exists (fun a _ -> a = attr) attrs) + p.Mir_interface.program.Mir.program_var_categories -let cond_TaxbenefitDefinedVariables : - Mir_interface.full_program -> Pos.t -> Bir.expression Pos.marked = - generate_input_condition (var_is_ "avfisc") +let cond_ExistsAttrWithVal (p : Mir_interface.full_program) (pos : Pos.t) + ((attr, pos_attr) : string Pos.marked) (value : float) : + Bir.expression Pos.marked = + if check_attribute p attr then + generate_input_condition (var_is_ attr value) p pos + else Errors.raise_spanned_error "unknown attribute" pos_attr -let cond_TaxbenefitCeiledVariables (p : Mir_interface.full_program) - (pos : Pos.t) : Bir.expression Pos.marked = - (* commented aliases do not exist in the 2018 version *) - (* double-commented aliases do not exist in the 2019 version *) - (* triple-commented aliases do not exist in the 2020 version *) - let aliases_list = - [ - (*(*(*"7QK";*)*)*) - (*(* "7QD"; *)*) - (*(* "7QB"; *)*) - (*(* "7QC"; *)*) - "4BA"; - "4BY"; - "4BB"; - "4BC"; - "7CL"; - (*(*(*"7CM";*)*)*) - (*(* "7CN"; *)*) - (*(* "7QE"; *)*) - (*(* "7QF"; *)*) - (*(* "7QG"; *)*) - (*(* "7QH"; *)*) - (*(*(*"7QI";*)*)*) - (*(*(*"7QJ";*)*)*) - "7LG"; - (* "7MA"; *) - "7QM"; - "2DC"; - (* "7KM"; *) - (* "7KG"; *) - "7QP"; - "7QS"; - "7QN"; - "7QO"; - (*(*(*"7QL";*)*)*) - (*(* "7LS"; *)*) - ] +let cond_ExistsAliases (p : Mir_interface.full_program) (pos : Pos.t) + (aliases : Pos.t StrMap.t) : Bir.expression Pos.marked = + let vars = + StrMap.fold + (fun var pos vmap -> + Mir.VariableMap.add (Mir.find_var_by_name p.program (var, pos)) () vmap) + aliases Mir.VariableMap.empty in - let supp_avfisc = - List.fold_left - (fun vmap var -> - Mir.VariableMap.add (Mir.find_var_by_name p.program var) () vmap) - Mir.VariableMap.empty - (List.map (fun x -> (x, Pos.no_pos)) aliases_list) - in - generate_input_condition (fun v -> Mir.VariableMap.mem v supp_avfisc) p pos + generate_input_condition (fun v -> Mir.VariableMap.mem v vars) p pos let translate_m_code (m_program : Mir_interface.full_program) (vars : (Mir.Variable.id * Mir.variable_data) list) = @@ -328,12 +295,12 @@ and translate_mpp_expr (p : Mir_interface.full_program) (ctx : translation_ctx) ( (Mast.Add, pos), (translate_mpp_expr p ctx (Mpp_ir.Variable l, pos), pos), (Mir.Literal (Float 0.), pos) ) - | Call (DepositDefinedVariables, []) -> - Pos.unmark @@ cond_DepositDefinedVariables p pos - | Call (TaxbenefitCeiledVariables, []) -> - Pos.unmark @@ cond_TaxbenefitCeiledVariables p pos - | Call (TaxbenefitDefinedVariables, []) -> - Pos.unmark @@ cond_TaxbenefitDefinedVariables p pos + | Call (ExistsAttrWithVal (attr, value), []) -> + Pos.unmark @@ cond_ExistsAttrWithVal p pos attr value + | Call (ExistsAliases aliases, []) -> + Pos.unmark @@ cond_ExistsAliases p pos aliases + | Call (NbVarCat _, []) -> + Errors.raise_spanned_error "forbidden expression" pos | _ -> assert false and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list) @@ -454,10 +421,8 @@ and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list) wrap_m_code_call m_program order ctx | Mpp_ir.Expr (Call (Verifs (dom, filter), _args), _) -> ({ ctx with verif_seen = true }, generate_verif_call m_program dom filter) - | Mpp_ir.Partition (filter, body) -> - let func_of_filter = - match filter with Mpp_ir.VarIsTaxBenefit -> var_is_ "avfisc" - in + | Mpp_ir.Partition ((attr, _), value, body) -> + let func_of_filter = var_is_ attr value in let ctx, partition_pre, partition_post = generate_partition mpp_program m_program func_args func_of_filter pos ctx From 86273f158e2c2de9ba3b97ad5a14695aa04a6bac Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 10 Aug 2023 13:35:50 +0200 Subject: [PATCH 26/26] Correction dans l'analyse du MPP. --- src/mlang/mpp_ir/mpp_ir_to_bir.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml index a965005f2..61f913579 100644 --- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml +++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml @@ -421,7 +421,9 @@ and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list) wrap_m_code_call m_program order ctx | Mpp_ir.Expr (Call (Verifs (dom, filter), _args), _) -> ({ ctx with verif_seen = true }, generate_verif_call m_program dom filter) - | Mpp_ir.Partition ((attr, _), value, body) -> + | Mpp_ir.Partition ((attr, pos_attr), value, body) -> + if not (check_attribute m_program attr) then + Errors.raise_spanned_error "unknown attribute" pos_attr; let func_of_filter = var_is_ attr value in let ctx, partition_pre, partition_post = generate_partition mpp_program m_program func_args func_of_filter pos