From cf541fee913bb76cdfcdc0cc1d3f2072b687fb32 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 10 Dec 2024 10:32:40 +0100 Subject: [PATCH 01/32] =?UTF-8?q?Ajout=20du=20mot-cl=C3=A9=20"evenement"?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/m_frontend/mlexer.mll | 1 + src/mlang/m_frontend/mparser.mly | 1 + 2 files changed, 2 insertions(+) diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index e48162414..b4f47881b 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -84,6 +84,7 @@ rule token = parse | "enchaineur" -> CHAINING | "erreur" -> ERROR | "et" -> AND + | "evenement" -> EVENT | "exporte_erreurs" -> EXPORT_ERRORS | "faire" -> DO | "finalise_erreurs" -> FINALIZE_ERRORS diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 34968f67f..0a113882a 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -58,6 +58,7 @@ along with this program. If not, see . %token INFORMATIVE OUTPUT FONCTION VARIABLE ATTRIBUT %token BASE GIVEN_BACK COMPUTABLE BY_DEFAULT %token DOMAIN SPECIALIZE AUTHORIZE VERIFIABLE +%token EVENT %token EOF From 8d2cee7610f71803c667cf0129ddf7fcf6191909 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 12 Dec 2024 10:42:10 +0100 Subject: [PATCH 02/32] =?UTF-8?q?D=C3=A9claration=20des=20=C3=A9v=C3=A9nem?= =?UTF-8?q?ents?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/dgfip_m.ml | 14 +++++++ src/mlang/dgfip_m.mli | 2 + src/mlang/driver.ml | 22 ++++++----- src/mlang/m_frontend/check_validity.ml | 49 ++++++++++++++++++++++++- src/mlang/m_frontend/check_validity.mli | 3 ++ src/mlang/m_frontend/expand_macros.ml | 4 +- src/mlang/m_frontend/format_mast.ml | 8 ++++ src/mlang/m_frontend/mast.ml | 1 + src/mlang/m_frontend/mast_to_mir.ml | 2 + src/mlang/m_frontend/mlexer.mll | 1 + src/mlang/m_frontend/mparser.mly | 15 +++++++- src/mlang/m_ir/com.ml | 2 + src/mlang/m_ir/com.mli | 2 + src/mlang/m_ir/mir.ml | 2 + src/mlang/m_ir/mir.mli | 2 + 15 files changed, 116 insertions(+), 13 deletions(-) diff --git a/src/mlang/dgfip_m.ml b/src/mlang/dgfip_m.ml index a7682f8c1..016b19f68 100644 --- a/src/mlang/dgfip_m.ml +++ b/src/mlang/dgfip_m.ml @@ -229,6 +229,20 @@ let declarations = Format.sprintf "%s%s%s" variable_domains_declaration rule_domains_declaration verif_domains_declaration +let event_declaration = + {| +evenement +: valeur date +: valeur rappel +: variable code +: valeur change +: valeur direction +: valeur penalite +: valeur base_tolerance_legale +: valeur mois_jour +: valeur decl_2042_rect; +|} + let string_to_rule_domain_id : string -> string list = function | "primitif" -> [ "primitive" ] | "corrective" -> [ "corrective" ] diff --git a/src/mlang/dgfip_m.mli b/src/mlang/dgfip_m.mli index 4ab7d2230..530928148 100644 --- a/src/mlang/dgfip_m.mli +++ b/src/mlang/dgfip_m.mli @@ -8,4 +8,6 @@ val verif_domains_declaration : string val declarations : string +val event_declaration : string + val string_to_rule_domain_id : string -> string list diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index 2eba473ca..0d6eb92e8 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -151,18 +151,22 @@ let driver (files : string list) (application_names : string list) let current_progress, finish = Cli.create_progress_bar "Parsing" in let m_program = ref [] in if not without_dgfip_m then ( - let filebuf = Lexing.from_string Dgfip_m.declarations in current_progress Dgfip_m.internal_m; - let filebuf = - { - filebuf with - lex_curr_p = - { filebuf.lex_curr_p with pos_fname = Dgfip_m.internal_m }; - } + let internal_command str = + let filebuf = + let buf = Lexing.from_string str in + { + buf with + lex_curr_p = { buf.lex_curr_p with pos_fname = Dgfip_m.internal_m }; + } + in + Mparser.source_file token filebuf in try - let commands = Mparser.source_file token filebuf in - m_program := commands :: !m_program + let first_commands = internal_command Dgfip_m.declarations in + m_program := first_commands :: !m_program; + let last_commands = internal_command Dgfip_m.event_declaration in + m_program := !m_program @ [ last_commands ] with Mparser.Error -> Errors.raise_error (Format.sprintf "M\n syntax error in %s" Dgfip_m.internal_m)); diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index 2eacf6dfc..ed1519a05 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -295,6 +295,20 @@ module Err = struct let is_base_function fn pos = let msg = Format.sprintf "function %s already exist as base function" fn in Errors.raise_spanned_error msg pos + + let event_already_declared old_pos pos = + let msg = + Format.asprintf "event fields are already declared at %a" + Pos.format_position old_pos + in + Errors.raise_spanned_error msg pos + + let event_field_already_declared name old_pos pos = + let msg = + Format.asprintf "event field \"%s\" is already declared at %a" name + Pos.format_position old_pos + in + Errors.raise_spanned_error msg pos end type syms = Com.DomainId.t Pos.marked Com.DomainIdMap.t @@ -342,6 +356,9 @@ type program = { prog_var_cats : Com.CatVar.data Com.CatVar.Map.t; prog_vars : Com.Var.t StrMap.t; prog_alias : Com.Var.t StrMap.t; + prog_event_fields : Com.event_field StrMap.t; + prog_event_field_idxs : string IntMap.t; + prog_event_pos : Pos.t; prog_errors : Com.Error.t StrMap.t; prog_rdoms : Com.rule_domain_data doms; prog_rdom_syms : syms; @@ -417,6 +434,9 @@ let empty_program (p : Mast.program) main_target = prog_chainings = StrMap.empty; prog_var_cats = Com.CatVar.Map.empty; prog_vars = StrMap.empty; + prog_event_fields = StrMap.empty; + prog_event_field_idxs = IntMap.empty; + prog_event_pos = Pos.no_pos; prog_alias = StrMap.empty; prog_errors = StrMap.empty; prog_rdoms = Com.DomainIdMap.empty; @@ -631,6 +651,32 @@ let check_var_decl (var_decl : Mast.variable_decl) (prog : program) : program = in check_global_var var prog +let check_event_decl (evt_decl : Com.event_field list) (decl_pos : Pos.t) + (prog : program) : program = + if not (StrMap.is_empty prog.prog_event_fields) then + Err.event_already_declared prog.prog_event_pos decl_pos; + let prog_event_fields = + let fold (map, index) (ef : Com.event_field) = + let name = Pos.unmark ef.name in + match StrMap.find_opt name map with + | None -> + let map = StrMap.add name { ef with index } map in + let index = index + 1 in + (map, index) + | Some old_ef -> + let old_pos = Pos.get_position old_ef.name in + let name_pos = Pos.get_position ef.name in + Err.event_field_already_declared name old_pos name_pos + in + fst (List.fold_left fold (StrMap.empty, 0) evt_decl) + in + let prog_event_field_idxs = + let fold name (ef : Com.event_field) map = IntMap.add ef.index name map in + StrMap.fold fold prog_event_fields IntMap.empty + in + let prog_event_pos = decl_pos in + { prog with prog_event_fields; prog_event_field_idxs; prog_event_pos } + let check_error (error : Mast.error_) (prog : program) : program = let famille = List.nth error.error_descr 0 in let code_bo = List.nth error.error_descr 1 in @@ -2488,13 +2534,14 @@ let proceed (p : Mast.program) (main_target : string) : program = List.fold_left (fun prog source_file -> List.fold_left - (fun prog (item, _pos_item) -> + (fun prog (item, pos_item) -> match item with | Mast.Application (name, pos) -> check_application name pos prog | Mast.Chaining ((name, pos), m_apps) -> check_chaining name pos m_apps prog | Mast.VarCatDecl (decl, pos) -> check_var_category decl pos prog | Mast.VariableDecl var_decl -> check_var_decl var_decl prog + | Mast.EventDecl evt_decl -> check_event_decl evt_decl pos_item prog | Mast.Error error -> check_error error prog | Mast.Func -> prog (* unused *) | Mast.Output _ -> prog (* unused *) diff --git a/src/mlang/m_frontend/check_validity.mli b/src/mlang/m_frontend/check_validity.mli index bd12bfbe2..bf50ddd13 100644 --- a/src/mlang/m_frontend/check_validity.mli +++ b/src/mlang/m_frontend/check_validity.mli @@ -57,6 +57,9 @@ type program = { prog_var_cats : Com.CatVar.data Com.CatVar.Map.t; prog_vars : Com.Var.t StrMap.t; prog_alias : Com.Var.t StrMap.t; + prog_event_fields : Com.event_field StrMap.t; + prog_event_field_idxs : string IntMap.t; + prog_event_pos : Pos.t; prog_errors : Com.Error.t StrMap.t; prog_rdoms : Com.rule_domain_data doms; prog_rdom_syms : syms; diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index 5b00c523e..8da2127a3 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -243,8 +243,8 @@ let elim_unselected_apps (p : Mast.program) : Mast.program = (Mast.Function target, pos_item) :: prog_file in (apps_env, prog_file) - | VariableDecl _ | Error _ | Output _ | Func | VarCatDecl _ - | RuleDomDecl _ | VerifDomDecl _ -> + | VariableDecl _ | EventDecl _ | Error _ | Output _ | Func + | VarCatDecl _ | RuleDomDecl _ | VerifDomDecl _ -> (apps_env, source_item :: prog_file)) (apps_env, []) source_file in diff --git a/src/mlang/m_frontend/format_mast.ml b/src/mlang/m_frontend/format_mast.ml index bac84679b..04c9edf47 100644 --- a/src/mlang/m_frontend/format_mast.ml +++ b/src/mlang/m_frontend/format_mast.ml @@ -45,6 +45,13 @@ let format_var_category_id fmt (vd : var_category_id) = | [ ("*", _) ] -> Format.fprintf fmt "*" | _ -> assert false +let format_event_decl fmt el = + let pp_field fmt (ef : Com.event_field) = + let ef_type = if ef.is_var then "variable" else "valeur" in + Format.fprintf fmt "%s %s" ef_type (Pos.unmark ef.name) + in + Format.fprintf fmt "evenement : %a;" (Pp.list " : " pp_field) el + let format_instruction fmt i = Com.format_instruction format_variable Pp.string fmt i @@ -191,6 +198,7 @@ let format_source_file_item fmt (i : source_file_item) = (Pp.list_space (Pp.unmark format_application)) apps | VariableDecl vd -> format_variable_decl fmt vd + | EventDecl el -> format_event_decl fmt el | Function t -> format_target fmt t | Rule r -> format_rule fmt r | Target t -> format_target fmt t diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index c0d56d79c..58e3511ad 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -213,6 +213,7 @@ type source_file_item = | Application of application Pos.marked (** Declares an application *) | Chaining of chaining Pos.marked * application Pos.marked list | VariableDecl of variable_decl + | EventDecl of Com.event_field list | Function of target | Rule of rule | Target of target diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 1d5b5f0f6..a635bdb88 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -471,6 +471,8 @@ let translate (p : Mast.program) (main_target : string) : Mir.program = program_rule_domains = prog.prog_rdoms; program_verif_domains = prog.prog_vdoms; program_vars = var_data; + program_event_fields = prog.prog_event_fields; + program_event_field_idxs = prog.prog_event_field_idxs; program_rules = rules; program_verifs = verifs; program_chainings = chainings; diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index b4f47881b..d2cedccb4 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -128,6 +128,7 @@ rule token = parse | "temporaire" -> TEMPORARY | "type" -> TYPE | "un" -> ONE + | "valeur" -> VALUE | "variable" -> VARIABLE | "verif" -> VERIFICATION | "verifiable" -> VERIFIABLE diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 0a113882a..73798d7b5 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -58,7 +58,7 @@ along with this program. If not, see . %token INFORMATIVE OUTPUT FONCTION VARIABLE ATTRIBUT %token BASE GIVEN_BACK COMPUTABLE BY_DEFAULT %token DOMAIN SPECIALIZE AUTHORIZE VERIFIABLE -%token EVENT +%token EVENT VALUE %token EOF @@ -104,6 +104,7 @@ source_file_item: | al = application_etc { al } | cl = chaining_etc { cl } | cl = var_category_decl_etc { cl } +| el = event_decl_etc { el } | crl = rule_domain_decl_etc { crl } | cvl = verif_domain_decl_etc { cvl } | ol = output_etc { ol } @@ -128,6 +129,18 @@ var_category_decl: { var_type; var_category; var_attributes } } +event_decl_etc: +| e = with_pos(event_decl) l = with_pos(symbol_colon_etc)* { + Pos.same_pos_as (EventDecl (Pos.unmark e)) e :: l + } + +event_field: +| VARIABLE name = symbol_with_pos { Com.{name; is_var = true; index = 0} } +| VALUE name = symbol_with_pos { Com.{name; is_var = false; index = 0} } + +event_decl: +| EVENT COLON el = separated_nonempty_list(COLON, event_field) SEMICOLON { el } + rule_domain_decl_etc: | cr =with_pos(rule_domain_decl) l = with_pos(symbol_colon_etc)* { cr :: l } diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 3ac20e92a..9afaffb6d 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -291,6 +291,8 @@ module Var = struct let compare_name n0 n1 = !compare_name_ref n0 n1*) end +type event_field = { name : string Pos.marked; index : int; is_var : bool } + module DomainId = StrSet module DomainIdSet = struct diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index e106eafe4..3c11ef3d1 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -150,6 +150,8 @@ module Var : sig val compare_name : string -> string -> int*) end +type event_field = { name : string Pos.marked; index : int; is_var : bool } + module DomainId : StrSet.T module DomainIdSet : diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index c1d68bc70..08576b299 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -66,6 +66,8 @@ type program = { program_rule_domains : Com.rule_domain Com.DomainIdMap.t; program_verif_domains : Com.verif_domain Com.DomainIdMap.t; program_vars : Com.Var.t StrMap.t; + program_event_fields : Com.event_field StrMap.t; + program_event_field_idxs : string IntMap.t; program_rules : string IntMap.t; program_verifs : string IntMap.t; program_chainings : string StrMap.t; diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 1674a879e..901e0817d 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -56,6 +56,8 @@ type program = { program_rule_domains : Com.rule_domain Com.DomainIdMap.t; program_verif_domains : Com.verif_domain Com.DomainIdMap.t; program_vars : Com.Var.t StrMap.t; + program_event_fields : Com.event_field StrMap.t; + program_event_field_idxs : string IntMap.t; program_rules : string IntMap.t; program_verifs : string IntMap.t; program_chainings : string StrMap.t; From 9812acded8f4c5bbfc7f09c8d237a87e0654b842 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 12 Dec 2024 15:55:57 +0100 Subject: [PATCH 03/32] =?UTF-8?q?=C3=89v=C3=A9nements=20pour=20l'interpr?= =?UTF-8?q?=C3=A9teur?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/dgfip_m.ml | 12 +-- src/mlang/m_ir/com.ml | 2 + src/mlang/m_ir/com.mli | 2 + src/mlang/m_ir/mir_interpreter.ml | 25 +++++- src/mlang/m_ir/mir_interpreter.mli | 1 + src/mlang/test_framework/test_interpreter.ml | 81 +++++++++++++++++--- 6 files changed, 106 insertions(+), 17 deletions(-) diff --git a/src/mlang/dgfip_m.ml b/src/mlang/dgfip_m.ml index 016b19f68..d82d3eaca 100644 --- a/src/mlang/dgfip_m.ml +++ b/src/mlang/dgfip_m.ml @@ -232,15 +232,15 @@ let declarations = let event_declaration = {| evenement -: valeur date +: valeur numero : valeur rappel : variable code -: valeur change -: valeur direction +: valeur montant +: valeur sens : valeur penalite -: valeur base_tolerance_legale -: valeur mois_jour -: valeur decl_2042_rect; +: valeur base_tl +: valeur date +: valeur 2042_rect; |} let string_to_rule_domain_id : string -> string list = function diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 9afaffb6d..3f20a12f4 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -293,6 +293,8 @@ end type event_field = { name : string Pos.marked; index : int; is_var : bool } +type event_value = Numeric of float option | RefVar of string + module DomainId = StrSet module DomainIdSet = struct diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 3c11ef3d1..420d52ad3 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -152,6 +152,8 @@ end type event_field = { name : string Pos.marked; index : int; is_var : bool } +type event_value = Numeric of float option | RefVar of string + module DomainId : StrSet.T module DomainIdSet : diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index bb0dd080e..cfd692119 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -861,8 +861,8 @@ let prepare_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : unit = | _ -> () let evaluate_program (p : Mir.program) (inputs : Com.literal Com.Var.Map.t) - (sort : Cli.value_sort) (roundops : Cli.round_ops) : - float option StrMap.t * StrSet.t = + (events : Com.event_value IntMap.t list) (sort : Cli.value_sort) + (roundops : Cli.round_ops) : float option StrMap.t * StrSet.t = prepare_interp sort roundops; let module Interp = (val get_interp sort roundops : S) in let ctx = Interp.empty_ctx p in @@ -882,6 +882,27 @@ let evaluate_program (p : Mir.program) (inputs : Com.literal Com.Var.Map.t) in StrMap.fold fold p.program_vars StrMap.empty in + let _eventMap = + let fold (map, idx) (evt : Com.event_value IntMap.t) = + let foldEvt id ev map = + match IntMap.find_opt id p.program_event_field_idxs with + | Some fname -> ( + match StrMap.find_opt fname p.program_event_fields with + | Some ef -> ( + match (ev, ef.is_var) with + | Com.Numeric _, false | Com.RefVar _, true -> + StrMap.add fname ev map + | _ -> Errors.raise_error "Wrong event field type") + | None -> Errors.raise_error "Wrong event field") + | None -> + Errors.raise_error + (Format.sprintf "Too much event fields: index %d for size %d" id + (IntMap.cardinal p.program_event_field_idxs)) + in + (IntMap.add idx (IntMap.fold foldEvt evt StrMap.empty) map, idx + 1) + in + fst (List.fold_left fold (IntMap.empty, 0) events) + in let anoSet = let fold res (e, _) = StrSet.add (Pos.unmark e.Com.Error.name) res in List.fold_left fold StrSet.empty ctx.ctx_exported_anos diff --git a/src/mlang/m_ir/mir_interpreter.mli b/src/mlang/m_ir/mir_interpreter.mli index 8a087b81c..edc70dfc0 100644 --- a/src/mlang/m_ir/mir_interpreter.mli +++ b/src/mlang/m_ir/mir_interpreter.mli @@ -156,6 +156,7 @@ val get_interp : Cli.value_sort -> Cli.round_ops -> (module S) val evaluate_program : Mir.program -> Com.literal Com.Var.Map.t -> + Com.event_value IntMap.t list -> Cli.value_sort -> Cli.round_ops -> float option StrMap.t * StrSet.t diff --git a/src/mlang/test_framework/test_interpreter.ml b/src/mlang/test_framework/test_interpreter.ml index 189e412f8..1875a4450 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -20,8 +20,9 @@ let find_var_of_name (p : Mir.program) (name : string Pos.marked) : Com.Var.t = StrMap.find name p.program_vars let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : - float StrMap.t * StrSet.t * Com.literal Com.Var.Map.t = - let input_file = + (Com.literal Com.Var.Map.t * float StrMap.t * StrSet.t) + * (Com.event_value IntMap.t list * float StrMap.t * StrSet.t) option = + let inputVars = let ancsded = find_var_of_name program ("V_ANCSDED", Pos.no_pos) in let ancsded_val = Com.Float (float_of_int (!Cli.income_year + 1)) in List.fold_left @@ -36,18 +37,74 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : (Com.Var.Map.one ancsded ancsded_val) t.prim.entrees in - let expectedVars = + let eventsList rappels = + let fromDirection = function + | "R" -> Some 0.0 + | "C" -> Some 1.0 + | "M" -> Some 2.0 + | "P" -> Some 3.0 + | s -> + Cli.error_print "Sens du rappel: %s, devrait être parmi R, C, M et P" + s; + raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) + in + let fromPenalty = function + | None -> None + | Some p when 0 <= p && p <= 99 -> Some (float p) + | Some p -> + Cli.error_print "Code de pénalité: %d, devrait être entre 0 et 99" p; + raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) + in + let from_2042_rect = function + | None -> None + | Some 0 -> Some 0.0 + | Some 1 -> Some 1.0 + | Some r -> + Cli.error_print + "Indicateur de déclaration rectificative: %d, devrait être 0 ou 1" r; + raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) + in + let toEvent (rappel : Irj_ast.rappel) = + IntMap.empty + |> IntMap.add 0 (Com.Numeric (Some (float rappel.event_nb))) + |> IntMap.add 1 (Com.Numeric (Some (float rappel.rappel_nb))) + |> IntMap.add 2 (Com.RefVar rappel.variable_code) + |> IntMap.add 3 (Com.Numeric (Some (float rappel.change_value))) + |> IntMap.add 4 (Com.Numeric (fromDirection rappel.direction)) + |> IntMap.add 5 (Com.Numeric (fromPenalty rappel.penalty_code)) + |> IntMap.add 6 + (Com.Numeric (Option.map float rappel.base_tolerance_legale)) + |> IntMap.add 7 (Com.Numeric (Some (float rappel.month_year))) + |> IntMap.add 8 (Com.Numeric (from_2042_rect rappel.decl_2042_rect)) + in + List.map toEvent rappels + in + let expectedVars vars_init = let fold res ((var, _), (value, _)) = let fVal = match value with Irj_ast.I i -> float i | Irj_ast.F f -> f in StrMap.add var fVal res in - List.fold_left fold StrMap.empty t.prim.resultats_attendus + List.fold_left fold StrMap.empty vars_init in - let expectedAnos = + let expectedAnos anos_init = let fold res ano = StrSet.add ano res in - List.fold_left fold StrSet.empty (List.map fst t.prim.controles_attendus) + List.fold_left fold StrSet.empty (List.map fst anos_init) in - (expectedVars, expectedAnos, input_file) + let prim = + ( inputVars, + expectedVars t.prim.resultats_attendus, + expectedAnos t.prim.controles_attendus ) + in + let corr = + match t.rapp with + | None -> None + | Some rapp -> + Some + ( eventsList rapp.entrees_rappels, + expectedVars rapp.resultats_attendus, + expectedAnos rapp.controles_attendus ) + in + (prim, corr) exception InterpError of int @@ -56,12 +113,18 @@ let check_test (program : Mir.program) (test_name : string) Cli.debug_print "Parsing %s..." test_name; let t = Irj_file.parse_file test_name in Cli.debug_print "Running test %s..." t.nom; - let expVars, expAnos, input_file = to_MIR_function_and_inputs program t in + let (inputVars, expVars, expAnos), evtDatas = + to_MIR_function_and_inputs program t + in + let events = + match evtDatas with None -> [] | Some (events, _, _) -> events + in Cli.debug_print "Executing program"; (* Cli.debug_print "Combined Program (w/o verif conds):@.%a@." Format_bir.format_program program; *) let varMap, anoSet = - Mir_interpreter.evaluate_program program input_file value_sort round_ops + Mir_interpreter.evaluate_program program inputVars events value_sort + round_ops in let check_vars exp vars = let test_error_margin = 0.01 in From d9d85eb919f224dc268fd609491cd9bb61091911 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 17 Dec 2024 16:22:11 +0100 Subject: [PATCH 04/32] =?UTF-8?q?=C3=89v=C3=A9nements=20pour=20le=20backen?= =?UTF-8?q?d=20C?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mlang-deps | 2 +- .../backend_compilers/dgfip_gen_files.ml | 20 +++++++++++++++++-- 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/mlang-deps b/mlang-deps index f7cd952e3..982183a94 160000 --- a/mlang-deps +++ b/mlang-deps @@ -1 +1 @@ -Subproject commit f7cd952e3200ebac6b413da56c4b84776573df41 +Subproject commit 982183a94932165c46269bd3c22db9657e9e6ef3 diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index 72b730196..d79f345b7 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -298,7 +298,7 @@ extern void aff_val(const char *nom, const T_irdata *irdata, int indice, int niv #endif /* FLG_TRACE */ |} -let gen_const fmt = +let gen_const fmt (cprog : Mir.program) = Format.fprintf fmt {|#define FALSE 0 #define TRUE 1 @@ -389,6 +389,22 @@ typedef struct S_irdata T_irdata; /*#define IT_ irdata->info_tmps*/ /*#define IR_ irdata->info_ref*/ +struct S_event { +|}; + IntMap.iter + (fun _idx fname -> + let field = StrMap.find fname cprog.program_event_fields in + if field.is_var then + Format.fprintf fmt " T_varinfo *field_%s_var;\n" fname + else ( + Format.fprintf fmt " char field_%s_def;\n" fname; + Format.fprintf fmt " double field_%s_val;\n" fname)) + cprog.program_event_field_idxs; + Format.fprintf fmt + {|}; + +typedef struct S_event T_event; + #define EST_SAISIE 0x00000 #define EST_CALCULEE 0x04000 #define EST_BASE 0x08000 @@ -616,7 +632,7 @@ let gen_mlang_h fmt cprog flags stats_varinfos = pr "\n"; gen_decl_varinfos fmt cprog stats_varinfos; pr "\n"; - gen_const fmt; + gen_const fmt cprog; pr "\n"; (* The debug functions need T_irdata to be defined so we put them after *) gen_dbg fmt; From ad51e693fd0fffd9416c5c5ba9d6d53b93b08542 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Mon, 13 Jan 2025 22:22:52 +0100 Subject: [PATCH 05/32] =?UTF-8?q?It=C3=A9rateurs=20num=C3=A9rique=20(insta?= =?UTF-8?q?ble).?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/m_frontend/check_validity.ml | 582 +++++++++++++++---------- src/mlang/m_frontend/expand_macros.ml | 11 + src/mlang/m_frontend/mast.ml | 1 + src/mlang/m_frontend/mparser.mly | 37 +- src/mlang/m_ir/com.ml | 14 + src/mlang/m_ir/com.mli | 4 + src/mlang/m_ir/mir.ml | 12 + src/mlang/m_ir/mir.mli | 1 + 8 files changed, 421 insertions(+), 241 deletions(-) diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index ed1519a05..c55116375 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -458,6 +458,7 @@ let empty_program (p : Mast.program) main_target = nb_vars = 0; nb_all_tmps = 0; nb_all_refs = 0; + nb_all_itval = 0; sz_calculated = 0; sz_base = 0; sz_input = 0; @@ -803,238 +804,6 @@ let check_verif_dom_decl (decl : Mast.verif_domain_decl) (prog : program) : let doms, syms = check_domain Verif decl dom_data doms_syms in { prog with prog_vdoms = doms; prog_vdom_syms = syms } -let complete_vars (prog : program) : program = - let prog_vars = prog.prog_vars in - let prog_vars = - let incr_cpt cat cpt = - let i = Com.CatVar.Map.find cat cpt in - let cpt = Com.CatVar.Map.add cat (i + 1) cpt in - (cpt, i) - in - let cat_cpt = Com.CatVar.Map.map (fun _ -> 0) prog.prog_var_cats in - let prog_vars, _ = - StrMap.fold - (fun vn (var : Com.Var.t) (res, cpt) -> - let tgv = Com.Var.tgv var in - let dcat = Com.CatVar.Map.find tgv.cat prog.prog_var_cats in - let cpt, i = incr_cpt tgv.cat cpt in - let loc = Com.set_loc_tgv_cat var.loc dcat.loc dcat.id_str i in - let var = Com.Var.{ var with loc } in - let res = StrMap.add vn var res in - (res, cpt)) - prog_vars (StrMap.empty, cat_cpt) - in - prog_vars - in - let module CatLoc = struct - type t = Com.CatVar.loc - - let pp fmt (loc : t) = - match loc with - | Com.CatVar.LocComputed -> Format.fprintf fmt "calculee" - | Com.CatVar.LocBase -> Format.fprintf fmt "base" - | Com.CatVar.LocInput -> Format.fprintf fmt "saisie" - - let compare x y = compare x y - end in - let module CatLocMap = struct - include MapExt.Make (CatLoc) - - let _pp ?(sep = ", ") ?(pp_key = CatLoc.pp) ?(assoc = " => ") - (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) - (map : 'a t) : unit = - pp ~sep ~pp_key ~assoc pp_val fmt map - end in - let loc_vars, sz_loc_vars, sz_vars = - let fold _ (var : Com.Var.t) (loc_vars, sz_loc_vars, n) = - let var = Com.Var.{ var with loc = Com.set_loc_int var.loc n } in - let loc_cat = - (Com.CatVar.Map.find (Com.Var.cat var) prog.prog_var_cats).loc - in - let loc_vars = - let upd = function - | None -> Some (Com.Var.Set.one var) - | Some set -> Some (Com.Var.Set.add var set) - in - CatLocMap.update loc_cat upd loc_vars - in - let sz = Com.Var.size var in - let sz_loc_vars = - let upd = function - | None -> Some sz - | Some n_loc -> Some (n_loc + sz) - in - CatLocMap.update loc_cat upd sz_loc_vars - in - (loc_vars, sz_loc_vars, n + sz) - in - StrMap.fold fold prog_vars (CatLocMap.empty, CatLocMap.empty, 0) - in - let update_loc (var : Com.Var.t) (vars, n) = - let loc = Com.set_loc_tgv_idx var.loc n in - let vars = - StrMap.add (Com.Var.name_str var) Com.Var.{ var with loc } vars - in - (vars, n + Com.Var.size var) - in - let prog_vars = - CatLocMap.fold - (fun _loc_cat vars prog_vars -> - (prog_vars, 0) |> Com.Var.Set.fold update_loc vars |> fst) - loc_vars StrMap.empty - in - let nb_loc loc_cat = - match CatLocMap.find_opt loc_cat loc_vars with - | Some set -> Com.Var.Set.cardinal set - | None -> 0 - in - let sz_loc loc_cat = - match CatLocMap.find_opt loc_cat sz_loc_vars with - | Some sz -> sz - | None -> 0 - in - let prog_targets = - let rec aux nbRef = function - | [] -> nbRef - | (instr, _) :: il -> ( - match instr with - | Com.IfThenElse (_, ilt, ile) -> - aux (nbRef + max (aux 0 ilt) (aux 0 ile)) il - | Com.WhenDoElse (wdl, ed) -> - let rec wde nbRef = function - | (_, dl, _) :: wdl' -> wde (max nbRef (aux 0 dl)) wdl' - | [] -> max nbRef (aux 0 (Pos.unmark ed)) - in - aux (wde nbRef wdl) il - | Com.VerifBlock instrs -> aux (nbRef + aux 0 instrs) il - | Com.Iterate (_, _, _, instrs) -> aux (nbRef + 1 + aux 0 instrs) il - | Com.Restore (_, _, instrs) -> aux (nbRef + max 1 (aux 0 instrs)) il - | Com.ComputeTarget _ | Com.Affectation _ | Com.Print _ - | Com.RaiseError _ | Com.CleanErrors | Com.ExportErrors - | Com.FinalizeErrors -> - aux nbRef il - | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> - assert false) - in - let map (t : Mast.target) = - let target_nb_tmps = StrMap.cardinal t.target_tmp_vars in - let target_sz_tmps = - let fold _ (_, tsz_opt) sz = - match tsz_opt with - | None -> sz + 1 - | Some (tsz, _) -> sz + Mast.get_table_size tsz - in - StrMap.fold fold t.target_tmp_vars 0 - in - let target_nb_refs = List.length t.target_args + aux 0 t.target_prog in - { t with target_nb_tmps; target_sz_tmps; target_nb_refs } - in - StrMap.map map prog.prog_targets - in - let nb_all_tmps, sz_all_tmps, nb_all_refs = - let rec aux (nb, sz, nbRef, tdata) = function - | [] -> (nb, sz, nbRef, tdata) - | (instr, _) :: il -> ( - match instr with - | Com.ComputeTarget (tn, _targs) -> - let name = Pos.unmark tn in - let target = StrMap.find name prog_targets in - let nb1, sz1 = (target.target_nb_tmps, target.target_sz_tmps) in - let nbRef1 = List.length target.target_args in - let nbt, szt, nbRefT, tdata = - match StrMap.find_opt name tdata with - | None -> - let nbt, szt, nbRefT, tdata = - aux (0, 0, 0, tdata) target.target_prog - in - let tdata = StrMap.add name (nbt, szt, nbRefT) tdata in - (nbt, szt, nbRefT, tdata) - | Some (nbt, szt, nbRefT) -> (nbt, szt, nbRefT, tdata) - in - let nb = nb + nb1 + nbt in - let sz = sz + sz1 + szt in - let nbRef = nbRef + nbRef1 + nbRefT in - aux (nb, sz, nbRef, tdata) il - | Com.IfThenElse (_, ilt, ile) -> - let nb1, sz1, nbRef1, tdata = aux (0, 0, 0, tdata) ilt in - let nb2, sz2, nbRef2, tdata = aux (0, 0, 0, tdata) ile in - let nb = nb + max nb1 nb2 in - let sz = sz + max sz1 sz2 in - let nbRef = nbRef + max nbRef1 nbRef2 in - aux (nb, sz, nbRef, tdata) il - | Com.WhenDoElse (wdl, ed) -> - let rec wde (nb, sz, nbRef, tdata) = function - | (_, dl, _) :: wdl' -> - let nb', sz', nbRef', tdata = aux (0, 0, 0, tdata) dl in - let nb = max nb nb' in - let sz = max sz sz' in - let nbRef = max nbRef nbRef' in - wde (nb, sz, nbRef, tdata) wdl' - | [] -> - let nb', sz', nbRef', tdata = - aux (0, 0, 0, tdata) (Pos.unmark ed) - in - let nb = max nb nb' in - let sz = max sz sz' in - let nbRef = max nbRef nbRef' in - (nb, sz, nbRef, tdata) - in - let nb', sz', nbRef', tdata = wde (0, 0, 0, tdata) wdl in - let nb = nb + nb' in - let sz = sz + sz' in - let nbRef = nbRef + nbRef' in - aux (nb, sz, nbRef, tdata) il - | Com.VerifBlock instrs -> - let nb1, sz1, nbRef1, tdata = aux (0, 0, 0, tdata) instrs in - let nb = nb + nb1 in - let sz = sz + sz1 in - let nbRef = nbRef + nbRef1 in - aux (nb, sz, nbRef, tdata) il - | Com.Iterate (_, _, _, instrs) -> - let nb1, sz1, nbRef1, tdata = aux (0, 0, 0, tdata) instrs in - let nb = nb + nb1 in - let sz = sz + sz1 in - let nbRef = nbRef + 1 + nbRef1 in - aux (nb, sz, nbRef, tdata) il - | Com.Restore (_, _, instrs) -> - let nb1, sz1, nbRef1, tdata = aux (0, 0, 0, tdata) instrs in - let nb = nb + nb1 in - let sz = sz + sz1 in - let nbRef = nbRef + max 1 nbRef1 in - aux (nb, sz, nbRef, tdata) il - | Com.Affectation _ | Com.Print _ | Com.RaiseError _ | Com.CleanErrors - | Com.ExportErrors | Com.FinalizeErrors -> - aux (nb, sz, nbRef, tdata) il - | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> - assert false) - in - match StrMap.find_opt prog.prog_main_target prog_targets with - | None -> Err.main_target_not_found prog.prog_main_target - | Some t -> - let init_instrs = - [ (Com.ComputeTarget (t.target_name, []), Pos.no_pos) ] - in - let nb, sz, nbRef, _ = aux (0, 0, 0, StrMap.empty) init_instrs in - (nb, sz, nbRef) - in - let prog_stats = - Mir. - { - nb_calculated = nb_loc Com.CatVar.LocComputed; - nb_input = nb_loc Com.CatVar.LocInput; - nb_base = nb_loc Com.CatVar.LocBase; - nb_vars = StrMap.cardinal prog_vars; - nb_all_tmps; - nb_all_refs; - sz_calculated = sz_loc Com.CatVar.LocComputed; - sz_input = sz_loc Com.CatVar.LocInput; - sz_base = sz_loc Com.CatVar.LocBase; - sz_vars; - sz_all_tmps; - } - in - { prog with prog_vars; prog_targets; prog_stats } - let complete_dom_decls (rov : rule_or_verif) ((doms, syms) : 'a doms * syms) : 'a doms = let get_id id = Pos.unmark (Com.DomainIdMap.find id syms) in @@ -1581,6 +1350,45 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) let env = { env with prog } in let res_instr = Com.Iterate (var, vars, var_params, res_instrs) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il + | Com.Iterate_values (var, var_intervals, instrs) -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + let var_pos = Pos.get_position var in + let var_name = + match Pos.unmark var with + | Mast.Normal var -> var + | Mast.Generic _ -> assert false + in + (match StrMap.find_opt var_name env.prog.prog_vars with + | Some Com.Var.{ name = _, old_pos; _ } -> + Err.variable_already_declared var_name old_pos var_pos + | None -> ()); + (match StrMap.find_opt var_name env.tmp_vars with + | Some (_, old_pos) -> + Err.variable_already_declared var_name old_pos var_pos + | None -> ()); + (match StrMap.find_opt var_name env.ref_vars with + | Some old_pos -> + Err.variable_already_declared var_name old_pos var_pos + | None -> ()); + let env' = + { + env with + tmp_vars = StrMap.add var_name (None, var_pos) env.tmp_vars; + } + in + List.iter + (fun (e0, e1) -> + ignore (check_expression false e0 env); + ignore (check_expression false e1 env)) + var_intervals; + let prog, res_instrs, _, _ = + check_instructions instrs is_rule env' + in + let env = { env with prog } in + let res_instr = + Com.Iterate_values (var, var_intervals, res_instrs) + in + aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il | Com.Restore (vars, var_params, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; ignore @@ -1866,6 +1674,7 @@ let convert_rules (prog : program) : program = target_nb_tmps = 0; target_sz_tmps = 0; target_nb_refs = 0; + target_nb_itval = 0; } in StrMap.add tname target prog_targets) @@ -2014,6 +1823,7 @@ let complete_rule_domains (prog : program) : program = target_nb_tmps = 0; target_sz_tmps = 0; target_nb_refs = 0; + target_nb_itval = 0; } in StrMap.add tname target prog_targets @@ -2113,6 +1923,7 @@ let complete_chainings (prog : program) : program = target_nb_tmps = 0; target_sz_tmps = 0; target_nb_refs = 0; + target_nb_itval = 0; } in StrMap.add tname target prog_targets) @@ -2241,6 +2052,7 @@ let convert_verifs (prog : program) : program = target_nb_tmps = 0; target_sz_tmps = 0; target_nb_refs = 0; + target_nb_itval = 0; } in StrMap.add tname target prog_targets) @@ -2485,6 +2297,7 @@ let complete_verif_calls (prog : program) : program = target_nb_tmps = 0; target_sz_tmps = 0; target_nb_refs = 0; + target_nb_itval = 0; } in let prog_targets = StrMap.add tname target prog_targets in @@ -2518,6 +2331,7 @@ let complete_verif_calls (prog : program) : program = target_nb_tmps = 0; target_sz_tmps = 0; target_nb_refs = 0; + target_nb_itval = 0; } in let prog_targets = StrMap.add tname target prog_targets in @@ -2528,6 +2342,310 @@ let complete_verif_calls (prog : program) : program = in { prog with prog_targets } +let complete_vars (prog : program) : program = + let prog_vars = prog.prog_vars in + let prog_vars = + let incr_cpt cat cpt = + let i = Com.CatVar.Map.find cat cpt in + let cpt = Com.CatVar.Map.add cat (i + 1) cpt in + (cpt, i) + in + let cat_cpt = Com.CatVar.Map.map (fun _ -> 0) prog.prog_var_cats in + let prog_vars, _ = + StrMap.fold + (fun vn (var : Com.Var.t) (res, cpt) -> + let tgv = Com.Var.tgv var in + let dcat = Com.CatVar.Map.find tgv.cat prog.prog_var_cats in + let cpt, i = incr_cpt tgv.cat cpt in + let loc = Com.set_loc_tgv_cat var.loc dcat.loc dcat.id_str i in + let var = Com.Var.{ var with loc } in + let res = StrMap.add vn var res in + (res, cpt)) + prog_vars (StrMap.empty, cat_cpt) + in + prog_vars + in + let module CatLoc = struct + type t = Com.CatVar.loc + + let pp fmt (loc : t) = + match loc with + | Com.CatVar.LocComputed -> Format.fprintf fmt "calculee" + | Com.CatVar.LocBase -> Format.fprintf fmt "base" + | Com.CatVar.LocInput -> Format.fprintf fmt "saisie" + + let compare x y = compare x y + end in + let module CatLocMap = struct + include MapExt.Make (CatLoc) + + let _pp ?(sep = ", ") ?(pp_key = CatLoc.pp) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map + end in + let loc_vars, sz_loc_vars, sz_vars = + let fold _ (var : Com.Var.t) (loc_vars, sz_loc_vars, n) = + let var = Com.Var.{ var with loc = Com.set_loc_int var.loc n } in + let loc_cat = + (Com.CatVar.Map.find (Com.Var.cat var) prog.prog_var_cats).loc + in + let loc_vars = + let upd = function + | None -> Some (Com.Var.Set.one var) + | Some set -> Some (Com.Var.Set.add var set) + in + CatLocMap.update loc_cat upd loc_vars + in + let sz = Com.Var.size var in + let sz_loc_vars = + let upd = function + | None -> Some sz + | Some n_loc -> Some (n_loc + sz) + in + CatLocMap.update loc_cat upd sz_loc_vars + in + (loc_vars, sz_loc_vars, n + sz) + in + StrMap.fold fold prog_vars (CatLocMap.empty, CatLocMap.empty, 0) + in + let update_loc (var : Com.Var.t) (vars, n) = + let loc = Com.set_loc_tgv_idx var.loc n in + let vars = + StrMap.add (Com.Var.name_str var) Com.Var.{ var with loc } vars + in + (vars, n + Com.Var.size var) + in + let prog_vars = + CatLocMap.fold + (fun _loc_cat vars prog_vars -> + (prog_vars, 0) |> Com.Var.Set.fold update_loc vars |> fst) + loc_vars StrMap.empty + in + let nb_loc loc_cat = + match CatLocMap.find_opt loc_cat loc_vars with + | Some set -> Com.Var.Set.cardinal set + | None -> 0 + in + let sz_loc loc_cat = + match CatLocMap.find_opt loc_cat sz_loc_vars with + | Some sz -> sz + | None -> 0 + in + let prog_targets = + let rec aux nbRef nbIt = function + | [] -> (nbRef, nbIt) + | (instr, _) :: il -> ( + match instr with + | Com.IfThenElse (_, ilt, ile) -> + let nbRefT, nbItT = aux 0 0 ilt in + let nbRefE, nbItE = aux 0 0 ile in + aux (nbRef + max nbRefT nbRefE) (nbIt + max nbItT nbItE) il + | Com.WhenDoElse (wdl, ed) -> + let rec wde nbRef nbIt = function + | (_, dl, _) :: wdl' -> + let nbRefW, nbItW = aux 0 0 dl in + wde (max nbRef nbRefW) (max nbIt nbItW) wdl' + | [] -> + let nbRefW, nbItW = aux 0 0 (Pos.unmark ed) in + aux (max nbRef nbRefW) (max nbIt nbItW) il + in + wde nbRef nbIt wdl + | Com.VerifBlock is -> + let nbRef', nbIt' = aux 0 0 is in + aux (nbRef + nbRef') (nbIt + nbIt') il + | Com.Iterate (_, _, _, is) -> + let nbRef', nbIt' = aux 0 0 is in + aux (nbRef + nbRef' + 1) (nbIt + nbIt') il + | Com.Iterate_values (_, _, is) -> + let nbRef', nbIt' = aux 0 0 is in + aux (nbRef + nbRef') (nbIt + nbIt' + 1) il + | Com.Restore (_, _, is) -> + let nbRef', nbIt' = aux 0 0 is in + aux (nbRef + max 1 nbRef') (nbIt + nbIt') il + | Com.ComputeTarget _ | Com.Affectation _ | Com.Print _ + | Com.RaiseError _ | Com.CleanErrors | Com.ExportErrors + | Com.FinalizeErrors -> + aux nbRef nbIt il + | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> + assert false) + in + let map (t : Mast.target) = + let target_nb_tmps = StrMap.cardinal t.target_tmp_vars in + let target_sz_tmps = + let fold _ (_, tsz_opt) sz = + match tsz_opt with + | None -> sz + 1 + | Some (tsz, _) -> sz + Mast.get_table_size tsz + in + StrMap.fold fold t.target_tmp_vars 0 + in + let nbRef, target_nb_itval = aux 0 0 t.target_prog in + let target_nb_refs = List.length t.target_args + nbRef in + { t with target_nb_tmps; target_sz_tmps; target_nb_refs; target_nb_itval } + in + StrMap.map map prog.prog_targets + in + let nb_all_tmps, sz_all_tmps, nb_all_refs, nb_all_itval = + let rec aux (nb, sz, nbRef, nbItval, tdata) = function + | [] -> (nb, sz, nbRef, nbItval, tdata) + | (instr, _) :: il -> ( + match instr with + | Com.ComputeTarget (tn, _targs) -> + let name = Pos.unmark tn in + let target = StrMap.find name prog_targets in + let nb1, sz1 = (target.target_nb_tmps, target.target_sz_tmps) in + let nbRef1 = List.length target.target_args in + let nbItval1 = target.target_nb_itval in + let nbt, szt, nbRefT, nbItvalT, tdata = + match StrMap.find_opt name tdata with + | None -> + let nbt, szt, nbRefT, nbItvalT, tdata = + aux (0, 0, 0, 0, tdata) target.target_prog + in + let tdata = + StrMap.add name (nbt, szt, nbRefT, nbItvalT) tdata + in + (nbt, szt, nbRefT, nbItvalT, tdata) + | Some (nbt, szt, nbRefT, nbItvalT) -> + (nbt, szt, nbRefT, nbItvalT, tdata) + in + let nb = nb + nb1 + nbt in + let sz = sz + sz1 + szt in + let nbRef = nbRef + nbRef1 + nbRefT in + let nbItval = nbItval + nbItval1 + nbItvalT in + aux (nb, sz, nbRef, nbItval, tdata) il + | Com.IfThenElse (_, ilt, ile) -> + let nb1, sz1, nbRef1, nbItval1, tdata = + aux (0, 0, 0, 0, tdata) ilt + in + let nb2, sz2, nbRef2, nbItval2, tdata = + aux (0, 0, 0, 0, tdata) ile + in + let nb = nb + max nb1 nb2 in + let sz = sz + max sz1 sz2 in + let nbRef = nbRef + max nbRef1 nbRef2 in + let nbItval = nbItval + max nbItval1 nbItval2 in + aux (nb, sz, nbRef, nbItval, tdata) il + | Com.WhenDoElse (wdl, ed) -> + let rec wde (nb, sz, nbRef, nbItval, tdata) = function + | (_, dl, _) :: wdl' -> + let nb', sz', nbRef', nbItval', tdata = + aux (0, 0, 0, 0, tdata) dl + in + let nb = max nb nb' in + let sz = max sz sz' in + let nbRef = max nbRef nbRef' in + let nbItval = max nbItval nbItval' in + wde (nb, sz, nbRef, nbItval, tdata) wdl' + | [] -> + let nb', sz', nbRef', nbItval', tdata = + aux (0, 0, 0, 0, tdata) (Pos.unmark ed) + in + let nb = max nb nb' in + let sz = max sz sz' in + let nbRef = max nbRef nbRef' in + let nbItval = max nbItval nbItval' in + (nb, sz, nbRef, nbItval, tdata) + in + let nb', sz', nbRef', nbItval', tdata = + wde (0, 0, 0, 0, tdata) wdl + in + let nb = nb + nb' in + let sz = sz + sz' in + let nbRef = nbRef + nbRef' in + let nbItval = nbItval + nbItval' in + aux (nb, sz, nbRef, nbItval, tdata) il + | Com.VerifBlock instrs -> + let nb1, sz1, nbRef1, nbItval1, tdata = + aux (0, 0, 0, 0, tdata) instrs + in + let nb = nb + nb1 in + let sz = sz + sz1 in + let nbRef = nbRef + nbRef1 in + let nbItval = nbItval + nbItval1 in + aux (nb, sz, nbRef, nbItval, tdata) il + | Com.Iterate (_, _, _, instrs) -> + let nb1, sz1, nbRef1, nbItval1, tdata = + aux (0, 0, 0, 0, tdata) instrs + in + let nb = nb + nb1 in + let sz = sz + sz1 in + let nbRef = nbRef + 1 + nbRef1 in + let nbItval = nbItval + nbItval1 in + aux (nb, sz, nbRef, nbItval, tdata) il + | Com.Iterate_values (_, _, instrs) -> + let nb1, sz1, nbRef1, nbItval1, tdata = + aux (0, 0, 0, 0, tdata) instrs + in + let nb = nb + nb1 in + let sz = sz + sz1 in + let nbRef = nbRef + nbRef1 in + let nbItval = nbItval + 1 + nbItval1 in + aux (nb, sz, nbRef, nbItval, tdata) il + | Com.Restore (_, _, instrs) -> + let nb1, sz1, nbRef1, nbItval1, tdata = + aux (0, 0, 0, 0, tdata) instrs + in + let nb = nb + nb1 in + let sz = sz + sz1 in + let nbRef = nbRef + max 1 nbRef1 in + let nbItval = nbItval + nbItval1 in + aux (nb, sz, nbRef, nbItval, tdata) il + | Com.Affectation _ | Com.Print _ | Com.RaiseError _ | Com.CleanErrors + | Com.ExportErrors | Com.FinalizeErrors -> + aux (nb, sz, nbRef, nbItval, tdata) il + | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> + assert false) + in + let nb, sz, nbRef, nbItval, _ = + StrMap.fold + (fun tn (t : Mast.target) (nb, sz, nbRef, nbItval, tdata) -> + match StrMap.find_opt tn tdata with + | Some (nbt, szt, nbRefT, nbItvalT) -> + ( max nb nbt, + max sz szt, + max nbRef nbRefT, + max nbItval nbItvalT, + tdata ) + | None -> + let init_instrs = + [ (Com.ComputeTarget (t.target_name, []), Pos.no_pos) ] + in + let nbT, szT, nbRefT, nbItvalT, tdata = + aux (0, 0, 0, 0, tdata) init_instrs + in + ( max nb nbT, + max sz szT, + max nbRef nbRefT, + max nbItval nbItvalT, + tdata )) + prog_targets (0, 0, 0, 0, StrMap.empty) + in + (nb, sz, nbRef, nbItval) + in + (match StrMap.find_opt prog.prog_main_target prog_targets with + | None -> Err.main_target_not_found prog.prog_main_target + | Some _ -> ()); + let prog_stats = + Mir. + { + nb_calculated = nb_loc Com.CatVar.LocComputed; + nb_input = nb_loc Com.CatVar.LocInput; + nb_base = nb_loc Com.CatVar.LocBase; + nb_vars = StrMap.cardinal prog_vars; + nb_all_tmps; + nb_all_refs; + nb_all_itval; + sz_calculated = sz_loc Com.CatVar.LocComputed; + sz_input = sz_loc Com.CatVar.LocInput; + sz_base = sz_loc Com.CatVar.LocBase; + sz_vars; + sz_all_tmps; + } + in + { prog with prog_vars; prog_targets; prog_stats } + let proceed (p : Mast.program) (main_target : string) : program = (* à paramétrer *) let prog = diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index 8da2127a3..f1b90deea 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -709,6 +709,17 @@ let rec expand_instruction (const_map : const_context) in let instrs' = expand_instructions const_map instrs in (Com.Iterate (name, vars, var_params', instrs'), instr_pos) :: prev + | Com.Iterate_values (name, var_intervals, instrs) -> + let var_intervals' = + List.map + (fun (e0, e1) -> + let e0' = expand_expression const_map ParamsMap.empty e0 in + let e1' = expand_expression const_map ParamsMap.empty e1 in + (e0', e1')) + var_intervals + in + let instrs' = expand_instructions const_map instrs in + (Com.Iterate_values (name, var_intervals', instrs'), instr_pos) :: prev | Com.Restore (vars, var_params, instrs) -> let instrs' = expand_instructions const_map instrs in (Com.Restore (vars, var_params, instrs'), instr_pos) :: prev diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index 58e3511ad..754d24dc7 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -105,6 +105,7 @@ type target = { target_nb_tmps : int; target_sz_tmps : int; target_nb_refs : int; + target_nb_itval : int; target_prog : instruction Pos.marked list; } diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 73798d7b5..1285b7eb6 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -561,6 +561,7 @@ target_etc: target_nb_tmps = -1; target_sz_tmps = -1; target_nb_refs = -1; + target_nb_itval = -1; target_prog; } in Pos.same_pos_as (Target target) name :: l @@ -594,6 +595,7 @@ function_etc: target_nb_tmps = -1; target_sz_tmps = -1; target_nb_refs = -1; + target_nb_itval = -1; target_prog; } in Pos.same_pos_as (Function target) name :: l @@ -678,17 +680,31 @@ instruction: } | ITERATE COLON VARIABLE vn = symbol_with_pos COLON - it_params = nonempty_list(it_param) + it_params = nonempty_list(with_pos(it_param)) IN LPAREN instrs = instruction_list_rev RPAREN { let var = Pos.same_pos_as (Normal (Pos.unmark vn)) vn in - let var_list, var_cats = - let fold (var_list, var_cats) = function - | `VarList vl -> (List.rev vl) @ var_list, var_cats - | `VarCatsIt vc -> var_list, vc :: var_cats - in - List.fold_left fold ([], []) it_params - in - Some (Iterate (var, List.rev var_list, List.rev var_cats, List.rev instrs)) + match it_params with + | (`VarInterval _, _) :: _ -> + let var_intervals = + let fold var_intervals = function + | (`VarInterval (e0, e1), _) -> (e0, e1) :: var_intervals + | (`VarList _, pos) | (`VarCatsIt _, pos) -> + Errors.raise_spanned_error "variable descriptors forbidden in values iteration" pos + in + List.fold_left fold [] it_params + in + Some (Iterate_values (var, List.rev var_intervals, List.rev instrs)) + | _ -> + let var_list, var_cats = + let fold (var_list, var_cats) = function + | (`VarList vl, _) -> (List.rev vl) @ var_list, var_cats + | (`VarCatsIt vc, _) -> var_list, vc :: var_cats + | (`VarInterval _, pos) -> + Errors.raise_spanned_error "interval forbidden in variable iteration" pos + in + List.fold_left fold ([], []) it_params + in + Some (Iterate (var, List.rev var_list, List.rev var_cats, List.rev instrs)) } | RESTORE COLON rest_params = nonempty_list(rest_param) AFTER LPAREN instrs = instruction_list_rev RPAREN { @@ -816,6 +832,9 @@ it_param: in `VarCatsIt (vcats, expr) } +| expr0 = with_pos(expression) RANGE expr1 = with_pos(expression) COLON { + `VarInterval (expr0, expr1) + } it_param_with_expr: | WITH expr = with_pos(expression) COLON { expr } diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 3f20a12f4..fa3384c12 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -481,6 +481,10 @@ type ('v, 'e) instruction = * 'v Pos.marked list * (Pos.t CatVar.Map.t * 'v m_expression) list * ('v, 'e) m_instruction list + | Iterate_values of + 'v Pos.marked + * ('v m_expression * 'v m_expression) list + * ('v, 'e) m_instruction list | Restore of 'v Pos.marked list * ('v Pos.marked * Pos.t CatVar.Map.t * 'v m_expression) list @@ -771,6 +775,16 @@ let rec format_instruction form_var form_err = (Pp.list_space format_var_param) var_params; Format.fprintf fmt "@[ %a@]@\n)@\n" form_instrs itb + | Iterate_values (var, var_intervals, itb) -> + let format_var_intervals fmt (e0, e1) = + Format.fprintf fmt ": %a .. %a@\n" form_expr (Pos.unmark e0) form_expr + (Pos.unmark e1) + in + Format.fprintf fmt "iterate variable %a@;: %a@;: dans (" form_var + (Pos.unmark var) + (Pp.list_space format_var_intervals) + var_intervals; + Format.fprintf fmt "@[ %a@]@\n)@\n" form_instrs itb | Restore (vars, var_params, rb) -> let format_var_param fmt (var, vcs, expr) = Format.fprintf fmt ": variable %a : categorie %a : avec %a@\n" diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 420d52ad3..b2ac9167b 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -334,6 +334,10 @@ type ('v, 'e) instruction = * 'v Pos.marked list * (Pos.t CatVar.Map.t * 'v m_expression) list * ('v, 'e) m_instruction list + | Iterate_values of + 'v Pos.marked + * ('v m_expression * 'v m_expression) list + * ('v, 'e) m_instruction list | Restore of 'v Pos.marked list * ('v Pos.marked * Pos.t CatVar.Map.t * 'v m_expression) list diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 08576b299..fb70736b9 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -52,6 +52,7 @@ type stats = { nb_vars : int; nb_all_tmps : int; nb_all_refs : int; + nb_all_itval : int; sz_calculated : int; sz_base : int; sz_input : int; @@ -259,6 +260,17 @@ let expand_functions (p : program) : program = in let instrs' = List.map map_instr instrs in (Iterate (v_id, vars, var_params', instrs'), instr_pos) + | Iterate_values (v_id, var_intervals, instrs) -> + let var_intervals' = + List.map + (fun (e0, e1) -> + let e0' = expand_functions_expr e0 in + let e1' = expand_functions_expr e1 in + (e0', e1')) + var_intervals + in + let instrs' = List.map map_instr instrs in + (Iterate_values (v_id, var_intervals', instrs'), instr_pos) | Restore (vars, filters, instrs) -> let filters' = List.map diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 901e0817d..537320588 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -42,6 +42,7 @@ type stats = { nb_vars : int; nb_all_tmps : int; nb_all_refs : int; + nb_all_itval : int; sz_calculated : int; sz_base : int; sz_input : int; From 1a8fea05897a0d3ac1294f249be03795e9f85dc7 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 14 Jan 2025 16:38:45 +0100 Subject: [PATCH 06/32] =?UTF-8?q?Taille=20des=20piles=20d'ex=C3=A9cution?= =?UTF-8?q?=20(instable)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mlang-deps | 2 +- src/mlang/m_frontend/check_validity.ml | 441 ++++++++++--------- src/mlang/m_frontend/mast.ml | 1 - src/mlang/m_frontend/mparser.mly | 2 - src/mlang/m_ir/mir.ml | 1 - src/mlang/m_ir/mir.mli | 1 - src/mlang/m_ir/mir_interpreter.ml | 33 +- src/mlang/test_framework/test_interpreter.ml | 9 +- 8 files changed, 265 insertions(+), 225 deletions(-) diff --git a/mlang-deps b/mlang-deps index 982183a94..3bfa74fff 160000 --- a/mlang-deps +++ b/mlang-deps @@ -1 +1 @@ -Subproject commit 982183a94932165c46269bd3c22db9657e9e6ef3 +Subproject commit 3bfa74fff694869c045470130cb18e9ebb3a7f33 diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index c55116375..28f7102ff 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -458,7 +458,6 @@ let empty_program (p : Mast.program) main_target = nb_vars = 0; nb_all_tmps = 0; nb_all_refs = 0; - nb_all_itval = 0; sz_calculated = 0; sz_base = 0; sz_input = 0; @@ -1674,7 +1673,6 @@ let convert_rules (prog : program) : program = target_nb_tmps = 0; target_sz_tmps = 0; target_nb_refs = 0; - target_nb_itval = 0; } in StrMap.add tname target prog_targets) @@ -1823,7 +1821,6 @@ let complete_rule_domains (prog : program) : program = target_nb_tmps = 0; target_sz_tmps = 0; target_nb_refs = 0; - target_nb_itval = 0; } in StrMap.add tname target prog_targets @@ -1923,7 +1920,6 @@ let complete_chainings (prog : program) : program = target_nb_tmps = 0; target_sz_tmps = 0; target_nb_refs = 0; - target_nb_itval = 0; } in StrMap.add tname target prog_targets) @@ -2052,7 +2048,6 @@ let convert_verifs (prog : program) : program = target_nb_tmps = 0; target_sz_tmps = 0; target_nb_refs = 0; - target_nb_itval = 0; } in StrMap.add tname target prog_targets) @@ -2297,7 +2292,6 @@ let complete_verif_calls (prog : program) : program = target_nb_tmps = 0; target_sz_tmps = 0; target_nb_refs = 0; - target_nb_itval = 0; } in let prog_targets = StrMap.add tname target prog_targets in @@ -2331,7 +2325,6 @@ let complete_verif_calls (prog : program) : program = target_nb_tmps = 0; target_sz_tmps = 0; target_nb_refs = 0; - target_nb_itval = 0; } in let prog_targets = StrMap.add tname target prog_targets in @@ -2432,219 +2425,265 @@ let complete_vars (prog : program) : program = | Some sz -> sz | None -> 0 in - let prog_targets = - let rec aux nbRef nbIt = function - | [] -> (nbRef, nbIt) - | (instr, _) :: il -> ( - match instr with - | Com.IfThenElse (_, ilt, ile) -> - let nbRefT, nbItT = aux 0 0 ilt in - let nbRefE, nbItE = aux 0 0 ile in - aux (nbRef + max nbRefT nbRefE) (nbIt + max nbItT nbItE) il - | Com.WhenDoElse (wdl, ed) -> - let rec wde nbRef nbIt = function - | (_, dl, _) :: wdl' -> - let nbRefW, nbItW = aux 0 0 dl in - wde (max nbRef nbRefW) (max nbIt nbItW) wdl' - | [] -> - let nbRefW, nbItW = aux 0 0 (Pos.unmark ed) in - aux (max nbRef nbRefW) (max nbIt nbItW) il - in - wde nbRef nbIt wdl - | Com.VerifBlock is -> - let nbRef', nbIt' = aux 0 0 is in - aux (nbRef + nbRef') (nbIt + nbIt') il - | Com.Iterate (_, _, _, is) -> - let nbRef', nbIt' = aux 0 0 is in - aux (nbRef + nbRef' + 1) (nbIt + nbIt') il - | Com.Iterate_values (_, _, is) -> - let nbRef', nbIt' = aux 0 0 is in - aux (nbRef + nbRef') (nbIt + nbIt' + 1) il - | Com.Restore (_, _, is) -> - let nbRef', nbIt' = aux 0 0 is in - aux (nbRef + max 1 nbRef') (nbIt + nbIt') il - | Com.ComputeTarget _ | Com.Affectation _ | Com.Print _ - | Com.RaiseError _ | Com.CleanErrors | Com.ExportErrors - | Com.FinalizeErrors -> - aux nbRef nbIt il - | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> - assert false) + let prog_stats = + Mir. + { + prog.prog_stats with + nb_calculated = nb_loc Com.CatVar.LocComputed; + nb_input = nb_loc Com.CatVar.LocInput; + nb_base = nb_loc Com.CatVar.LocBase; + nb_vars = StrMap.cardinal prog_vars; + sz_calculated = sz_loc Com.CatVar.LocComputed; + sz_input = sz_loc Com.CatVar.LocInput; + sz_base = sz_loc Com.CatVar.LocBase; + sz_vars; + } + in + { prog with prog_vars; prog_stats } + +let complete_vars_stack (prog : program) : program = + let prog_functions, prog_targets = + let rec aux_instrs mil = + let fold (nbRef, nbIt) mi = + let nbRef', nbIt' = aux_instr mi in + (max nbRef nbRef', max nbIt nbIt') + in + List.fold_left fold (0, 0) mil + and aux_instr (instr, _pos) = + match instr with + | Com.IfThenElse (_, ilThen, ilElse) -> + let nbRefThen, nbItThen = aux_instrs ilThen in + let nbRefElse, nbItElse = aux_instrs ilElse in + (max nbRefThen nbRefElse, max nbItThen nbItElse) + | Com.WhenDoElse (wdl, ed) -> + let rec wde (nbRef, nbIt) = function + | (_, dl, _) :: wdl' -> + let nbRefD, nbItD = aux_instrs dl in + wde (max nbRef nbRefD, max nbIt nbItD) wdl' + | [] -> + let nbRefD, nbItD = aux_instrs (Pos.unmark ed) in + (max nbRef nbRefD, max nbIt nbItD) + in + wde (0, 0) wdl + | Com.VerifBlock instrs -> aux_instrs instrs + | Com.Iterate (_, _, _, instrs) -> + let nbRef, nbIt = aux_instrs instrs in + (nbRef + 1, nbIt) + | Com.Iterate_values (_, _, instrs) -> + let nbRef, nbIt = aux_instrs instrs in + (nbRef, nbIt + 1) + | Com.Restore (_, _, instrs) -> + let nbRef, nbIt = aux_instrs instrs in + (max nbRef 1, nbIt) + | Com.Affectation _ | Com.Print _ | Com.ComputeTarget _ | Com.RaiseError _ + | Com.CleanErrors | Com.ExportErrors | Com.FinalizeErrors -> + (0, 0) + | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> + assert false in let map (t : Mast.target) = - let target_nb_tmps = StrMap.cardinal t.target_tmp_vars in + let nbRef, nbIt = aux_instrs t.target_prog in + let target_nb_tmps = StrMap.cardinal t.target_tmp_vars + nbIt in let target_sz_tmps = let fold _ (_, tsz_opt) sz = match tsz_opt with | None -> sz + 1 | Some (tsz, _) -> sz + Mast.get_table_size tsz in - StrMap.fold fold t.target_tmp_vars 0 + StrMap.fold fold t.target_tmp_vars nbIt in - let nbRef, target_nb_itval = aux 0 0 t.target_prog in let target_nb_refs = List.length t.target_args + nbRef in - { t with target_nb_tmps; target_sz_tmps; target_nb_refs; target_nb_itval } + if target_nb_tmps + target_sz_tmps + target_nb_refs > 0 then + Format.eprintf "%s: %d %d %d@." (Pos.unmark t.target_name) + target_nb_tmps target_sz_tmps target_nb_refs; + { t with target_nb_tmps; target_sz_tmps; target_nb_refs } in - StrMap.map map prog.prog_targets - in - let nb_all_tmps, sz_all_tmps, nb_all_refs, nb_all_itval = - let rec aux (nb, sz, nbRef, nbItval, tdata) = function - | [] -> (nb, sz, nbRef, nbItval, tdata) - | (instr, _) :: il -> ( - match instr with - | Com.ComputeTarget (tn, _targs) -> - let name = Pos.unmark tn in - let target = StrMap.find name prog_targets in - let nb1, sz1 = (target.target_nb_tmps, target.target_sz_tmps) in - let nbRef1 = List.length target.target_args in - let nbItval1 = target.target_nb_itval in - let nbt, szt, nbRefT, nbItvalT, tdata = - match StrMap.find_opt name tdata with - | None -> - let nbt, szt, nbRefT, nbItvalT, tdata = - aux (0, 0, 0, 0, tdata) target.target_prog - in - let tdata = - StrMap.add name (nbt, szt, nbRefT, nbItvalT) tdata - in - (nbt, szt, nbRefT, nbItvalT, tdata) - | Some (nbt, szt, nbRefT, nbItvalT) -> - (nbt, szt, nbRefT, nbItvalT, tdata) - in - let nb = nb + nb1 + nbt in - let sz = sz + sz1 + szt in - let nbRef = nbRef + nbRef1 + nbRefT in - let nbItval = nbItval + nbItval1 + nbItvalT in - aux (nb, sz, nbRef, nbItval, tdata) il - | Com.IfThenElse (_, ilt, ile) -> - let nb1, sz1, nbRef1, nbItval1, tdata = - aux (0, 0, 0, 0, tdata) ilt - in - let nb2, sz2, nbRef2, nbItval2, tdata = - aux (0, 0, 0, 0, tdata) ile - in - let nb = nb + max nb1 nb2 in - let sz = sz + max sz1 sz2 in - let nbRef = nbRef + max nbRef1 nbRef2 in - let nbItval = nbItval + max nbItval1 nbItval2 in - aux (nb, sz, nbRef, nbItval, tdata) il - | Com.WhenDoElse (wdl, ed) -> - let rec wde (nb, sz, nbRef, nbItval, tdata) = function - | (_, dl, _) :: wdl' -> - let nb', sz', nbRef', nbItval', tdata = - aux (0, 0, 0, 0, tdata) dl - in - let nb = max nb nb' in - let sz = max sz sz' in - let nbRef = max nbRef nbRef' in - let nbItval = max nbItval nbItval' in - wde (nb, sz, nbRef, nbItval, tdata) wdl' - | [] -> - let nb', sz', nbRef', nbItval', tdata = - aux (0, 0, 0, 0, tdata) (Pos.unmark ed) - in - let nb = max nb nb' in - let sz = max sz sz' in - let nbRef = max nbRef nbRef' in - let nbItval = max nbItval nbItval' in - (nb, sz, nbRef, nbItval, tdata) - in - let nb', sz', nbRef', nbItval', tdata = - wde (0, 0, 0, 0, tdata) wdl - in - let nb = nb + nb' in - let sz = sz + sz' in - let nbRef = nbRef + nbRef' in - let nbItval = nbItval + nbItval' in - aux (nb, sz, nbRef, nbItval, tdata) il - | Com.VerifBlock instrs -> - let nb1, sz1, nbRef1, nbItval1, tdata = - aux (0, 0, 0, 0, tdata) instrs - in - let nb = nb + nb1 in - let sz = sz + sz1 in - let nbRef = nbRef + nbRef1 in - let nbItval = nbItval + nbItval1 in - aux (nb, sz, nbRef, nbItval, tdata) il - | Com.Iterate (_, _, _, instrs) -> - let nb1, sz1, nbRef1, nbItval1, tdata = - aux (0, 0, 0, 0, tdata) instrs - in - let nb = nb + nb1 in - let sz = sz + sz1 in - let nbRef = nbRef + 1 + nbRef1 in - let nbItval = nbItval + nbItval1 in - aux (nb, sz, nbRef, nbItval, tdata) il - | Com.Iterate_values (_, _, instrs) -> - let nb1, sz1, nbRef1, nbItval1, tdata = - aux (0, 0, 0, 0, tdata) instrs - in - let nb = nb + nb1 in - let sz = sz + sz1 in - let nbRef = nbRef + nbRef1 in - let nbItval = nbItval + 1 + nbItval1 in - aux (nb, sz, nbRef, nbItval, tdata) il - | Com.Restore (_, _, instrs) -> - let nb1, sz1, nbRef1, nbItval1, tdata = - aux (0, 0, 0, 0, tdata) instrs + (StrMap.map map prog.prog_functions, StrMap.map map prog.prog_targets) + in + let nb_all_tmps, sz_all_tmps, nb_all_refs = + let rec aux_instrs tdata mil = + let fold (nb, sz, nbRef, tdata) mi = + let nb', sz', nbRef', tdata = aux_instr tdata mi in + (max nb nb', max sz sz', max nbRef nbRef', tdata) + in + List.fold_left fold (0, 0, 0, tdata) mil + and aux_call tdata name = + match StrMap.find_opt name tdata with + | Some (nb, sz, nbRef) -> (nb, sz, nbRef, tdata) + | None -> ( + let eval_call (t : Mast.target) = + let nb, sz, nbRef = + (t.target_nb_tmps, t.target_sz_tmps, List.length t.target_args) + in + let nb', sz', nbRef', tdata = aux_instrs tdata t.target_prog in + let nb = nb + nb' in + let sz = sz + sz' in + let nbRef = nbRef + nbRef' in + let tdata = StrMap.add name (nb, sz, nbRef) tdata in + (nb, sz, nbRef, tdata) + in + match StrMap.find_opt name prog_functions with + | Some t -> eval_call t + | None -> eval_call (StrMap.find name prog_targets)) + and aux_instr tdata (instr, _pos) = + match instr with + | Com.Affectation mf -> ( + match Pos.unmark mf with + | SingleFormula (_, mei_opt, mev) -> + let nbI, szI, nbRefI, tdata = + match mei_opt with + | None -> (0, 0, 0, tdata) + | Some mei -> aux_expr tdata mei in - let nb = nb + nb1 in - let sz = sz + sz1 in - let nbRef = nbRef + max 1 nbRef1 in - let nbItval = nbItval + nbItval1 in - aux (nb, sz, nbRef, nbItval, tdata) il - | Com.Affectation _ | Com.Print _ | Com.RaiseError _ | Com.CleanErrors - | Com.ExportErrors | Com.FinalizeErrors -> - aux (nb, sz, nbRef, nbItval, tdata) il - | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> - assert false) + let nbV, szV, nbRefV, tdata = aux_expr tdata mev in + (max nbI nbV, max szI szV, max nbRefI nbRefV, tdata) + | MultipleFormulaes _ -> assert false) + | Com.ComputeTarget (tn, _args) -> aux_call tdata (Pos.unmark tn) + | Com.IfThenElse (meI, ilT, ilE) -> + let nbI, szI, nbRefI, tdata = aux_expr tdata meI in + let nbT, szT, nbRefT, tdata = aux_instrs tdata ilT in + let nbE, szE, nbRefE, tdata = aux_instrs tdata ilE in + let nb = max nbI (max nbT nbE) in + let sz = max szI (max szT szE) in + let nbRef = max nbRefI (max nbRefT nbRefE) in + (nb, sz, nbRef, tdata) + | Com.WhenDoElse (wdl, ed) -> + let rec wde (nb, sz, nbRef, tdata) = function + | (me, dl, _) :: wdl' -> + let nbE, szE, nbRefE, tdata = aux_expr tdata me in + let nbD, szD, nbRefD, tdata = aux_instrs tdata dl in + let nb = max nb (max nbE nbD) in + let sz = max sz (max szE szD) in + let nbRef = max nbRef (max nbRefE nbRefD) in + wde (nb, sz, nbRef, tdata) wdl' + | [] -> + let nbD, szD, nbRefD, tdata = + aux_instrs tdata (Pos.unmark ed) + in + let nb = max nb nbD in + let sz = max sz szD in + let nbRef = max nbRef nbRefD in + (nb, sz, nbRef, tdata) + in + wde (0, 0, 0, tdata) wdl + | Com.VerifBlock instrs -> aux_instrs tdata instrs + | Com.Print (_, pal) -> + let fold (nb, sz, nbRef, tdata) (a, _pos) = + match a with + | Com.PrintString _ | Com.PrintName _ | Com.PrintAlias _ -> + (nb, sz, nbRef, tdata) + | Com.PrintIndent me | Com.PrintExpr (me, _, _) -> + let nb', sz', nbRef', tdata = aux_expr tdata me in + (max nb nb', max sz sz', max nbRef nbRef', tdata) + in + List.fold_left fold (0, 0, 0, tdata) pal + | Com.Iterate (_, _, mel, instrs) -> + let fold (nb, sz, nbRef, tdata) (_, me) = + let nb', sz', nbRef', tdata = aux_expr tdata me in + (max nb nb', max sz sz', max nbRef nbRef', tdata) + in + let nb', sz', nbRef', tdata = + List.fold_left fold (0, 0, 0, tdata) mel + in + let nb, sz, nbRef, tdata = aux_instrs tdata instrs in + let nb = max nb nb' in + let sz = max sz sz' in + let nbRef = 1 + max nbRef nbRef' in + (nb, sz, nbRef, tdata) + | Com.Iterate_values (_, me2l, instrs) -> + let fold (nb, sz, nbRef, tdata) (me0, me1) = + let nb', sz', nbRef', tdata = aux_expr tdata me0 in + let nb'', sz'', nbRef'', tdata = aux_expr tdata me1 in + let nb = max nb (max nb' nb'') in + let sz = max sz (max sz' sz'') in + let nbRef = max nbRef (max nbRef' nbRef'') in + (nb, sz, nbRef, tdata) + in + let nb', sz', nbRef', tdata = + List.fold_left fold (0, 0, 0, tdata) me2l + in + let nb, sz, nbRef, tdata = aux_instrs tdata instrs in + let nb = 1 + max nb nb' in + let sz = 1 + max sz sz' in + let nbRef = max nbRef nbRef' in + (nb, sz, nbRef, tdata) + | Com.Restore (_, mel, instrs) -> + let fold (nb, sz, nbRef, tdata) (_, _, me) = + let nb', sz', nbRef', tdata = aux_expr tdata me in + (max nb nb', max sz sz', max nbRef nbRef', tdata) + in + let nb', sz', nbRef', tdata = + List.fold_left fold (0, 0, 0, tdata) mel + in + let nb, sz, nbRef, tdata = aux_instrs tdata instrs in + let nb = max nb nb' in + let sz = max sz sz' in + let nbRef = 1 + max nbRef nbRef' in + (nb, sz, nbRef, tdata) + | Com.RaiseError _ | Com.CleanErrors | Com.ExportErrors + | Com.FinalizeErrors -> + (0, 0, 0, tdata) + | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> + assert false + and aux_expr tdata (expr, _pos) = + match expr with + | Com.TestInSet (_, me, _) | Com.Unop (_, me) | Com.Index (_, me) -> + aux_expr tdata me + | Com.Comparison (_, me0, me1) | Com.Binop (_, me0, me1) -> + let nb0, sz0, nbRef0, tdata = aux_expr tdata me0 in + let nb1, sz1, nbRef1, tdata = aux_expr tdata me1 in + (max nb0 nb1, max sz0 sz1, max nbRef0 nbRef1, tdata) + | Com.Conditional (meI, meT, meEOpt) -> + let nbI, szI, nbRefI, tdata = aux_expr tdata meI in + let nbT, szT, nbRefT, tdata = aux_expr tdata meT in + let nbE, szE, nbRefE, tdata = + match meEOpt with + | None -> (0, 0, 0, tdata) + | Some meE -> aux_expr tdata meE + in + let nb = max nbI (max nbT nbE) in + let sz = max szI (max szT szE) in + let nbRef = max nbRefI (max nbRefT nbRefE) in + (nb, sz, nbRef, tdata) + | Com.FuncCall (func, mel) -> + let fold (nb, sz, nbRef, tdata) me = + let nb', sz', nbRef', tdata = aux_expr tdata me in + (max nb nb', max sz sz', max nbRef nbRef', tdata) + in + let nb', sz', nbRef', tdata = + List.fold_left fold (0, 0, 0, tdata) mel + in + let nb, sz, nbRef, tdata = + match Pos.unmark func with + | Func name -> aux_call tdata name + | _ -> (0, 0, 0, tdata) + in + (max nb nb', max sz sz', max nbRef nbRef', tdata) + | Com.Literal _ | Com.Var _ | Com.NbCategory _ | Com.Attribut _ + | Com.Size _ | Com.NbAnomalies | Com.NbDiscordances | Com.NbInformatives + | Com.NbBloquantes -> + (0, 0, 0, tdata) + | Com.FuncCallLoop _ | Com.Loop _ -> assert false in - let nb, sz, nbRef, nbItval, _ = - StrMap.fold - (fun tn (t : Mast.target) (nb, sz, nbRef, nbItval, tdata) -> - match StrMap.find_opt tn tdata with - | Some (nbt, szt, nbRefT, nbItvalT) -> - ( max nb nbt, - max sz szt, - max nbRef nbRefT, - max nbItval nbItvalT, - tdata ) - | None -> - let init_instrs = - [ (Com.ComputeTarget (t.target_name, []), Pos.no_pos) ] - in - let nbT, szT, nbRefT, nbItvalT, tdata = - aux (0, 0, 0, 0, tdata) init_instrs - in - ( max nb nbT, - max sz szT, - max nbRef nbRefT, - max nbItval nbItvalT, - tdata )) - prog_targets (0, 0, 0, 0, StrMap.empty) + let nb, sz, nbRef, _ = + let fold tn (t : Mast.target) (nb, sz, nbRef, tdata) = + let nb', sz', nbRef', tdata = aux_call tdata tn in + (max nb nb', max sz sz', max nbRef nbRef', tdata) + in + (0, 0, 0, StrMap.empty) + |> StrMap.fold fold prog_functions + |> StrMap.fold fold prog_targets in - (nb, sz, nbRef, nbItval) + (nb, sz, nbRef) in (match StrMap.find_opt prog.prog_main_target prog_targets with | None -> Err.main_target_not_found prog.prog_main_target | Some _ -> ()); let prog_stats = - Mir. - { - nb_calculated = nb_loc Com.CatVar.LocComputed; - nb_input = nb_loc Com.CatVar.LocInput; - nb_base = nb_loc Com.CatVar.LocBase; - nb_vars = StrMap.cardinal prog_vars; - nb_all_tmps; - nb_all_refs; - nb_all_itval; - sz_calculated = sz_loc Com.CatVar.LocComputed; - sz_input = sz_loc Com.CatVar.LocInput; - sz_base = sz_loc Com.CatVar.LocBase; - sz_vars; - sz_all_tmps; - } + Mir.{ prog.prog_stats with nb_all_tmps; sz_all_tmps; nb_all_refs } in - { prog with prog_vars; prog_targets; prog_stats } + Format.eprintf "%d %d %d@." nb_all_tmps sz_all_tmps nb_all_refs; + { prog with prog_functions; prog_targets; prog_stats } let proceed (p : Mast.program) (main_target : string) : program = (* à paramétrer *) @@ -2675,4 +2714,4 @@ let proceed (p : Mast.program) (main_target : string) : program = in prog |> complete_rdom_decls |> complete_vdom_decls |> convert_rules |> complete_rule_domains |> complete_chainings |> convert_verifs - |> complete_verif_calls |> complete_vars + |> complete_verif_calls |> complete_vars |> complete_vars_stack diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index 754d24dc7..58e3511ad 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -105,7 +105,6 @@ type target = { target_nb_tmps : int; target_sz_tmps : int; target_nb_refs : int; - target_nb_itval : int; target_prog : instruction Pos.marked list; } diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 1285b7eb6..f13f540d8 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -561,7 +561,6 @@ target_etc: target_nb_tmps = -1; target_sz_tmps = -1; target_nb_refs = -1; - target_nb_itval = -1; target_prog; } in Pos.same_pos_as (Target target) name :: l @@ -595,7 +594,6 @@ function_etc: target_nb_tmps = -1; target_sz_tmps = -1; target_nb_refs = -1; - target_nb_itval = -1; target_prog; } in Pos.same_pos_as (Function target) name :: l diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index fb70736b9..4d67a9b76 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -52,7 +52,6 @@ type stats = { nb_vars : int; nb_all_tmps : int; nb_all_refs : int; - nb_all_itval : int; sz_calculated : int; sz_base : int; sz_input : int; diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 537320588..901e0817d 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -42,7 +42,6 @@ type stats = { nb_vars : int; nb_all_tmps : int; nb_all_refs : int; - nb_all_itval : int; sz_calculated : int; sz_base : int; sz_input : int; diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index cfd692119..9e7c7dc27 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -517,8 +517,8 @@ struct | Com.Var.Arg -> (List.hd ctx.ctx_args).(vi) <- value | Com.Var.Res -> ctx.ctx_res <- value :: List.tl ctx.ctx_res) - and evaluate_stmt (canBlock : bool) (p : Mir.program) (ctx : ctx) - (stmt : Mir.m_instruction) : unit = + and evaluate_stmt (tn : string) (canBlock : bool) (p : Mir.program) + (ctx : ctx) (stmt : Mir.m_instruction) : unit = match Pos.unmark stmt with | Com.Affectation (Com.SingleFormula (m_var, vidx_opt, vexpr), _) -> ( let vari = get_var ctx (Pos.unmark m_var) in @@ -528,23 +528,23 @@ struct | Com.Affectation _ -> assert false | Com.IfThenElse (b, t, f) -> ( match evaluate_expr ctx p b with - | Number z when N.(z =. zero ()) -> evaluate_stmts canBlock p ctx f - | Number _ -> evaluate_stmts canBlock p ctx t + | Number z when N.(z =. zero ()) -> evaluate_stmts tn canBlock p ctx f + | Number _ -> evaluate_stmts tn canBlock p ctx t | Undefined -> ()) | Com.WhenDoElse (wdl, ed) -> let rec aux = function | (expr, dl, _) :: l -> ( match evaluate_expr ctx p expr with | Number z when N.(z =. zero ()) -> - evaluate_stmts canBlock p ctx (Pos.unmark ed) + evaluate_stmts tn canBlock p ctx (Pos.unmark ed) | Number _ -> - evaluate_stmts canBlock p ctx dl; + evaluate_stmts tn canBlock p ctx dl; aux l | Undefined -> aux l) | [] -> () in aux wdl - | Com.VerifBlock stmts -> evaluate_stmts true p ctx stmts + | Com.VerifBlock stmts -> evaluate_stmts tn true p ctx stmts | Com.ComputeTarget ((tn, _), args) -> let tf = Com.TargetMap.find tn p.program_targets in let rec set_args n = function @@ -620,7 +620,7 @@ struct List.iter (fun (v, _) -> ctx.ctx_ref.(ctx.ctx_ref_org + var_i) <- get_var ctx v; - evaluate_stmts canBlock p ctx stmts) + evaluate_stmts tn canBlock p ctx stmts) vars; List.iter (fun (vcs, expr) -> @@ -628,10 +628,12 @@ struct StrMap.iter (fun _ v -> if Com.CatVar.compare (Com.Var.cat v) vc = 0 then ( + (* Format.eprintf "%s ref %d/%d@." tn (ctx.ctx_ref_org + var_i) + (Array.length ctx.ctx_ref);*) ctx.ctx_ref.(ctx.ctx_ref_org + var_i) <- get_var ctx v; match evaluate_expr ctx p expr with | Number z when N.(z =. one ()) -> - evaluate_stmts canBlock p ctx stmts + evaluate_stmts tn canBlock p ctx stmts | _ -> ())) p.program_vars in @@ -680,7 +682,7 @@ struct vcs backup) backup var_params in - evaluate_stmts canBlock p ctx stmts; + evaluate_stmts tn canBlock p ctx stmts; List.iter (fun ((v : Com.Var.t), i, value) -> match v.scope with @@ -734,19 +736,19 @@ struct | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> assert false - and evaluate_stmts canBlock (p : Mir.program) (ctx : ctx) + and evaluate_stmts (tn : string) canBlock (p : Mir.program) (ctx : ctx) (stmts : Mir.m_instruction list) : unit = - try List.iter (evaluate_stmt canBlock p ctx) stmts + try List.iter (evaluate_stmt tn canBlock p ctx) stmts with BlockingError as b_err -> if canBlock then raise b_err - and evaluate_target canBlock (p : Mir.program) (ctx : ctx) (_tn : string) + and evaluate_target canBlock (p : Mir.program) (ctx : ctx) (tn : string) (tf : Mir.target_data) : unit = for i = 0 to tf.target_sz_tmps - 1 do ctx.ctx_tmps.(ctx.ctx_tmps_org + i) <- Undefined done; ctx.ctx_tmps_org <- ctx.ctx_tmps_org + tf.target_sz_tmps; ctx.ctx_ref_org <- ctx.ctx_ref_org + tf.target_nb_refs; - evaluate_stmts canBlock p ctx tf.target_prog; + evaluate_stmts tn canBlock p ctx tf.target_prog; ctx.ctx_ref_org <- ctx.ctx_ref_org - tf.target_nb_refs; ctx.ctx_tmps_org <- ctx.ctx_tmps_org - tf.target_sz_tmps @@ -761,7 +763,8 @@ struct Errors.raise_error "Unable to find main function of Bir program" in evaluate_target false p ctx p.program_main_target main_target; - evaluate_stmt false p ctx (Com.ExportErrors, Pos.no_pos) + evaluate_stmt p.program_main_target false p ctx + (Com.ExportErrors, Pos.no_pos) with RuntimeError (e, ctx) -> if !exit_on_rte then raise_runtime_as_structured e else raise (RuntimeError (e, ctx)) diff --git a/src/mlang/test_framework/test_interpreter.ml b/src/mlang/test_framework/test_interpreter.ml index 1875a4450..dce056506 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -202,9 +202,12 @@ let check_all_tests (p : Mir.program) (test_dir : string) raise e in let s, f = - Parmap.parfold ~chunksize:5 process (Parmap.A arr) ([], StrMap.empty) - (fun (old_s, old_f) (new_s, new_f) -> - (new_s @ old_s, StrMap.union (fun _ x1 x2 -> Some (x1 + x2)) old_f new_f)) + List.fold_left + (fun r n -> process n r) + ([], StrMap.empty) (Array.to_list arr) + (* Parmap.parfold ~chunksize:5 process (Parmap.A arr) ([], StrMap.empty) + (fun (old_s, old_f) (new_s, new_f) -> + (new_s @ old_s, StrMap.union (fun _ x1 x2 -> Some (x1 + x2)) old_f new_f))*) in (* finish "done!"; *) Cli.warning_flag := true; From 655b2f77ac1a73671fa5fd93936ecc5b2b0183da Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Wed, 15 Jan 2025 16:16:58 +0100 Subject: [PATCH 07/32] =?UTF-8?q?Dimensionnement=20des=20piles=20d'ex?= =?UTF-8?q?=C3=A9cution=20des=20variables.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/m_frontend/check_validity.ml | 10 ++++------ src/mlang/m_ir/mir_interpreter.ml | 2 -- src/mlang/test_framework/test_interpreter.ml | 9 +++------ 3 files changed, 7 insertions(+), 14 deletions(-) diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index 28f7102ff..f74dbb1bd 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -2493,9 +2493,6 @@ let complete_vars_stack (prog : program) : program = StrMap.fold fold t.target_tmp_vars nbIt in let target_nb_refs = List.length t.target_args + nbRef in - if target_nb_tmps + target_sz_tmps + target_nb_refs > 0 then - Format.eprintf "%s: %d %d %d@." (Pos.unmark t.target_name) - target_nb_tmps target_sz_tmps target_nb_refs; { t with target_nb_tmps; target_sz_tmps; target_nb_refs } in (StrMap.map map prog.prog_functions, StrMap.map map prog.prog_targets) @@ -2513,7 +2510,9 @@ let complete_vars_stack (prog : program) : program = | None -> ( let eval_call (t : Mast.target) = let nb, sz, nbRef = - (t.target_nb_tmps, t.target_sz_tmps, List.length t.target_args) + ( t.target_nb_tmps, + t.target_sz_tmps, + List.length t.target_args + t.target_nb_refs ) in let nb', sz', nbRef', tdata = aux_instrs tdata t.target_prog in let nb = nb + nb' in @@ -2666,7 +2665,7 @@ let complete_vars_stack (prog : program) : program = | Com.FuncCallLoop _ | Com.Loop _ -> assert false in let nb, sz, nbRef, _ = - let fold tn (t : Mast.target) (nb, sz, nbRef, tdata) = + let fold tn _ (nb, sz, nbRef, tdata) = let nb', sz', nbRef', tdata = aux_call tdata tn in (max nb nb', max sz sz', max nbRef nbRef', tdata) in @@ -2682,7 +2681,6 @@ let complete_vars_stack (prog : program) : program = let prog_stats = Mir.{ prog.prog_stats with nb_all_tmps; sz_all_tmps; nb_all_refs } in - Format.eprintf "%d %d %d@." nb_all_tmps sz_all_tmps nb_all_refs; { prog with prog_functions; prog_targets; prog_stats } let proceed (p : Mast.program) (main_target : string) : program = diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 9e7c7dc27..8a13f113f 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -628,8 +628,6 @@ struct StrMap.iter (fun _ v -> if Com.CatVar.compare (Com.Var.cat v) vc = 0 then ( - (* Format.eprintf "%s ref %d/%d@." tn (ctx.ctx_ref_org + var_i) - (Array.length ctx.ctx_ref);*) ctx.ctx_ref.(ctx.ctx_ref_org + var_i) <- get_var ctx v; match evaluate_expr ctx p expr with | Number z when N.(z =. one ()) -> diff --git a/src/mlang/test_framework/test_interpreter.ml b/src/mlang/test_framework/test_interpreter.ml index dce056506..1875a4450 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -202,12 +202,9 @@ let check_all_tests (p : Mir.program) (test_dir : string) raise e in let s, f = - List.fold_left - (fun r n -> process n r) - ([], StrMap.empty) (Array.to_list arr) - (* Parmap.parfold ~chunksize:5 process (Parmap.A arr) ([], StrMap.empty) - (fun (old_s, old_f) (new_s, new_f) -> - (new_s @ old_s, StrMap.union (fun _ x1 x2 -> Some (x1 + x2)) old_f new_f))*) + Parmap.parfold ~chunksize:5 process (Parmap.A arr) ([], StrMap.empty) + (fun (old_s, old_f) (new_s, new_f) -> + (new_s @ old_s, StrMap.union (fun _ x1 x2 -> Some (x1 + x2)) old_f new_f)) in (* finish "done!"; *) Cli.warning_flag := true; From 6aea338b4170f00799d829cb5a8dfc21fa6c7539 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 16 Jan 2025 18:32:21 +0100 Subject: [PATCH 08/32] =?UTF-8?q?It=C3=A9rateur=20sur=20les=20valeurs.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2022/cibles.m | 51 +++++++++++++++ mlang-deps | 2 +- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 52 +++++++++++++++ src/mlang/m_frontend/check_validity.ml | 63 +++++++++++++------ src/mlang/m_frontend/expand_macros.ml | 5 +- src/mlang/m_frontend/mast_to_mir.ml | 48 ++++++++++++-- src/mlang/m_frontend/mlexer.mll | 1 + src/mlang/m_frontend/mparser.mly | 10 +-- src/mlang/m_ir/com.ml | 9 +-- src/mlang/m_ir/com.mli | 2 +- src/mlang/m_ir/mir.ml | 5 +- src/mlang/m_ir/mir_interpreter.ml | 36 +++++++++++ 12 files changed, 247 insertions(+), 37 deletions(-) diff --git a/m_ext/2022/cibles.m b/m_ext/2022/cibles.m index 4448b011c..1e2e351b2 100644 --- a/m_ext/2022/cibles.m +++ b/m_ext/2022/cibles.m @@ -773,6 +773,56 @@ si nb_discordances() + nb_informatives() > 0 alors exporte_erreurs; finsi +fonction truc: +application: iliad; +argument: A0, A1; +resultat: RES; +variable temporaire: TOTO; +#V_IND_TRAIT = 4; +afficher_erreur "truc\n" indenter(2); +TOTO = 1; +iterer +: variable I +: A0 .. A1 increment 1 +: dans ( + si I = A0 alors + RES = 1; + sinon + RES = 2 * RES + TOTO; + finsi + afficher_erreur (I) ": " (RES) "\n"; +) +afficher_erreur indenter(-2); + +cible test_boucle: +application: iliad; +argument: I0, I1; +variable temporaire: TOTO; +TOTO = 0; +iterer +: variable I +: I0 .. I1 increment 0.7 +: 2 .. 1 increment -1 +: dans ( + iterer + : variable J + : -3 .. -1 increment 1 + : 1 .. 0 increment -1 + : dans ( + afficher_erreur nom(I) " = " (I) ", " nom(J) " = " (J) "\n"; + ) +) +TOTO = truc(TOTO, truc(4, truc(7, 9))); +afficher_erreur "truc: " (TOTO) "\n"; + +cible test: +application: iliad; +variable temporaire: A0, A1; +A0 = 1.6; +A1 = 3.6; +calculer cible test_boucle : avec A0, A1; + + cible enchainement_primitif: application: iliad; variable temporaire: EXPORTE_ERREUR; @@ -810,6 +860,7 @@ puis_quand nb_anomalies() = 0 faire finquand calculer cible trace_out; #afficher_erreur "]traite_double_liquidation2\n"; +#calculer cible test; # primitif iterpréteur diff --git a/mlang-deps b/mlang-deps index 3bfa74fff..34bd1f213 160000 --- a/mlang-deps +++ b/mlang-deps @@ -1 +1 @@ -Subproject commit 3bfa74fff694869c045470130cb18e9ebb3a7f33 +Subproject commit 34bd1f21399788e696d06a5f6fe521dc9c8df766 diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index 93e2fc34d..2d1a28415 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -642,6 +642,58 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@]@;}@;") vcs) var_params + | Iterate_values (m_var, var_intervals, stmts) -> + let pr fmt = Format.fprintf oc fmt in + let var = Pos.unmark m_var in + let itval_def = VID.gen_def var "" in + let itval_val = VID.gen_val var "" in + let itval_name = fresh_c_local "iterate_values" in + let itval_e0_val = Format.sprintf "%s_e0" itval_name in + let itval_e1_val = Format.sprintf "%s_e1" itval_name in + let itval_step_val = Format.sprintf "%s_step" itval_name in + let itval_e0_def = Format.sprintf "%s_def" itval_e0_val in + let itval_e1_def = Format.sprintf "%s_def" itval_e1_val in + let itval_step_def = Format.sprintf "%s_def" itval_step_val in + List.iter + (fun (e0, e1, step) -> + let locals_e0, set_e0, def_e0, value_e0 = + D.build_expression @@ generate_c_expr e0 + in + let locals_e1, set_e1, def_e1, value_e1 = + D.build_expression @@ generate_c_expr e1 + in + let locals_step, set_step, def_step, value_step = + D.build_expression @@ generate_c_expr step + in + pr "@[{@;"; + pr "char %s;@;double %s;@;" itval_e0_def itval_e0_val; + pr "char %s;@;double %s;@;" itval_e1_def itval_e1_val; + pr "char %s;@;double %s;@;" itval_step_def itval_step_val; + pr "%a" D.format_local_declarations locals_e0; + pr "%a" D.format_local_declarations locals_e1; + pr "%a" D.format_local_declarations locals_step; + pr "%a" (D.format_set_vars dgfip_flags) set_e0; + pr "%a" (D.format_set_vars dgfip_flags) set_e1; + pr "%a" (D.format_set_vars dgfip_flags) set_step; + pr "%a@;" (D.format_assign dgfip_flags itval_e0_def) def_e0; + pr "%a@;" (D.format_assign dgfip_flags itval_e1_def) def_e1; + pr "%a@;" (D.format_assign dgfip_flags itval_step_def) def_step; + pr "%a@;" (D.format_assign dgfip_flags itval_e0_val) value_e0; + pr "%a@;" (D.format_assign dgfip_flags itval_e1_val) value_e1; + pr "%a@;" (D.format_assign dgfip_flags itval_step_val) value_step; + pr "@[if(%s && %s && %s && %s != 0.0){@;" itval_e0_def + itval_e1_def itval_step_def itval_step_val; + pr + "@[for(%s = 1, %s = %s; (%s > 0.0 ? %s <= %s : %s >= %s); \ + %s = %s + %s){@;" + itval_def itval_val itval_e0_val itval_step_val itval_val + itval_e1_val itval_val itval_e1_val itval_val itval_val + itval_step_val; + pr "%a@]@;" (generate_stmts dgfip_flags program) stmts; + pr "}@;"; + pr "@]@;}@;"; + pr "@]@;}") + var_intervals | Restore (vars, var_params, stmts) -> let pr fmt = Format.fprintf oc fmt in pr "@[{@;"; diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index f74dbb1bd..f9a2ad26e 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -282,6 +282,12 @@ module Err = struct let msg = Format.sprintf "result missing in function %s" fn in Errors.raise_spanned_error msg pos + let forbidden_in_var_in_function vn fn pos = + let msg = + Format.sprintf "variable %s cannot be read in function %s" vn fn + in + Errors.raise_spanned_error msg pos + let forbidden_out_var_in_function vn fn pos = let msg = Format.sprintf "variable %s cannot be written in function %s" vn fn @@ -1350,7 +1356,6 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) let res_instr = Com.Iterate (var, vars, var_params, res_instrs) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il | Com.Iterate_values (var, var_intervals, instrs) -> - if is_rule then Err.insruction_forbidden_in_rules instr_pos; let var_pos = Pos.get_position var in let var_name = match Pos.unmark var with @@ -1375,18 +1380,30 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) tmp_vars = StrMap.add var_name (None, var_pos) env.tmp_vars; } in - List.iter - (fun (e0, e1) -> - ignore (check_expression false e0 env); - ignore (check_expression false e1 env)) - var_intervals; - let prog, res_instrs, _, _ = + let in_exprs = + List.fold_left + (fun in_exprs (e0, e1, step) -> + in_exprs + |> StrSet.union (check_expression false e0 env) + |> StrSet.union (check_expression false e1 env) + |> StrSet.union (check_expression false step env)) + StrSet.empty var_intervals + in + let prog, res_instrs, in_instrs, out_instrs = check_instructions instrs is_rule env' in let env = { env with prog } in let res_instr = Com.Iterate_values (var, var_intervals, res_instrs) in + let in_vars = + in_vars + |> StrSet.union + (in_exprs |> StrSet.union in_instrs |> StrSet.remove var_name) + in + let out_vars = + out_vars |> StrSet.union (out_instrs |> StrSet.remove var_name) + in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il | Com.Restore (vars, var_params, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; @@ -1539,15 +1556,24 @@ let check_target (is_function : bool) (t : Mast.target) (prog : program) : let res_var = target_result in let prog, target_prog = let env = { prog; tmp_vars; ref_vars; res_var } in - let prog, target_prog, _in_vars, out_vars = + let prog, target_prog, in_vars, out_vars = check_instructions t.target_prog is_function env in - (if is_function then - let vr = Pos.unmark (Option.get target_result) in - let bad_out_vars = StrSet.remove vr out_vars in - if StrSet.card bad_out_vars > 0 then - let vn = StrSet.min_elt bad_out_vars in - Err.forbidden_out_var_in_function vn tname tpos); + if is_function then ( + let vr = Pos.unmark (Option.get target_result) in + let bad_in_vars = + List.fold_left + (fun res (vn, _) -> StrSet.remove vn res) + in_vars target_args + |> StrSet.remove vr + in + let bad_out_vars = StrSet.remove vr out_vars in + (if StrSet.card bad_in_vars > 0 then + let vn = StrSet.min_elt bad_in_vars in + Err.forbidden_in_var_in_function vn tname tpos); + if StrSet.card bad_out_vars > 0 then + let vn = StrSet.min_elt bad_out_vars in + Err.forbidden_out_var_in_function vn tname tpos); (prog, target_prog) in let target = @@ -2590,12 +2616,13 @@ let complete_vars_stack (prog : program) : program = let nbRef = 1 + max nbRef nbRef' in (nb, sz, nbRef, tdata) | Com.Iterate_values (_, me2l, instrs) -> - let fold (nb, sz, nbRef, tdata) (me0, me1) = + let fold (nb, sz, nbRef, tdata) (me0, me1, mstep) = let nb', sz', nbRef', tdata = aux_expr tdata me0 in let nb'', sz'', nbRef'', tdata = aux_expr tdata me1 in - let nb = max nb (max nb' nb'') in - let sz = max sz (max sz' sz'') in - let nbRef = max nbRef (max nbRef' nbRef'') in + let nb''', sz''', nbRef''', tdata = aux_expr tdata mstep in + let nb = max nb (max nb' (max nb'' nb''')) in + let sz = max sz (max sz' (max sz'' sz''')) in + let nbRef = max nbRef (max nbRef' (max nbRef'' nbRef''')) in (nb, sz, nbRef, tdata) in let nb', sz', nbRef', tdata = diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index f1b90deea..768ed9af1 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -712,10 +712,11 @@ let rec expand_instruction (const_map : const_context) | Com.Iterate_values (name, var_intervals, instrs) -> let var_intervals' = List.map - (fun (e0, e1) -> + (fun (e0, e1, step) -> let e0' = expand_expression const_map ParamsMap.empty e0 in let e1' = expand_expression const_map ParamsMap.empty e1 in - (e0', e1')) + let step' = expand_expression const_map ParamsMap.empty step in + (e0', e1', step')) var_intervals in let instrs' = expand_instructions const_map instrs in diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index a635bdb88..0d732401b 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -172,7 +172,7 @@ let rec translate_expression (cats : Com.CatVar.data Com.CatVar.Map.t) let rec translate_prog (error_decls : Com.Error.t StrMap.t) (cats : Com.CatVar.data Com.CatVar.Map.t) (var_data : Com.Var.t StrMap.t) - (it_depth : int) prog = + (it_depth : int) (itval_depth : int) prog = let rec aux res = function | [] -> List.rev res | (Com.Affectation (Com.SingleFormula (v, idx, e), _), pos) :: il -> @@ -297,10 +297,48 @@ let rec translate_prog (error_decls : Com.Error.t StrMap.t) var_params in let prog_it = - translate_prog error_decls cats var_data (it_depth + 1) instrs + translate_prog error_decls cats var_data (it_depth + 1) itval_depth + instrs in let m_var = Pos.same_pos_as var vn in aux ((Com.Iterate (m_var, vars', var_params', prog_it), pos) :: res) il + | (Com.Iterate_values (vn, var_intervals, instrs), pos) :: il -> + let var_pos = Pos.get_position vn in + let var_name = + match Pos.unmark vn with + | Mast.Normal name -> name + | Mast.Generic _ -> assert false + in + (match StrMap.find_opt var_name var_data with + | Some v -> + let msg = + Format.asprintf "variable already declared %a" Pos.format_position + (Pos.get_position v.name) + in + Errors.raise_spanned_error msg pos + | _ -> ()); + let var = + Com.Var.new_temp ~name:(var_name, var_pos) ~is_table:None + ~loc_int:itval_depth + in + let var_data = StrMap.add var_name var var_data in + let var_intervals' = + List.map + (fun (e0, e1, step) -> + let e0' = translate_expression cats var_data e0 in + let e1' = translate_expression cats var_data e1 in + let step' = translate_expression cats var_data step in + (e0', e1', step')) + var_intervals + in + let prog_it = + translate_prog error_decls cats var_data it_depth (itval_depth + 1) + instrs + in + let m_var = Pos.same_pos_as var vn in + aux + ((Com.Iterate_values (m_var, var_intervals', prog_it), pos) :: res) + il | (Com.Restore (vars, var_params, instrs), pos) :: il -> let vars' = List.map @@ -325,7 +363,7 @@ let rec translate_prog (error_decls : Com.Error.t StrMap.t) var_params in let prog_rest = - translate_prog error_decls cats var_data it_depth instrs + translate_prog error_decls cats var_data it_depth itval_depth instrs in aux ((Com.Restore (vars', var_params', prog_rest), pos) :: res) il | (Com.RaiseError (err_name, var_opt), pos) :: il -> @@ -370,7 +408,7 @@ let get_targets (is_function : bool) (error_decls : Com.Error.t StrMap.t) t.target_args in let target_sz_tmps = t.target_sz_tmps in - let tmp_var_data, _ = + let tmp_var_data, itval_depth = StrMap.fold (fun name ((_, pos), size) (tmp_var_data, n) -> let size' = Pos.unmark_option (Mast.get_table_size_opt size) in @@ -410,7 +448,7 @@ let get_targets (is_function : bool) (error_decls : Com.Error.t StrMap.t) let target_prog = translate_prog error_decls cats tmp_var_data (List.length target_args - target_nb_refs) - t.target_prog + itval_depth t.target_prog in let target_data = Mir. diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index d2cedccb4..2be7658be 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -91,6 +91,7 @@ rule token = parse | "finquand" -> ENDWHEN | "finsi" -> ENDIF | "fonction" -> FONCTION + | "increment" -> STEP | "indefini" -> UNDEFINED | "indenter" -> INDENT | "informative" -> INFORMATIVE diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index f13f540d8..15e800768 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -58,7 +58,7 @@ along with this program. If not, see . %token INFORMATIVE OUTPUT FONCTION VARIABLE ATTRIBUT %token BASE GIVEN_BACK COMPUTABLE BY_DEFAULT %token DOMAIN SPECIALIZE AUTHORIZE VERIFIABLE -%token EVENT VALUE +%token EVENT VALUE STEP %token EOF @@ -685,7 +685,7 @@ instruction: | (`VarInterval _, _) :: _ -> let var_intervals = let fold var_intervals = function - | (`VarInterval (e0, e1), _) -> (e0, e1) :: var_intervals + | (`VarInterval (e0, e1, step), _) -> (e0, e1, step) :: var_intervals | (`VarList _, pos) | (`VarCatsIt _, pos) -> Errors.raise_spanned_error "variable descriptors forbidden in values iteration" pos in @@ -830,8 +830,10 @@ it_param: in `VarCatsIt (vcats, expr) } -| expr0 = with_pos(expression) RANGE expr1 = with_pos(expression) COLON { - `VarInterval (expr0, expr1) +| expr0 = with_pos(expression) RANGE expr1 = with_pos(expression) + STEP step = with_pos(expression) COLON { + + `VarInterval (expr0, expr1, step) } it_param_with_expr: diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index fa3384c12..260aae7d8 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -483,7 +483,7 @@ type ('v, 'e) instruction = * ('v, 'e) m_instruction list | Iterate_values of 'v Pos.marked - * ('v m_expression * 'v m_expression) list + * ('v m_expression * 'v m_expression * 'v m_expression) list * ('v, 'e) m_instruction list | Restore of 'v Pos.marked list @@ -776,9 +776,10 @@ let rec format_instruction form_var form_err = var_params; Format.fprintf fmt "@[ %a@]@\n)@\n" form_instrs itb | Iterate_values (var, var_intervals, itb) -> - let format_var_intervals fmt (e0, e1) = - Format.fprintf fmt ": %a .. %a@\n" form_expr (Pos.unmark e0) form_expr - (Pos.unmark e1) + let format_var_intervals fmt (e0, e1, step) = + Format.fprintf fmt ": %a .. %a increment %a@\n" form_expr + (Pos.unmark e0) form_expr (Pos.unmark e1) form_expr + (Pos.unmark step) in Format.fprintf fmt "iterate variable %a@;: %a@;: dans (" form_var (Pos.unmark var) diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index b2ac9167b..1229ad48e 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -336,7 +336,7 @@ type ('v, 'e) instruction = * ('v, 'e) m_instruction list | Iterate_values of 'v Pos.marked - * ('v m_expression * 'v m_expression) list + * ('v m_expression * 'v m_expression * 'v m_expression) list * ('v, 'e) m_instruction list | Restore of 'v Pos.marked list diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 4d67a9b76..49d9bd0c3 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -262,10 +262,11 @@ let expand_functions (p : program) : program = | Iterate_values (v_id, var_intervals, instrs) -> let var_intervals' = List.map - (fun (e0, e1) -> + (fun (e0, e1, step) -> let e0' = expand_functions_expr e0 in let e1' = expand_functions_expr e1 in - (e0', e1')) + let step' = expand_functions_expr step in + (e0', e1', step')) var_intervals in let instrs' = List.map map_instr instrs in diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 8a13f113f..84be16716 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -637,6 +637,42 @@ struct in Com.CatVar.Map.iter eval vcs) var_params + | Com.Iterate_values ((m_var : Com.Var.t Pos.marked), var_intervals, stmts) + -> + let var = Pos.unmark m_var in + let var_i = + match var.loc with LocTmp (_, i) -> i | _ -> assert false + in + List.iter + (fun (e0, e1, step) -> + match evaluate_expr ctx p e0 with + | Number z0 -> ( + match evaluate_expr ctx p e1 with + | Number z1 -> ( + match evaluate_expr ctx p step with + | Number zStep when not N.(is_zero zStep) -> + if N.(zStep > zero ()) then + let rec loop i = + if N.(i <=. z1) then ( + ctx.ctx_tmps.(ctx.ctx_tmps_org + var_i) <- + Number i; + evaluate_stmts tn canBlock p ctx stmts; + loop N.(i +. zStep)) + in + loop z0 + else + let rec loop i = + if N.(i >=. z1) then ( + ctx.ctx_tmps.(ctx.ctx_tmps_org + var_i) <- + Number i; + evaluate_stmts tn canBlock p ctx stmts; + loop N.(i +. zStep)) + in + loop z0 + | _ -> ()) + | Undefined -> ()) + | Undefined -> ()) + var_intervals | Com.Restore (vars, var_params, stmts) -> let backup = List.fold_left From 2ed57c82aee78496f9bead8ce14acfd767fd09b4 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Mon, 20 Jan 2025 19:33:41 +0100 Subject: [PATCH 09/32] =?UTF-8?q?Fonction=20nb=5Fevenements=20pour=20l'int?= =?UTF-8?q?erpr=C3=A9teur?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2022/cibles.m | 51 ------------------ m_ext/2023/cibles.m | 52 ++++++++++++++++++ src/mlang/m_frontend/check_validity.ml | 6 ++- src/mlang/m_frontend/parse_utils.ml | 1 + src/mlang/m_ir/com.ml | 2 + src/mlang/m_ir/com.mli | 1 + src/mlang/m_ir/mir_interpreter.ml | 75 ++++++++++++++++++-------- src/mlang/m_ir/mir_interpreter.mli | 4 ++ src/mlang/utils/pp.ml | 4 ++ src/mlang/utils/pp.mli | 4 ++ 10 files changed, 127 insertions(+), 73 deletions(-) diff --git a/m_ext/2022/cibles.m b/m_ext/2022/cibles.m index 1e2e351b2..4448b011c 100644 --- a/m_ext/2022/cibles.m +++ b/m_ext/2022/cibles.m @@ -773,56 +773,6 @@ si nb_discordances() + nb_informatives() > 0 alors exporte_erreurs; finsi -fonction truc: -application: iliad; -argument: A0, A1; -resultat: RES; -variable temporaire: TOTO; -#V_IND_TRAIT = 4; -afficher_erreur "truc\n" indenter(2); -TOTO = 1; -iterer -: variable I -: A0 .. A1 increment 1 -: dans ( - si I = A0 alors - RES = 1; - sinon - RES = 2 * RES + TOTO; - finsi - afficher_erreur (I) ": " (RES) "\n"; -) -afficher_erreur indenter(-2); - -cible test_boucle: -application: iliad; -argument: I0, I1; -variable temporaire: TOTO; -TOTO = 0; -iterer -: variable I -: I0 .. I1 increment 0.7 -: 2 .. 1 increment -1 -: dans ( - iterer - : variable J - : -3 .. -1 increment 1 - : 1 .. 0 increment -1 - : dans ( - afficher_erreur nom(I) " = " (I) ", " nom(J) " = " (J) "\n"; - ) -) -TOTO = truc(TOTO, truc(4, truc(7, 9))); -afficher_erreur "truc: " (TOTO) "\n"; - -cible test: -application: iliad; -variable temporaire: A0, A1; -A0 = 1.6; -A1 = 3.6; -calculer cible test_boucle : avec A0, A1; - - cible enchainement_primitif: application: iliad; variable temporaire: EXPORTE_ERREUR; @@ -860,7 +810,6 @@ puis_quand nb_anomalies() = 0 faire finquand calculer cible trace_out; #afficher_erreur "]traite_double_liquidation2\n"; -#calculer cible test; # primitif iterpréteur diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index f1120323b..f6bcb2621 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -773,6 +773,57 @@ si nb_discordances() + nb_informatives() > 0 alors exporte_erreurs; finsi + +fonction truc: +application: iliad; +argument: A0, A1; +resultat: RES; +variable temporaire: TOTO; +#V_IND_TRAIT = 4; +afficher_erreur "truc\n" indenter(2); +TOTO = 1; +iterer +: variable I +: A0 .. A1 increment 1 +: dans ( + si I = A0 alors + RES = 1; + sinon + RES = 2 * RES + TOTO; + finsi + afficher_erreur (I) ": " (RES) "\n"; +) +afficher_erreur indenter(-2); + +cible test_boucle: +application: iliad; +argument: I0, I1; +variable temporaire: TOTO; +TOTO = 0; +iterer +: variable I +: I0 .. I1 increment 0.7 +: 2 .. 1 increment -1 +: dans ( + iterer + : variable J + : -3 .. -1 increment 1 + : 1 .. 0 increment -1 + : dans ( + afficher_erreur nom(I) " = " (I) ", " nom(J) " = " (J) "\n"; + ) +) +TOTO = truc(TOTO, truc(4, truc(7, 9))); +afficher_erreur "truc: " (TOTO) "\n"; + +cible test: +application: iliad; +variable temporaire: A0, A1; +A0 = 1.6; +A1 = 3.6; +calculer cible test_boucle : avec A0, A1; +afficher_erreur "nb_evenements() = " (nb_evenements()) "\n"; + cible enchainement_primitif: application: iliad; variable temporaire: EXPORTE_ERREUR; @@ -810,6 +861,7 @@ puis_quand nb_anomalies() = 0 faire finquand calculer cible trace_out; #afficher_erreur "]traite_double_liquidation2\n"; +calculer cible test; # primitif iterpréteur diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index f9a2ad26e..5aed941e3 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -1024,6 +1024,9 @@ let rec fold_var_expr | Com.PresentFunc -> if is_filter then Err.forbidden_expresion_in_filter expr_pos; check_func 1 + | Com.NbEvents -> + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + check_func 0 | Com.Func fn -> if is_filter then Err.forbidden_expresion_in_filter expr_pos; let fd = @@ -2171,7 +2174,8 @@ let eval_expr_verif (prog : program) (verif : verif) | [ Some f ] when f = 0.0 -> None | [ r ] -> r | _ -> assert false) - | Com.PresentFunc | Com.Multimax | Com.Func _ -> assert false) + | Com.PresentFunc | Com.Multimax | Com.NbEvents | Com.Func _ -> + assert false) | Comparison (op, e0, e1) -> ( match (aux e0, aux e1) with | None, _ | _, None -> None diff --git a/src/mlang/m_frontend/parse_utils.ml b/src/mlang/m_frontend/parse_utils.ml index 3cbb37d78..c87d2ab9c 100644 --- a/src/mlang/m_frontend/parse_utils.ml +++ b/src/mlang/m_frontend/parse_utils.ml @@ -116,6 +116,7 @@ let parse_function_name f_name = | "supzero" -> Supzero | "numero_verif" -> VerifNumber | "numero_compl" -> ComplNumber + | "nb_evenements" -> NbEvents | fn -> Func fn in Pos.map_under_mark map f_name diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 260aae7d8..a2b62e7f1 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -387,6 +387,7 @@ type func = | Supzero (** ??? *) | VerifNumber | ComplNumber + | NbEvents | Func of string type 'v expression = @@ -618,6 +619,7 @@ let format_func fmt f = | Supzero -> "supzero" | VerifNumber -> "numero_verif" | ComplNumber -> "numero_compl" + | NbEvents -> "nb_evenements" | Func fn -> fn) let rec format_expression form_var fmt = diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 1229ad48e..81bb884d0 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -245,6 +245,7 @@ type func = | Supzero (** ??? *) | VerifNumber | ComplNumber + | NbEvents | Func of string type 'v expression = diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 84be16716..274deae79 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -47,6 +47,7 @@ module type S = sig mutable ctx_nb_bloquantes : int; mutable ctx_finalized_anos : (Com.Error.t * string option) list; mutable ctx_exported_anos : (Com.Error.t * string option) list; + mutable ctx_events : Com.event_value StrMap.t IntMap.t; } val empty_ctx : Mir.program -> ctx @@ -57,6 +58,9 @@ module type S = sig val update_ctx_with_inputs : ctx -> Com.literal Com.Var.Map.t -> unit + val update_ctx_with_events : + ctx -> Mir.program -> Com.event_value IntMap.t list -> unit + type run_error = | NanOrInf of string * Mir.expression Pos.marked | StructuredError of @@ -123,6 +127,7 @@ struct mutable ctx_nb_bloquantes : int; mutable ctx_finalized_anos : (Com.Error.t * string option) list; mutable ctx_exported_anos : (Com.Error.t * string option) list; + mutable ctx_events : Com.event_value StrMap.t IntMap.t; } let empty_ctx (p : Mir.program) : ctx = @@ -147,6 +152,7 @@ struct ctx_nb_bloquantes = 0; ctx_finalized_anos = []; ctx_exported_anos = []; + ctx_events = IntMap.empty; } let literal_to_value (l : Com.literal) : value = @@ -174,6 +180,50 @@ struct ctx.ctx_tgv.(Com.Var.loc_int var) <- value) value_inputs + let update_ctx_with_events (ctx : ctx) (p : Mir.program) + (events : Com.event_value IntMap.t list) : unit = + let ctx_events = + let fold (map, idx) (evt : Com.event_value IntMap.t) = + let foldEvt id ev map = + match IntMap.find_opt id p.program_event_field_idxs with + | Some fname -> ( + match StrMap.find_opt fname p.program_event_fields with + | Some ef -> ( + match (ev, ef.is_var) with + | Com.Numeric _, false | Com.RefVar _, true -> + StrMap.add fname ev map + | _ -> Errors.raise_error "Wrong event field type") + | None -> Errors.raise_error "Wrong event field") + | None -> + Errors.raise_error + (Format.sprintf "Too much event fields: index %d for size %d" id + (IntMap.cardinal p.program_event_field_idxs)) + in + (IntMap.add idx (IntMap.fold foldEvt evt StrMap.empty) map, idx + 1) + in + fst (List.fold_left fold (IntMap.empty, 0) events) + in + let max_field_length = + StrMap.fold + (fun s _ r -> max r (String.length s)) + p.program_event_fields 0 + in + let pp_field fmt s = + let l = String.length s in + Format.fprintf fmt "%s%s" s (String.make (max_field_length - l + 1) ' ') + in + let pp_ev fmt = function + | Com.Numeric None -> Pp.string fmt "indefini" + | Com.Numeric (Some f) -> Pp.float fmt f + | Com.RefVar v -> Pp.string fmt v + in + IntMap.iter + (fun i m -> + Format.eprintf "%d@." i; + StrMap.iter (fun s v -> Format.eprintf " %a%a@." pp_field s pp_ev v) m) + ctx_events; + ctx.ctx_events <- ctx_events + type run_error = | NanOrInf of string * Mir.expression Pos.marked | StructuredError of @@ -419,6 +469,9 @@ struct match !maxi with | None -> Undefined | Some f -> Number (N.of_int f))) + | FuncCall ((NbEvents, _), _) -> + let card = IntMap.cardinal ctx.ctx_events in + Number (N.of_int @@ Int64.of_int @@ card) | FuncCall ((Func fn, _), args) -> let fd = Com.TargetMap.find fn p.program_functions in let atab = Array.of_list (List.map (evaluate_expr ctx p) args) in @@ -904,6 +957,7 @@ let evaluate_program (p : Mir.program) (inputs : Com.literal Com.Var.Map.t) let module Interp = (val get_interp sort roundops : S) in let ctx = Interp.empty_ctx p in Interp.update_ctx_with_inputs ctx inputs; + Interp.update_ctx_with_events ctx p events; Interp.evaluate_program p ctx; let varMap = let fold name (var : Com.Var.t) res = @@ -919,27 +973,6 @@ let evaluate_program (p : Mir.program) (inputs : Com.literal Com.Var.Map.t) in StrMap.fold fold p.program_vars StrMap.empty in - let _eventMap = - let fold (map, idx) (evt : Com.event_value IntMap.t) = - let foldEvt id ev map = - match IntMap.find_opt id p.program_event_field_idxs with - | Some fname -> ( - match StrMap.find_opt fname p.program_event_fields with - | Some ef -> ( - match (ev, ef.is_var) with - | Com.Numeric _, false | Com.RefVar _, true -> - StrMap.add fname ev map - | _ -> Errors.raise_error "Wrong event field type") - | None -> Errors.raise_error "Wrong event field") - | None -> - Errors.raise_error - (Format.sprintf "Too much event fields: index %d for size %d" id - (IntMap.cardinal p.program_event_field_idxs)) - in - (IntMap.add idx (IntMap.fold foldEvt evt StrMap.empty) map, idx + 1) - in - fst (List.fold_left fold (IntMap.empty, 0) events) - in let anoSet = let fold res (e, _) = StrSet.add (Pos.unmark e.Com.Error.name) res in List.fold_left fold StrSet.empty ctx.ctx_exported_anos diff --git a/src/mlang/m_ir/mir_interpreter.mli b/src/mlang/m_ir/mir_interpreter.mli index edc70dfc0..55a8aa5e5 100644 --- a/src/mlang/m_ir/mir_interpreter.mli +++ b/src/mlang/m_ir/mir_interpreter.mli @@ -68,6 +68,7 @@ module type S = sig mutable ctx_nb_bloquantes : int; mutable ctx_finalized_anos : (Com.Error.t * string option) list; mutable ctx_exported_anos : (Com.Error.t * string option) list; + mutable ctx_events : Com.event_value StrMap.t IntMap.t; } (** Interpretation context *) @@ -79,6 +80,9 @@ module type S = sig val update_ctx_with_inputs : ctx -> Com.literal Com.Var.Map.t -> unit + val update_ctx_with_events : + ctx -> Mir.program -> Com.event_value IntMap.t list -> unit + (** Interpreter runtime errors *) type run_error = | NanOrInf of string * Mir.expression Pos.marked diff --git a/src/mlang/utils/pp.ml b/src/mlang/utils/pp.ml index 4a62ef722..ebbff394c 100644 --- a/src/mlang/utils/pp.ml +++ b/src/mlang/utils/pp.ml @@ -14,6 +14,10 @@ let nil _ _ = () let string = Format.pp_print_string +let int = Format.pp_print_int + +let float = Format.pp_print_float + let option pp_elt fmt opt = Format.pp_print_option pp_elt fmt opt let list sep pp_elt fmt l = diff --git a/src/mlang/utils/pp.mli b/src/mlang/utils/pp.mli index 894618f2a..0e660cdb7 100644 --- a/src/mlang/utils/pp.mli +++ b/src/mlang/utils/pp.mli @@ -14,6 +14,10 @@ val nil : t -> 'a -> unit val string : t -> string -> unit +val int : t -> int -> unit + +val float : t -> float -> unit + val option : (t -> 'a -> unit) -> t -> 'a option -> unit val list : (unit, t, unit) format -> (t -> 'a -> unit) -> t -> 'a list -> unit From 297bfed6a25d4fc1ed22206c2c6589ee35b95c46 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 21 Jan 2025 16:11:48 +0100 Subject: [PATCH 10/32] =?UTF-8?q?Accesseurs=20pour=20les=20=C3=A9v=C3=A9ne?= =?UTF-8?q?ments.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- examples/dgfip_c/ml_primitif/ml_driver/m.ml | 1 + .../dgfip_c/ml_primitif/ml_driver/main.ml | 20 +++-- .../ml_primitif/ml_driver/read_test.ml | 21 +++-- .../dgfip_c/ml_primitif/ml_driver/stubs.c | 46 +++++++++++ m_ext/2023/cibles.m | 33 +++++++- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 56 ++++++++++++- .../backend_compilers/dgfip_gen_files.ml | 82 ++++++++++++++----- src/mlang/m_frontend/check_validity.ml | 42 ++++++++-- src/mlang/m_frontend/check_validity.mli | 2 +- src/mlang/m_frontend/expand_macros.ml | 9 ++ src/mlang/m_frontend/mast_to_mir.ml | 10 +++ src/mlang/m_frontend/mlexer.mll | 1 + src/mlang/m_frontend/mparser.mly | 36 ++++---- src/mlang/m_ir/com.ml | 16 +++- src/mlang/m_ir/com.mli | 5 +- src/mlang/m_ir/mir.ml | 7 ++ src/mlang/m_ir/mir.mli | 1 + src/mlang/m_ir/mir_interpreter.ml | 54 ++++++++++-- src/mlang/m_ir/mir_interpreter.mli | 6 +- src/mlang/test_framework/test_interpreter.ml | 21 ++++- 20 files changed, 389 insertions(+), 80 deletions(-) diff --git a/examples/dgfip_c/ml_primitif/ml_driver/m.ml b/examples/dgfip_c/ml_primitif/ml_driver/m.ml index 94a819db3..e15dee7d2 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/m.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/m.ml @@ -148,4 +148,5 @@ external get_err_list : TGV.t -> string list = "ml_get_err_list" external annee_calc : unit -> int = "ml_annee_calc" external export_errs : TGV.t -> unit = "ml_export_errs" external enchainement_primitif : TGV.t -> unit = "ml_enchainement_primitif" +external set_evt_list : TGV.t -> (float * float * string * float * float * float * float * float * float) list-> unit = "ml_set_evt_list" diff --git a/examples/dgfip_c/ml_primitif/ml_driver/main.ml b/examples/dgfip_c/ml_primitif/ml_driver/main.ml index 310d12d81..1f0bde022 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/main.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/main.ml @@ -3,29 +3,30 @@ open Common let read_test filename = let test = Read_test.read_test filename in let tgv = M.TGV.alloc_tgv () in - let res_prim, ctl_prim = - let fold_prim (res_prim, ctl_prim) s = + let evt_list, res_prim, ctl_prim = + let fold_prim (evt_list, res_prim, ctl_prim) s = match s with | `EntreesPrimitif pl -> List.iter (fun (code, montant) -> M.TGV.set tgv code montant) pl; - res_prim, ctl_prim + evt_list, res_prim, ctl_prim | `ResultatsPrimitif pl -> let res_prim = let fold res (code, montant) = StrMap.add code montant res in List.fold_left fold res_prim pl in - res_prim, ctl_prim + evt_list, res_prim, ctl_prim | `ControlesPrimitif el -> let ctl_prim = let fold err e = StrSet.add e err in List.fold_left fold ctl_prim el in - res_prim, ctl_prim - | _ -> res_prim, ctl_prim + evt_list, res_prim, ctl_prim + | `EntreesRappels evt_list -> evt_list, res_prim, ctl_prim + | _ -> evt_list, res_prim, ctl_prim in - List.fold_left fold_prim (StrMap.empty, StrSet.empty) test + List.fold_left fold_prim ([], StrMap.empty, StrSet.empty) test in - tgv, res_prim, ctl_prim + tgv, evt_list, res_prim, ctl_prim let check_result tgv err expected_tgv expected_err = let result = ref true in @@ -130,7 +131,8 @@ let compare_dump out outexp = let run_test test_file annee_exec = Printf.printf "Testing %s...\n%!" test_file; let annee_calc = M.annee_calc () in - let tgv, res_prim, ctl_prim = read_test test_file in + let tgv, evt_list, res_prim, ctl_prim = read_test test_file in + M.set_evt_list tgv evt_list; let annee_revenu = M.TGV.get_int_def tgv "ANREV" annee_calc in if annee_revenu <> annee_calc then ( Printf.eprintf diff --git a/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml b/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml index ce7967859..2384728f2 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml @@ -55,16 +55,25 @@ let parse_entree_corr s = | _ -> failwith (Printf.sprintf "Ligne entree correctif invalide: '%s'" s) let parse_entree_rap s = + let err () = failwith (Printf.sprintf "Ligne entree rappel invalide: '%s'" s) in let sl = String.split_on_char '/' s in match sl with | [ num_evt; num_rappel; code; montant; sens; penalite; base_tl; date_evt; ind20 ] -> - let date_evt = convert_int date_evt in - (convert_int num_evt, convert_int num_rappel, - code, convert_float montant, sens.[0], - convert_int penalite, convert_float base_tl, - (date_evt mod 10000, date_evt / 10000), String.equal ind20 "1") (* TODO: improve *) - | _ -> failwith (Printf.sprintf "Ligne entree rappel invalide: '%s'" s) + let sens_float = + if String.length sens = 0 then err (); + match sens.[0] with + | 'R' -> 0.0 + | 'C' -> 1.0 + | 'M' -> 2.0 + | 'P' -> 3.0 + | _ -> err () + in + (convert_float num_evt, convert_float num_rappel, + code, convert_float montant, sens_float, + convert_float penalite, convert_float base_tl, + convert_float date_evt, convert_float ind20) (* TODO: improve *) + | _ -> err () let read_section_contents f parsefun = let rec aux contents = diff --git a/examples/dgfip_c/ml_primitif/ml_driver/stubs.c b/examples/dgfip_c/ml_primitif/ml_driver/stubs.c index 741a412d4..fff6ca7eb 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/stubs.c +++ b/examples/dgfip_c/ml_primitif/ml_driver/stubs.c @@ -213,3 +213,49 @@ CAMLprim value ml_enchainement_primitif(value mlTgv) { CAMLreturn(mlErrListOut); } +CAMLprim value ml_set_evt_list(value mlTgv, value mlEvtList) { + CAMLparam2(mlTgv, mlEvtList); + CAMLlocal2(mlList, mlEvt); + + T_irdata *tgv = Tgv_val(mlTgv); + int len = 0; + mlList = mlEvtList; + while (mlList != Val_emptylist) { + len++; + mlList = Field(mlList, 1); + } + if (len > 0) { + tgv->events = (T_event *)malloc(len * sizeof (T_event)); + } else { + tgv->events = NULL; + } + tgv->nb_events = len; + + int i = 0; + mlList = mlEvtList; + while (mlList != Val_emptylist) { + mlEvt = Field(mlList, 0); + tgv->events[i].field_numero_def = 1; + tgv->events[i].field_numero_val = Double_val(Field(mlEvt, 0)); + tgv->events[i].field_rappel_def = 1; + tgv->events[i].field_rappel_val = Double_val(Field(mlEvt, 1)); + tgv->events[i].field_code_var = cherche_var(tgv, String_val(Field(mlEvt, 2))); + tgv->events[i].field_montant_def = 1; + tgv->events[i].field_montant_val = Double_val(Field(mlEvt, 3)); + tgv->events[i].field_sens_def = 1; + tgv->events[i].field_sens_val = Double_val(Field(mlEvt, 4)); + tgv->events[i].field_penalite_def = 1; + tgv->events[i].field_penalite_val = Double_val(Field(mlEvt, 5)); + tgv->events[i].field_base_tl_def = 1; + tgv->events[i].field_base_tl_val = Double_val(Field(mlEvt, 6)); + tgv->events[i].field_date_def = 1; + tgv->events[i].field_date_val = Double_val(Field(mlEvt, 7)); + tgv->events[i].field_2042_rect_def = 1; + tgv->events[i].field_2042_rect_val = Double_val(Field(mlEvt, 8)); + i++; + mlList = Field(mlList, 1); + } + CAMLreturn(Val_unit); +} + + diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index f6bcb2621..bc8c3a767 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -773,7 +773,6 @@ si nb_discordances() + nb_informatives() > 0 alors exporte_erreurs; finsi - fonction truc: application: iliad; argument: A0, A1; @@ -823,6 +822,38 @@ si nb_discordances() + nb_informatives() > 0 alors A1 = 3.6; calculer cible test_boucle : avec A0, A1; afficher_erreur "nb_evenements() = " (nb_evenements()) "\n"; +iterer +: variable I +: 0 .. (nb_evenements() - 1) increment 1 +: dans ( + afficher_erreur (I) ": "; + si (present(champ_evenement(I, numero))) alors afficher_erreur (champ_evenement(I, numero)); finsi + afficher_erreur "/"; + si (present(champ_evenement(I, rappel))) alors afficher_erreur (champ_evenement(I, rappel)); finsi + afficher_erreur "/" alias(I, code) "," nom(I, code) "/"; + si (present(champ_evenement(I, montant))) alors afficher_erreur (champ_evenement(I, montant)); finsi + afficher_erreur "/"; + si (present(champ_evenement(I, sens))) alors + si (champ_evenement(I, sens) = 0) alors + afficher_erreur "R"; + sinon_si (champ_evenement(I, sens) = 1) alors + afficher_erreur "C"; + sinon_si (champ_evenement(I, sens) = 2) alors + afficher_erreur "M"; + sinon_si (champ_evenement(I, sens) = 3) alors + afficher_erreur "P"; + finsi + finsi + afficher_erreur "/"; + si (present(champ_evenement(I, penalite))) alors afficher_erreur (champ_evenement(I, penalite)); finsi + afficher_erreur "/"; + si (present(champ_evenement(I, base_tl))) alors afficher_erreur (champ_evenement(I, base_tl)); finsi + afficher_erreur "/"; + si (present(champ_evenement(I, date))) alors afficher_erreur (champ_evenement(I, date)); finsi + afficher_erreur "/"; + si (present(champ_evenement(I, 2042_rect))) alors afficher_erreur (champ_evenement(I, 2042_rect)); finsi + afficher_erreur "\n"; +) cible enchainement_primitif: application: iliad; diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index 2d1a28415..67c2193a3 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -288,6 +288,10 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : D.dfun "multimax" [ bound.value_comp; D.m_var v2 PassPointer Val ] in D.build_transitive_composition { set_vars; def_test; value_comp } + | FuncCall ((NbEvents, _), _) -> + let def_test = D.dinstr "1.0" in + let value_comp = D.dinstr "nb_evenements(irdata)" in + D.build_transitive_composition { set_vars = []; def_test; value_comp } | FuncCall ((Func fn, _), args) -> let res = fresh_c_local "result" in let def_res = Pp.spr "def_%s" res in @@ -343,6 +347,33 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : (Format.sprintf "attribut_%s((T_varinfo *)%s)" (Pos.unmark a) ptr) in D.build_transitive_composition { set_vars = []; def_test; value_comp } + | EventField (me, f) -> + let fn = Format.sprintf "event_field_%s" (Pos.unmark f) in + let res = fresh_c_local "result" in + let def_res = Pp.spr "def_%s" res in + let val_res = Pp.spr "val_%s" res in + let def_res_ptr = Pp.spr "&%s" def_res in + let val_res_ptr = Pp.spr "&%s" val_res in + let set_vars, arg_exprs = + let e = generate_c_expr me in + (e.set_vars, [ e.def_test; e.value_comp ]) + in + let d_fun = + D.dfun fn + ([ + D.dlow_level "irdata"; + D.dlow_level def_res_ptr; + D.dlow_level val_res_ptr; + ] + @ arg_exprs) + in + let set_vars = + set_vars + @ [ (D.Def, def_res, d_fun); (D.Val, val_res, D.dlow_level val_res) ] + in + let def_test = D.dinstr def_res in + let value_comp = D.dinstr val_res in + D.build_transitive_composition { set_vars; def_test; value_comp } | Size var -> let ptr = VID.gen_info_ptr (Pos.unmark var) in let def_test = D.dinstr "1.0" in @@ -364,8 +395,7 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : let def_test = D.dinstr "1.0" in let value_comp = D.dinstr "nb_bloquantes(irdata)" in D.build_transitive_composition { set_vars = []; def_test; value_comp } - | NbCategory _ -> assert false - | FuncCallLoop _ | Loop _ -> assert false + | NbCategory _ | FuncCallLoop _ | Loop _ -> assert false let generate_m_assign (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t) (offset : D.offset) (oc : Format.formatter) (se : D.expression_composition) @@ -517,6 +547,26 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) in let print_val = fresh_c_local "mpp_print" in let print_def = print_val ^ "_d" in + let print_name_or_alias name_or_alias e f = + let locals, set, def, value = D.build_expression @@ generate_c_expr e in + Format.fprintf oc "@[{%a%a%a@;%a@;@]}@;" + D.format_local_declarations locals + (D.format_set_vars dgfip_flags) + set + (D.format_assign dgfip_flags print_def) + def + (D.format_assign dgfip_flags print_val) + value; + Format.fprintf oc "@[{@;int idx = (int)floor(%s);@; /* prout */" + print_val; + Format.fprintf oc + "@[if(%s && 0 <= idx && idx < irdata->nb_events){@;" print_def; + Format.fprintf oc + "print_string(%s, %s, irdata->events[idx].field_%s_var->%s);@]@;" + print_std pr_ctx (Pos.unmark f) name_or_alias; + Format.fprintf oc "}@]@;"; + Format.fprintf oc "}@;" + in Format.fprintf oc "@[{@,char %s;@;double %s;@;" print_def print_val; List.iter (fun (arg : Com.Var.t Com.print_arg Pos.marked) -> @@ -532,6 +582,8 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) let ptr = VID.gen_info_ptr var in Format.fprintf oc "print_string(%s, %s, %s->alias);@;" print_std pr_ctx ptr + | PrintEventName (e, f) -> print_name_or_alias "name" e f + | PrintEventAlias (e, f) -> print_name_or_alias "alias" e f | PrintIndent e -> let locals, set, def, value = D.build_expression @@ generate_c_expr e diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index d79f345b7..62efb06ca 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -338,6 +338,22 @@ struct S_keep_discord { T_keep_discord *suivant; }; +struct S_event { +|}; + IntMap.iter + (fun _idx fname -> + let field = StrMap.find fname cprog.program_event_fields in + if field.is_var then + Format.fprintf fmt " T_varinfo *field_%s_var;\n" fname + else ( + Format.fprintf fmt " char field_%s_def;\n" fname; + Format.fprintf fmt " double field_%s_val;\n" fname)) + cprog.program_event_field_idxs; + Format.fprintf fmt + {|}; + +typedef struct S_event T_event; + struct S_irdata { double *saisie; double *calculee; @@ -370,12 +386,24 @@ struct S_irdata { int sz_err_archive; char **err_archive; int nb_err_archive; + T_event *events; + int nb_events; T_print_context ctx_pr_out; T_print_context ctx_pr_err; }; typedef struct S_irdata T_irdata; +|}; + StrMap.iter + (fun f _ -> + Format.fprintf fmt + "extern char event_field_%s(T_irdata *irdata, char *res_def, double \ + *res_val, char idx_def, double idx_val);\n" + f) + cprog.program_event_fields; + Format.fprintf fmt + {| #define S_ irdata->saisie #define C_ irdata->calculee #define B_ irdata->base @@ -389,22 +417,6 @@ typedef struct S_irdata T_irdata; /*#define IT_ irdata->info_tmps*/ /*#define IR_ irdata->info_ref*/ -struct S_event { -|}; - IntMap.iter - (fun _idx fname -> - let field = StrMap.find fname cprog.program_event_fields in - if field.is_var then - Format.fprintf fmt " T_varinfo *field_%s_var;\n" fname - else ( - Format.fprintf fmt " char field_%s_def;\n" fname; - Format.fprintf fmt " double field_%s_val;\n" fname)) - cprog.program_event_field_idxs; - Format.fprintf fmt - {|}; - -typedef struct S_event T_event; - #define EST_SAISIE 0x00000 #define EST_CALCULEE 0x04000 #define EST_BASE 0x08000 @@ -426,7 +438,6 @@ extern void free_erreur(); #define max(a,b) (((a) >= (b)) ? (a) : (b)) |}; Format.fprintf fmt "#define EPSILON %f" !Cli.comparison_error_margin; - Format.fprintf fmt {| #define GT_E(a,b) ((a) > (b) + EPSILON) @@ -576,6 +587,7 @@ extern char *lis_erreur_sous_code(T_erreur *err); extern char *lis_erreur_is_isf(T_erreur *err); extern char *lis_erreur_nom(T_erreur *err); extern int lis_erreur_type(T_erreur *err); +extern int nb_evenements(T_irdata *irdata); extern T_varinfo *cherche_varinfo(T_irdata *irdata, const char *nom); extern char lis_varinfo_def(T_irdata *irdata, T_varinfo *info); @@ -644,7 +656,7 @@ let gen_mlang_h fmt cprog flags stats_varinfos = gen_decl_targets fmt cprog; pr "#endif /* _MLANG_H_ */\n\n" -let gen_mlang_c fmt flags = +let gen_mlang_c fmt (cprog : Mir.program) flags = Format.fprintf fmt "%s" {|/****** LICENCE CECIL *****/ @@ -1424,6 +1436,11 @@ int lis_erreur_type(T_erreur *err) { return err->type; } +int nb_evenements(T_irdata *irdata) { + if (irdata == NULL) return 0; + return irdata->nb_events; +} + T_varinfo *cherche_varinfo(T_irdata *irdata, const char *nom) { T_varinfo_map *map = NULL; int res = -1; @@ -1584,7 +1601,32 @@ void pr_err_var(T_irdata *irdata, char *nom) { if (irdata == NULL) return; pr_var(&(irdata->ctx_pr_err), irdata, nom); } -|} + +|}; + StrMap.iter + (fun f (ef : Com.event_field) -> + Format.fprintf fmt + "char event_field_%s(T_irdata *irdata, char *res_def, double *res_val, \ + char idx_def, double idx_val) {\n" + f; + if ef.is_var then Format.fprintf fmt " T_varinfo *info = NULL;\n"; + Format.fprintf fmt " int idx = (int)floor(idx_val);\n"; + Format.fprintf fmt + " if (idx_def != 1 || idx < 0 || irdata->nb_events <= idx) {\n"; + Format.fprintf fmt " *res_def = 0;\n"; + Format.fprintf fmt " *res_val = 0.0;\n"; + Format.fprintf fmt " return 0;\n"; + Format.fprintf fmt " }\n"; + if ef.is_var then ( + Format.fprintf fmt " info = irdata->events[idx].field_%s_var;\n" f; + Format.fprintf fmt " *res_def = lis_varinfo_def(irdata, info);\n"; + Format.fprintf fmt " *res_val = lis_varinfo_val(irdata, info);\n") + else ( + Format.fprintf fmt " *res_def = irdata->events[idx].field_%s_def;\n" f; + Format.fprintf fmt " *res_val = irdata->events[idx].field_%s_val;\n" f); + Format.fprintf fmt " return *res_def;\n"; + Format.fprintf fmt "}\n\n") + cprog.program_event_fields let open_file filename = let oc = open_out filename in @@ -1613,5 +1655,5 @@ let generate_auxiliary_files flags (cprog : Mir.program) : unit = close_out oc; let oc, fmt = open_file (Filename.concat folder "mlang.c") in - gen_mlang_c fmt flags; + gen_mlang_c fmt cprog flags; close_out oc diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index 5aed941e3..500c04ead 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -315,6 +315,10 @@ module Err = struct Pos.format_position old_pos in Errors.raise_spanned_error msg pos + + let unknown_event_field name pos = + let msg = Format.asprintf "unknown event field \"%s\"" name in + Errors.raise_spanned_error msg pos end type syms = Com.DomainId.t Pos.marked Com.DomainIdMap.t @@ -361,7 +365,7 @@ type program = { prog_chainings : chaining StrMap.t; prog_var_cats : Com.CatVar.data Com.CatVar.Map.t; prog_vars : Com.Var.t StrMap.t; - prog_alias : Com.Var.t StrMap.t; + prog_alias : string Pos.marked StrMap.t; prog_event_fields : Com.event_field StrMap.t; prog_event_field_idxs : string IntMap.t; prog_event_pos : Pos.t; @@ -596,16 +600,19 @@ let check_global_var (var : Com.Var.t) (prog : program) : program = | Some (gvar : Com.Var.t) -> let old_pos = Pos.get_position gvar.name in Err.variable_already_declared name old_pos name_pos - | None -> StrMap.add name var prog.prog_vars + | None -> ( + match StrMap.find_opt name prog.prog_alias with + | None -> StrMap.add name var prog.prog_vars + | Some (_, old_pos) -> + Err.variable_already_declared name old_pos name_pos) in let prog_alias = match Com.Var.alias var with | Some (alias, alias_pos) -> ( match StrMap.find_opt alias prog.prog_alias with - | Some (gvar : Com.Var.t) -> - let old_pos = Pos.get_position (Option.get (Com.Var.alias gvar)) in + | Some (_, old_pos) -> Err.alias_already_declared alias old_pos alias_pos - | None -> StrMap.add alias var prog.prog_alias) + | None -> StrMap.add alias var.name prog.prog_alias) | None -> prog.prog_alias in { prog with prog_vars; prog_alias } @@ -1064,6 +1071,11 @@ let rec fold_var_expr | Some _ -> Err.tmp_vars_have_no_attrs var_pos | None -> ())); fold_var v Both env acc + | EventField (e, f) -> ( + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + match StrMap.find_opt (Pos.unmark f) env.prog.prog_event_fields with + | Some _ -> fold_var_expr fold_var is_filter acc e env + | None -> Err.unknown_event_field (Pos.unmark f) (Pos.get_position f)) | Size v -> fold_var v Both env acc | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes -> if is_filter then Err.forbidden_expresion_in_filter expr_pos; @@ -1308,6 +1320,14 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) | Com.PrintString _ -> () | Com.PrintName v | Com.PrintAlias v -> ignore (check_variable v Both env) + | Com.PrintEventName (e, f) | Com.PrintEventAlias (e, f) -> ( + match + StrMap.find_opt (Pos.unmark f) env.prog.prog_event_fields + with + | Some _ -> ignore (check_expression false e env) + | None -> + Err.unknown_event_field (Pos.unmark f) + (Pos.get_position f)) | Com.PrintIndent e -> ignore (check_expression false e env) | Com.PrintExpr (e, _min, _max) -> ignore (check_expression false e env)) @@ -2239,7 +2259,7 @@ let eval_expr_verif (prog : program) (verif : verif) in Some (if res = positive then 1.0 else 0.0)) | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes | Index _ - | FuncCallLoop _ | Loop _ -> + | FuncCallLoop _ | Loop _ | EventField _ -> assert false in aux expr @@ -2601,7 +2621,10 @@ let complete_vars_stack (prog : program) : program = match a with | Com.PrintString _ | Com.PrintName _ | Com.PrintAlias _ -> (nb, sz, nbRef, tdata) - | Com.PrintIndent me | Com.PrintExpr (me, _, _) -> + | Com.PrintEventName (me, _) + | Com.PrintEventAlias (me, _) + | Com.PrintIndent me + | Com.PrintExpr (me, _, _) -> let nb', sz', nbRef', tdata = aux_expr tdata me in (max nb nb', max sz sz', max nbRef nbRef', tdata) in @@ -2657,7 +2680,10 @@ let complete_vars_stack (prog : program) : program = assert false and aux_expr tdata (expr, _pos) = match expr with - | Com.TestInSet (_, me, _) | Com.Unop (_, me) | Com.Index (_, me) -> + | Com.TestInSet (_, me, _) + | Com.Unop (_, me) + | Com.Index (_, me) + | Com.EventField (me, _) -> aux_expr tdata me | Com.Comparison (_, me0, me1) | Com.Binop (_, me0, me1) -> let nb0, sz0, nbRef0, tdata = aux_expr tdata me0 in diff --git a/src/mlang/m_frontend/check_validity.mli b/src/mlang/m_frontend/check_validity.mli index bf50ddd13..5b5c3ab27 100644 --- a/src/mlang/m_frontend/check_validity.mli +++ b/src/mlang/m_frontend/check_validity.mli @@ -56,7 +56,7 @@ type program = { prog_chainings : chaining StrMap.t; prog_var_cats : Com.CatVar.data Com.CatVar.Map.t; prog_vars : Com.Var.t StrMap.t; - prog_alias : Com.Var.t StrMap.t; + prog_alias : string Pos.marked StrMap.t; prog_event_fields : Com.event_field StrMap.t; prog_event_field_idxs : string IntMap.t; prog_event_pos : Pos.t; diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index 768ed9af1..a806b4fb9 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -617,6 +617,9 @@ let rec expand_expression (const_map : const_context) (loop_map : loop_context) | Var v, v_pos -> (Attribut ((v, v_pos), a), expr_pos) | Literal (Float _), v_pos -> Err.constant_cannot_have_an_attribut v_pos | _ -> assert false) + | EventField (e, f) -> + let e' = expand_expression const_map loop_map e in + (EventField (e', f), expr_pos) | Size var -> ( match expand_variable const_map loop_map var with | Var v, v_pos -> (Size (v, v_pos), expr_pos) @@ -689,6 +692,12 @@ let rec expand_instruction (const_map : const_context) List.map (fun arg -> match Pos.unmark arg with + | Com.PrintEventName (expr, f) -> + let expr' = expand_expression const_map ParamsMap.empty expr in + (Com.PrintEventName (expr', f), Pos.get_position arg) + | Com.PrintEventAlias (expr, f) -> + let expr' = expand_expression const_map ParamsMap.empty expr in + (Com.PrintEventAlias (expr', f), Pos.get_position arg) | Com.PrintIndent expr -> let expr' = expand_expression const_map ParamsMap.empty expr in (Com.PrintIndent expr', Pos.get_position arg) diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 0d732401b..3b4f06b51 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -148,6 +148,9 @@ let rec translate_expression (cats : Com.CatVar.data Com.CatVar.Map.t) | _ -> let msg = Format.sprintf "unknown variable %s" v_name in Errors.raise_spanned_error msg (Pos.get_position v)) + | EventField (e, f) -> + let new_e = translate_expression cats var_data e in + EventField (new_e, f) | Size v -> ( let v_name = match Pos.unmark v with @@ -253,6 +256,12 @@ let rec translate_prog (error_decls : Com.Error.t StrMap.t) Format.sprintf "unknown variable %s" name in Errors.raise_spanned_error msg (Pos.get_position v)) + | Com.PrintEventName (e, f) -> + let e' = translate_expression cats var_data e in + Com.PrintEventName (e', f) + | Com.PrintEventAlias (e, f) -> + let e' = translate_expression cats var_data e in + Com.PrintEventAlias (e', f) | Com.PrintIndent e -> Com.PrintIndent (translate_expression cats var_data e) | Com.PrintExpr (e, min, max) -> @@ -509,6 +518,7 @@ let translate (p : Mast.program) (main_target : string) : Mir.program = program_rule_domains = prog.prog_rdoms; program_verif_domains = prog.prog_vdoms; program_vars = var_data; + program_alias = prog.prog_alias; program_event_fields = prog.prog_event_fields; program_event_field_idxs = prog.prog_event_field_idxs; program_rules = rules; diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index 2be7658be..f4adb72d3 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -76,6 +76,7 @@ rule token = parse | "calculee" -> COMPUTED | "calculer" -> COMPUTE | "categorie" -> CATEGORY + | "champ_evenement" -> EVENT_FIELD | "cible" -> TARGET | "const" -> CONST | "dans" -> IN diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 15e800768..5bb4bab0d 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -58,7 +58,7 @@ along with this program. If not, see . %token INFORMATIVE OUTPUT FONCTION VARIABLE ATTRIBUT %token BASE GIVEN_BACK COMPUTABLE BY_DEFAULT %token DOMAIN SPECIALIZE AUTHORIZE VERIFIABLE -%token EVENT VALUE STEP +%token EVENT VALUE STEP EVENT_FIELD %token EOF @@ -753,20 +753,25 @@ instruction_then_when_branch: print_argument: | s = STRING { Com.PrintString (parse_string s) } -| f = with_pos(print_function) LPAREN v = symbol_with_pos RPAREN - { - match Pos.unmark f with - | "nom" -> Com.PrintName (parse_variable $sloc (fst v), snd v) - | "alias" -> Com.PrintAlias (parse_variable $sloc (fst v), snd v) - | _ -> assert false - } +| f = with_pos(print_function) LPAREN v = symbol_with_pos RPAREN { + match Pos.unmark f with + | "nom" -> Com.PrintName (parse_variable $sloc (fst v), snd v) + | "alias" -> Com.PrintAlias (parse_variable $sloc (fst v), snd v) + | _ -> assert false + } +| f = with_pos(print_function) LPAREN expr = with_pos(sum_expression) + COMMA field = symbol_with_pos RPAREN { + match Pos.unmark f with + | "nom" -> Com.PrintEventName (expr, field) + | "alias" -> Com.PrintEventAlias (expr, field) + | _ -> assert false + } | INDENT LPAREN e = with_pos(expression) RPAREN { Com.PrintIndent e } -| LPAREN e = with_pos(expression) RPAREN prec = print_precision? - { - match prec with - | Some (min, max) -> Com.PrintExpr (e, min, max) - | None -> Com.PrintExpr (e, 0, 20) - } +| LPAREN e = with_pos(expression) RPAREN prec = print_precision? { + match prec with + | Some (min, max) -> Com.PrintExpr (e, min, max) + | None -> Com.PrintExpr (e, 0, 20) + } print_function: | NAME { "nom" } @@ -1172,6 +1177,9 @@ function_call: | ATTRIBUT LPAREN var = symbol_with_pos COMMA attr = symbol_with_pos RPAREN { Attribut ((parse_variable $sloc (fst var), snd var), attr) } +| EVENT_FIELD LPAREN m_expr = with_pos(sum_expression) COMMA field = symbol_with_pos RPAREN { + EventField (m_expr, field) + } | SIZE LPAREN var = symbol_with_pos RPAREN { Size (parse_variable $sloc (fst var), snd var) } diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index a2b62e7f1..dd6699f80 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -293,7 +293,7 @@ end type event_field = { name : string Pos.marked; index : int; is_var : bool } -type event_value = Numeric of float option | RefVar of string +type 'v event_value = Numeric of float option | RefVar of 'v module DomainId = StrSet @@ -413,6 +413,7 @@ type 'v expression = | NbDiscordances | NbInformatives | NbBloquantes + | EventField of 'v m_expression * string Pos.marked and 'v m_expression = 'v expression Pos.marked @@ -451,6 +452,8 @@ type 'v print_arg = | PrintString of string | PrintName of 'v Pos.marked | PrintAlias of 'v Pos.marked + | PrintEventName of 'v m_expression * string Pos.marked + | PrintEventAlias of 'v m_expression * string Pos.marked | PrintIndent of 'v m_expression | PrintExpr of 'v m_expression * int * int @@ -666,16 +669,25 @@ let rec format_expression form_var fmt = | Attribut (v, a) -> Format.fprintf fmt "attribut(%a, %s)" form_var (Pos.unmark v) (Pos.unmark a) + | EventField (e, f) -> + Format.fprintf fmt "champ_evenement(%a, %s)" form_expr (Pos.unmark e) + (Pos.unmark f) | Size v -> Format.fprintf fmt "taille(%a)" form_var (Pos.unmark v) | NbAnomalies -> Format.fprintf fmt "nb_anomalies()" | NbDiscordances -> Format.fprintf fmt "nb_discordances()" | NbInformatives -> Format.fprintf fmt "nb_informatives()" | NbBloquantes -> Format.fprintf fmt "nb_bloquantes()" -let format_print_arg form_var fmt = function +let format_print_arg form_var fmt = + let form_expr = format_expression form_var in + function | PrintString s -> Format.fprintf fmt "\"%s\"" s | PrintName v -> Format.fprintf fmt "nom(%a)" (Pp.unmark form_var) v | PrintAlias v -> Format.fprintf fmt "alias(%a)" (Pp.unmark form_var) v + | PrintEventName (e, f) -> + Format.fprintf fmt "nom(%a, %s)" form_expr (Pos.unmark e) (Pos.unmark f) + | PrintEventAlias (e, f) -> + Format.fprintf fmt "alias(%a, %s)" form_expr (Pos.unmark e) (Pos.unmark f) | PrintIndent e -> Format.fprintf fmt "indenter(%a)" (Pp.unmark (format_expression form_var)) diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 81bb884d0..11d3e4acf 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -152,7 +152,7 @@ end type event_field = { name : string Pos.marked; index : int; is_var : bool } -type event_value = Numeric of float option | RefVar of string +type 'v event_value = Numeric of float option | RefVar of 'v module DomainId : StrSet.T @@ -271,6 +271,7 @@ type 'v expression = | NbDiscordances | NbInformatives | NbBloquantes + | EventField of 'v m_expression * string Pos.marked and 'v m_expression = 'v expression Pos.marked @@ -300,6 +301,8 @@ type 'v print_arg = | PrintString of string | PrintName of 'v Pos.marked | PrintAlias of 'v Pos.marked + | PrintEventName of 'v m_expression * string Pos.marked + | PrintEventAlias of 'v m_expression * string Pos.marked | PrintIndent of 'v m_expression | PrintExpr of 'v m_expression * int * int diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 49d9bd0c3..2daef3933 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -66,6 +66,7 @@ type program = { program_rule_domains : Com.rule_domain Com.DomainIdMap.t; program_verif_domains : Com.verif_domain Com.DomainIdMap.t; program_vars : Com.Var.t StrMap.t; + program_alias : string Pos.marked StrMap.t; program_event_fields : Com.event_field StrMap.t; program_event_field_idxs : string IntMap.t; program_rules : string IntMap.t; @@ -238,6 +239,12 @@ let expand_functions (p : program) : program = (fun m_arg -> let arg, arg_pos = m_arg in match arg with + | Com.PrintEventName (e, f) -> + let e' = expand_functions_expr e in + (Com.PrintEventName (e', f), arg_pos) + | Com.PrintEventAlias (e, f) -> + let e' = expand_functions_expr e in + (Com.PrintEventAlias (e', f), arg_pos) | Com.PrintIndent e -> let e' = expand_functions_expr e in (Com.PrintIndent e', arg_pos) diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 901e0817d..3be37e66c 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -56,6 +56,7 @@ type program = { program_rule_domains : Com.rule_domain Com.DomainIdMap.t; program_verif_domains : Com.verif_domain Com.DomainIdMap.t; program_vars : Com.Var.t StrMap.t; + program_alias : string Pos.marked StrMap.t; program_event_fields : Com.event_field StrMap.t; program_event_field_idxs : string IntMap.t; program_rules : string IntMap.t; diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 274deae79..fd770f52a 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -47,7 +47,7 @@ module type S = sig mutable ctx_nb_bloquantes : int; mutable ctx_finalized_anos : (Com.Error.t * string option) list; mutable ctx_exported_anos : (Com.Error.t * string option) list; - mutable ctx_events : Com.event_value StrMap.t IntMap.t; + mutable ctx_events : Com.Var.t Com.event_value StrMap.t IntMap.t; } val empty_ctx : Mir.program -> ctx @@ -59,7 +59,7 @@ module type S = sig val update_ctx_with_inputs : ctx -> Com.literal Com.Var.Map.t -> unit val update_ctx_with_events : - ctx -> Mir.program -> Com.event_value IntMap.t list -> unit + ctx -> Mir.program -> Com.Var.t Com.event_value IntMap.t list -> unit type run_error = | NanOrInf of string * Mir.expression Pos.marked @@ -127,7 +127,7 @@ struct mutable ctx_nb_bloquantes : int; mutable ctx_finalized_anos : (Com.Error.t * string option) list; mutable ctx_exported_anos : (Com.Error.t * string option) list; - mutable ctx_events : Com.event_value StrMap.t IntMap.t; + mutable ctx_events : Com.Var.t Com.event_value StrMap.t IntMap.t; } let empty_ctx (p : Mir.program) : ctx = @@ -181,9 +181,9 @@ struct value_inputs let update_ctx_with_events (ctx : ctx) (p : Mir.program) - (events : Com.event_value IntMap.t list) : unit = + (events : Com.Var.t Com.event_value IntMap.t list) : unit = let ctx_events = - let fold (map, idx) (evt : Com.event_value IntMap.t) = + let fold (map, idx) (evt : Com.Var.t Com.event_value IntMap.t) = let foldEvt id ev map = match IntMap.find_opt id p.program_event_field_idxs with | Some fname -> ( @@ -215,7 +215,7 @@ struct let pp_ev fmt = function | Com.Numeric None -> Pp.string fmt "indefini" | Com.Numeric (Some f) -> Pp.float fmt f - | Com.RefVar v -> Pp.string fmt v + | Com.RefVar v -> Pp.string fmt (Com.Var.name_str v) in IntMap.iter (fun i m -> @@ -488,6 +488,19 @@ struct match StrMap.find_opt (Pos.unmark a) (Com.Var.attrs var) with | Some l -> Number (N.of_float (float (Pos.unmark l))) | None -> Undefined) + | EventField (e, f) -> ( + let new_e = evaluate_expr ctx p e in + match new_e with + | Number z when N.(z >=. zero ()) -> ( + let i = Int64.to_int N.(to_int z) in + match IntMap.find_opt i ctx.ctx_events with + | Some m -> ( + match StrMap.find (Pos.unmark f) m with + | Com.Numeric (Some v) -> Number N.(of_float v) + | Com.Numeric None -> Undefined + | Com.RefVar var -> get_var_value ctx var 0) + | None -> Undefined) + | _ -> Undefined) | Size var -> ( let var, _ = get_var ctx (Pos.unmark var) in match Com.Var.is_table var with @@ -497,8 +510,7 @@ struct | NbDiscordances -> Number (N.of_float (float ctx.ctx_nb_discos)) | NbInformatives -> Number (N.of_float (float ctx.ctx_nb_infos)) | NbBloquantes -> Number (N.of_float (float ctx.ctx_nb_bloquantes)) - | NbCategory _ -> assert false - | FuncCallLoop _ | Loop _ -> assert false + | NbCategory _ | FuncCallLoop _ | Loop _ -> assert false with | RuntimeError (e, ctx) -> if !exit_on_rte then raise_runtime_as_structured e @@ -649,6 +661,30 @@ struct | PrintAlias (var, _) -> let var, _ = get_var ctx var in pr_raw ctx_pr (Com.Var.alias_str var) + | PrintEventName (e, f) -> ( + match evaluate_expr ctx p e with + | Number x -> ( + let i = Int64.to_int (N.to_int x) in + match IntMap.find_opt i ctx.ctx_events with + | Some m -> ( + match StrMap.find_opt (Pos.unmark f) m with + | Some (Com.RefVar var) -> + pr_raw ctx_pr (Com.Var.name_str var) + | _ -> ()) + | None -> ()) + | Undefined -> ()) + | PrintEventAlias (e, f) -> ( + match evaluate_expr ctx p e with + | Number x -> ( + let i = Int64.to_int (N.to_int x) in + match IntMap.find_opt i ctx.ctx_events with + | Some m -> ( + match StrMap.find_opt (Pos.unmark f) m with + | Some (Com.RefVar var) -> + pr_raw ctx_pr (Com.Var.alias_str var) + | _ -> ()) + | None -> ()) + | Undefined -> ()) | PrintIndent e -> let diff = match evaluate_expr ctx p e with @@ -951,7 +987,7 @@ let prepare_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : unit = | _ -> () let evaluate_program (p : Mir.program) (inputs : Com.literal Com.Var.Map.t) - (events : Com.event_value IntMap.t list) (sort : Cli.value_sort) + (events : Com.Var.t Com.event_value IntMap.t list) (sort : Cli.value_sort) (roundops : Cli.round_ops) : float option StrMap.t * StrSet.t = prepare_interp sort roundops; let module Interp = (val get_interp sort roundops : S) in diff --git a/src/mlang/m_ir/mir_interpreter.mli b/src/mlang/m_ir/mir_interpreter.mli index 55a8aa5e5..078f18767 100644 --- a/src/mlang/m_ir/mir_interpreter.mli +++ b/src/mlang/m_ir/mir_interpreter.mli @@ -68,7 +68,7 @@ module type S = sig mutable ctx_nb_bloquantes : int; mutable ctx_finalized_anos : (Com.Error.t * string option) list; mutable ctx_exported_anos : (Com.Error.t * string option) list; - mutable ctx_events : Com.event_value StrMap.t IntMap.t; + mutable ctx_events : Com.Var.t Com.event_value StrMap.t IntMap.t; } (** Interpretation context *) @@ -81,7 +81,7 @@ module type S = sig val update_ctx_with_inputs : ctx -> Com.literal Com.Var.Map.t -> unit val update_ctx_with_events : - ctx -> Mir.program -> Com.event_value IntMap.t list -> unit + ctx -> Mir.program -> Com.Var.t Com.event_value IntMap.t list -> unit (** Interpreter runtime errors *) type run_error = @@ -160,7 +160,7 @@ val get_interp : Cli.value_sort -> Cli.round_ops -> (module S) val evaluate_program : Mir.program -> Com.literal Com.Var.Map.t -> - Com.event_value IntMap.t list -> + Com.Var.t Com.event_value IntMap.t list -> Cli.value_sort -> Cli.round_ops -> float option StrMap.t * StrSet.t diff --git a/src/mlang/test_framework/test_interpreter.ml b/src/mlang/test_framework/test_interpreter.ml index 1875a4450..e084ece05 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -21,7 +21,8 @@ let find_var_of_name (p : Mir.program) (name : string Pos.marked) : Com.Var.t = let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : (Com.literal Com.Var.Map.t * float StrMap.t * StrSet.t) - * (Com.event_value IntMap.t list * float StrMap.t * StrSet.t) option = + * (Com.Var.t Com.event_value IntMap.t list * float StrMap.t * StrSet.t) + option = let inputVars = let ancsded = find_var_of_name program ("V_ANCSDED", Pos.no_pos) in let ancsded_val = Com.Float (float_of_int (!Cli.income_year + 1)) in @@ -38,6 +39,18 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : t.prim.entrees in let eventsList rappels = + let from_var vn = + let name = + match StrMap.find_opt vn program.program_alias with + | Some m_name -> Pos.unmark m_name + | None -> vn + in + match StrMap.find_opt name program.program_vars with + | Some var -> var + | None -> + Cli.error_print "Variable inconnue: %s" vn; + raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) + in let fromDirection = function | "R" -> Some 0.0 | "C" -> Some 1.0 @@ -49,14 +62,14 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) in let fromPenalty = function - | None -> None + | None -> Some 0.0 (* None *) | Some p when 0 <= p && p <= 99 -> Some (float p) | Some p -> Cli.error_print "Code de pénalité: %d, devrait être entre 0 et 99" p; raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) in let from_2042_rect = function - | None -> None + | None -> Some 0.0 (* None *) | Some 0 -> Some 0.0 | Some 1 -> Some 1.0 | Some r -> @@ -68,7 +81,7 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : IntMap.empty |> IntMap.add 0 (Com.Numeric (Some (float rappel.event_nb))) |> IntMap.add 1 (Com.Numeric (Some (float rappel.rappel_nb))) - |> IntMap.add 2 (Com.RefVar rappel.variable_code) + |> IntMap.add 2 (Com.RefVar (from_var rappel.variable_code)) |> IntMap.add 3 (Com.Numeric (Some (float rappel.change_value))) |> IntMap.add 4 (Com.Numeric (fromDirection rappel.direction)) |> IntMap.add 5 (Com.Numeric (fromPenalty rappel.penalty_code)) From 2621cc08831a604aa0aacbcaf97a13dbdaf4e69a Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 21 Jan 2025 18:09:35 +0100 Subject: [PATCH 11/32] =?UTF-8?q?Assignation=20dynamique=20des=20champs=20?= =?UTF-8?q?des=20=C3=A9v=C3=A9nements.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2023/cibles.m | 8 ++++ src/mlang/backend_compilers/bir_to_dgfip_c.ml | 47 ++++++++++++++++++- src/mlang/driver.ml | 2 +- src/mlang/m_frontend/check_validity.ml | 28 ++++++++++- src/mlang/m_frontend/expand_macros.ml | 21 +++++++-- src/mlang/m_frontend/mast_to_mir.ml | 29 ++++++++---- src/mlang/m_frontend/mparser.mly | 6 ++- src/mlang/m_ir/com.ml | 25 ++++++---- src/mlang/m_ir/com.mli | 4 +- src/mlang/m_ir/mir.ml | 12 +++-- src/mlang/m_ir/mir_interpreter.ml | 28 ++++++++--- 11 files changed, 172 insertions(+), 38 deletions(-) diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index bc8c3a767..9b6fdfa6f 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -854,6 +854,14 @@ si nb_discordances() + nb_informatives() > 0 alors si (present(champ_evenement(I, 2042_rect))) alors afficher_erreur (champ_evenement(I, 2042_rect)); finsi afficher_erreur "\n"; ) +si nb_evenements() > 0 alors + afficher_erreur "0: " nom(0, code) " = " (champ_evenement(0, code)) "\n"; + champ_evenement(0, code) = 456; + afficher_erreur "1: " nom(0, code) " = " (champ_evenement(0, code)) "\n"; +sinon + afficher_erreur "!!! AUCUN EVENEMENT !!!\n"; +finsi + cible enchainement_primitif: application: iliad; diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index 67c2193a3..ceba8c59a 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -466,14 +466,57 @@ let generate_var_def (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t) (generate_c_expr vexpr); pr "@]@;}@;" +let generate_event_field_def (dgfip_flags : Dgfip_options.flags) + (idx : Mir.expression Pos.marked) (field : string Pos.marked) + (expr : Mir.expression Pos.marked) (fmt : Format.formatter) : unit = + let pr form = Format.fprintf fmt form in + pr "@[{@;"; + let idx_val = fresh_c_local "mpp_idx" in + let idx_def = idx_val ^ "_d" in + let locals_idx, set_idx, def_idx, value_idx = + D.build_expression @@ generate_c_expr idx + in + pr "char %s;@;long %s;@;%a%a%a@;%a@;" idx_def idx_val + D.format_local_declarations locals_idx + (D.format_set_vars dgfip_flags) + set_idx + (D.format_assign dgfip_flags idx_def) + def_idx + (D.format_assign dgfip_flags idx_val) + value_idx; + pr "@[if(%s && 0 <= %s && %s < irdata->nb_events){@;" idx_def idx_val + idx_val; + let expr_val = fresh_c_local "mpp_expr" in + let expr_def = expr_val ^ "_d" in + let locals_expr, set_expr, def_expr, value_expr = + D.build_expression @@ generate_c_expr expr + in + pr "@[{@;char %s;@;double %s;@;%a%a%a@;%a@;" expr_def expr_val + D.format_local_declarations locals_expr + (D.format_set_vars dgfip_flags) + set_expr + (D.format_assign dgfip_flags expr_def) + def_expr + (D.format_assign dgfip_flags expr_val) + value_expr; + pr "ecris_varinfo(irdata, irdata->events[%s].field_%s_var, %s, %s);" idx_val + (Pos.unmark field) expr_def expr_val; + pr "@]@;}@;"; + pr "@]@;}"; + pr "@]@;}@;" + let rec generate_stmt (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (oc : Format.formatter) (stmt : Mir.m_instruction) = match Pos.unmark stmt with - | Affectation (SingleFormula (m_var, vidx_opt, vexpr), _) -> + | Affectation (SingleFormula (VarDecl (m_var, vidx_opt, vexpr)), _) -> Format.fprintf oc "@[{@;"; generate_var_def dgfip_flags (Pos.unmark m_var) vidx_opt vexpr oc; Format.fprintf oc "@]@;}@;" - | Affectation _ -> assert false + | Affectation (SingleFormula (EventFieldDecl (idx, f, expr)), _) -> + Format.fprintf oc "@[{@;"; + generate_event_field_def dgfip_flags idx f expr oc; + Format.fprintf oc "@]@;}@;" + | Affectation (MultipleFormulaes _, _) -> assert false | IfThenElse (cond, iftrue, iffalse) -> Format.fprintf oc "@[{@,"; let cond_val = fresh_c_local "mpp_cond" in diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index 0d6eb92e8..c041e1c7d 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -59,7 +59,7 @@ let patch_rule_1 (backend : string option) (dgfip_flags : Dgfip_options.flags) let no_pos x = (x, Pos.no_pos) in let var = Normal name in let litt = Com.Literal (Com.Float (if value then 1.0 else 0.0)) in - let cmd = Com.SingleFormula (no_pos var, None, no_pos litt) in + let cmd = Com.SingleFormula (VarDecl (no_pos var, None, no_pos litt)) in no_pos cmd :: l else l in diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index 500c04ead..932c502e0 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -319,6 +319,12 @@ module Err = struct let unknown_event_field name pos = let msg = Format.asprintf "unknown event field \"%s\"" name in Errors.raise_spanned_error msg pos + + let event_field_not_a_reference name pos = + let msg = + Format.asprintf "event field \"%s\" is not a variable reference" name + in + Errors.raise_spanned_error msg pos end type syms = Com.DomainId.t Pos.marked Com.DomainIdMap.t @@ -1190,7 +1196,7 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) match instr with | Com.Affectation (f, _) -> ( match f with - | Com.SingleFormula (v, idx, e) -> + | Com.SingleFormula (VarDecl (v, idx, e)) -> let out_var = let idx_mem = OneOf (Option.map (fun _ -> ()) idx) in check_variable v idx_mem env @@ -1209,6 +1215,20 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) let out_vars = StrSet.add out_var out_vars in aux (env, m_instr :: res, in_vars, out_vars) il else aux (env, m_instr :: res, in_vars, out_vars) il + | Com.SingleFormula (EventFieldDecl (idx, f, e)) -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + let f_name, f_pos = f in + (match StrMap.find_opt f_name env.prog.prog_event_fields with + | Some ef when ef.is_var -> () + | Some _ -> Err.event_field_not_a_reference f_name f_pos + | None -> Err.unknown_event_field f_name f_pos); + let in_vars_index = check_expression false idx env in + let in_vars_expr = check_expression false e env in + let in_vars_aff = StrSet.union in_vars_index in_vars_expr in + let in_vars = + StrSet.union in_vars (StrSet.diff in_vars_aff out_vars) + in + aux (env, m_instr :: res, in_vars, out_vars) il | Com.MultipleFormulaes _ -> assert false) | Com.IfThenElse (expr, i_then, i_else) -> (* if is_rule then Err.insruction_forbidden_in_rules instr_pos; *) @@ -2578,7 +2598,7 @@ let complete_vars_stack (prog : program) : program = match instr with | Com.Affectation mf -> ( match Pos.unmark mf with - | SingleFormula (_, mei_opt, mev) -> + | SingleFormula (VarDecl (_, mei_opt, mev)) -> let nbI, szI, nbRefI, tdata = match mei_opt with | None -> (0, 0, 0, tdata) @@ -2586,6 +2606,10 @@ let complete_vars_stack (prog : program) : program = in let nbV, szV, nbRefV, tdata = aux_expr tdata mev in (max nbI nbV, max szI szV, max nbRefI nbRefV, tdata) + | SingleFormula (EventFieldDecl (mei, _, mev)) -> + let nbI, szI, nbRefI, tdata = aux_expr tdata mei in + let nbV, szV, nbRefV, tdata = aux_expr tdata mev in + (max nbI nbV, max szI szV, max nbRefI nbRefV, tdata) | MultipleFormulaes _ -> assert false) | Com.ComputeTarget (tn, _args) -> aux_call tdata (Pos.unmark tn) | Com.IfThenElse (meI, ilT, ilE) -> diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index a806b4fb9..3f1e2d497 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -635,7 +635,7 @@ let expand_formula (const_map : const_context) Mast.variable Com.formula Pos.marked list = let form, form_pos = m_form in match form with - | Com.SingleFormula (v, idx, e) -> + | Com.SingleFormula (VarDecl (v, idx, e)) -> let v' = match expand_variable const_map ParamsMap.empty v with | Com.Var v, v_pos -> (v, v_pos) @@ -645,8 +645,12 @@ let expand_formula (const_map : const_context) in let idx' = Option.map (expand_expression const_map ParamsMap.empty) idx in let e' = expand_expression const_map ParamsMap.empty e in - (Com.SingleFormula (v', idx', e'), form_pos) :: prev - | Com.MultipleFormulaes (lvs, (v, idx, e)) -> + (Com.SingleFormula (VarDecl (v', idx', e')), form_pos) :: prev + | Com.SingleFormula (EventFieldDecl (idx, f, e)) -> + let idx' = expand_expression const_map ParamsMap.empty idx in + let e' = expand_expression const_map ParamsMap.empty e in + (Com.SingleFormula (EventFieldDecl (idx', f, e')), form_pos) :: prev + | Com.MultipleFormulaes (lvs, VarDecl (v, idx, e)) -> let loop_context_provider = expand_loop_variables lvs const_map in let translator loop_map = let v' = @@ -658,7 +662,16 @@ let expand_formula (const_map : const_context) in let idx' = Option.map (expand_expression const_map loop_map) idx in let e' = expand_expression const_map loop_map e in - (Com.SingleFormula (v', idx', e'), form_pos) + (Com.SingleFormula (VarDecl (v', idx', e')), form_pos) + in + let res = loop_context_provider translator in + List.rev res @ prev + | Com.MultipleFormulaes (lvs, EventFieldDecl (idx, f, e)) -> + let loop_context_provider = expand_loop_variables lvs const_map in + let translator loop_map = + let idx' = expand_expression const_map loop_map idx in + let e' = expand_expression const_map loop_map e in + (Com.SingleFormula (EventFieldDecl (idx', f, e')), form_pos) in let res = loop_context_provider translator in List.rev res @ prev diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 3b4f06b51..ef71a822d 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -178,18 +178,27 @@ let rec translate_prog (error_decls : Com.Error.t StrMap.t) (it_depth : int) (itval_depth : int) prog = let rec aux res = function | [] -> List.rev res - | (Com.Affectation (Com.SingleFormula (v, idx, e), _), pos) :: il -> - let var = - match Pos.unmark (translate_variable var_data v) with - | Com.Var var -> Pos.same_pos_as var v - | _ -> assert false - (* should not happen *) + | (Com.Affectation (SingleFormula decl, _), pos) :: il -> + let decl' = + match decl with + | VarDecl (v, idx, e) -> + let var = + match Pos.unmark (translate_variable var_data v) with + | Com.Var var -> Pos.same_pos_as var v + | _ -> assert false + (* should not happen *) + in + let idx' = Option.map (translate_expression cats var_data) idx in + let e' = translate_expression cats var_data e in + Com.VarDecl (var, idx', e') + | EventFieldDecl (idx, f, e) -> + let idx' = translate_expression cats var_data idx in + let e' = translate_expression cats var_data e in + Com.EventFieldDecl (idx', f, e') in - let var_idx = Option.map (translate_expression cats var_data) idx in - let var_e = translate_expression cats var_data e in - let m_form = (Com.SingleFormula (var, var_idx, var_e), pos) in + let m_form = (Com.SingleFormula decl', pos) in aux ((Com.Affectation m_form, pos) :: res) il - | (Com.Affectation _, _) :: _ -> assert false + | (Com.Affectation (MultipleFormulaes _, _), _) :: _ -> assert false | (Com.IfThenElse (e, ilt, ile), pos) :: il -> let expr = translate_expression cats var_data e in let prog_then = aux [] ilt in diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 5bb4bab0d..fedd21b41 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -893,9 +893,13 @@ lvalue: | s = with_pos(lvalue_name) i = with_pos(brackets)? { (s, i) } formula: +| EVENT_FIELD LPAREN idx = with_pos(expression) + COMMA f = symbol_with_pos RPAREN EQUALS e = with_pos(expression) { + EventFieldDecl (idx, f, e) + } | lvalue = lvalue EQUALS e = with_pos(expression) { let v, idx = lvalue in - (v, idx, e) + VarDecl (v, idx, e) } verification_etc: diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index dd6699f80..59618c8d7 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -459,7 +459,9 @@ type 'v print_arg = type 'v formula_loop = 'v loop_variables Pos.marked -type 'v formula_decl = 'v Pos.marked * 'v m_expression option * 'v m_expression +type 'v formula_decl = + | VarDecl of 'v Pos.marked * 'v m_expression option * 'v m_expression + | EventFieldDecl of 'v m_expression * string Pos.marked * 'v m_expression type 'v formula = | SingleFormula of 'v formula_decl @@ -704,13 +706,20 @@ let format_print_arg form_var fmt = (Pp.unmark (format_expression form_var)) e min max -let format_formula_decl form_var fmt (v, idx, e) = - Format.fprintf fmt "%a" form_var (Pos.unmark v); - (match idx with - | Some vi -> - Format.fprintf fmt "[%a]" (format_expression form_var) (Pos.unmark vi) - | None -> ()); - Format.fprintf fmt " = %a" (format_expression form_var) (Pos.unmark e) +let format_formula_decl form_var fmt = function + | VarDecl (v, idx, e) -> + Format.fprintf fmt "%a" form_var (Pos.unmark v); + (match idx with + | Some vi -> + Format.fprintf fmt "[%a]" (format_expression form_var) (Pos.unmark vi) + | None -> ()); + Format.fprintf fmt " = %a" (format_expression form_var) (Pos.unmark e) + | EventFieldDecl (idx, f, e) -> + Format.fprintf fmt "champ_evenement(%a,%s) = %a" + (format_expression form_var) + (Pos.unmark idx) (Pos.unmark f) + (format_expression form_var) + (Pos.unmark e) let format_formula form_var fmt f = match f with diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 11d3e4acf..633d6515c 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -312,7 +312,9 @@ type 'v print_arg = type 'v formula_loop = 'v loop_variables Pos.marked -type 'v formula_decl = 'v Pos.marked * 'v m_expression option * 'v m_expression +type 'v formula_decl = + | VarDecl of 'v Pos.marked * 'v m_expression option * 'v m_expression + | EventFieldDecl of 'v m_expression * string Pos.marked * 'v m_expression type 'v formula = | SingleFormula of 'v formula_decl diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 2daef3933..1a04c7747 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -206,15 +206,21 @@ let expand_functions (p : program) : program = let rec map_instr m_instr = let instr, instr_pos = m_instr in match instr with - | Affectation (SingleFormula (v_id, v_idx_opt, v_expr), pos) -> + | Affectation (SingleFormula (VarDecl (v_id, v_idx_opt, v_expr)), pos) -> let m_idx_opt = match v_idx_opt with | Some v_idx -> Some (expand_functions_expr v_idx) | None -> None in let m_expr = expand_functions_expr v_expr in - (Affectation (SingleFormula (v_id, m_idx_opt, m_expr), pos), instr_pos) - | Affectation _ -> assert false + ( Affectation (SingleFormula (VarDecl (v_id, m_idx_opt, m_expr)), pos), + instr_pos ) + | Affectation (SingleFormula (EventFieldDecl (v_idx, f, v_expr)), pos) -> + let m_idx = expand_functions_expr v_idx in + let m_expr = expand_functions_expr v_expr in + ( Affectation (SingleFormula (EventFieldDecl (m_idx, f, m_expr)), pos), + instr_pos ) + | Affectation (MultipleFormulaes _, _) -> assert false | IfThenElse (i, t, e) -> let i' = expand_functions_expr i in let t' = List.map map_instr t in diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index fd770f52a..754149aca 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -585,12 +585,28 @@ struct and evaluate_stmt (tn : string) (canBlock : bool) (p : Mir.program) (ctx : ctx) (stmt : Mir.m_instruction) : unit = match Pos.unmark stmt with - | Com.Affectation (Com.SingleFormula (m_var, vidx_opt, vexpr), _) -> ( - let vari = get_var ctx (Pos.unmark m_var) in - match vidx_opt with - | None -> set_var_value p ctx vari vexpr - | Some ei -> set_var_value_tab p ctx vari ei vexpr) - | Com.Affectation _ -> assert false + | Com.Affectation (Com.SingleFormula decl, _) -> ( + match decl with + | VarDecl (m_var, vidx_opt, vexpr) -> ( + let vari = get_var ctx (Pos.unmark m_var) in + match vidx_opt with + | None -> set_var_value p ctx vari vexpr + | Some ei -> set_var_value_tab p ctx vari ei vexpr) + | EventFieldDecl (idx, f, expr) -> ( + let new_idx = evaluate_expr ctx p idx in + match new_idx with + | Number z when N.(z >=. zero ()) -> ( + let i = Int64.to_int N.(to_int z) in + match IntMap.find_opt i ctx.ctx_events with + | Some m -> ( + match StrMap.find (Pos.unmark f) m with + | Com.RefVar var -> + let vari = get_var ctx var in + set_var_value p ctx vari expr + | Com.Numeric _ -> assert false) + | None -> ()) + | _ -> ())) + | Com.Affectation (Com.MultipleFormulaes _, _) -> assert false | Com.IfThenElse (b, t, f) -> ( match evaluate_expr ctx p b with | Number z when N.(z =. zero ()) -> evaluate_stmts tn canBlock p ctx f From c85d47373a11d5bde9a65ace0aa1bc1339624023 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Wed, 22 Jan 2025 20:29:28 +0100 Subject: [PATCH 12/32] =?UTF-8?q?Am=C3=A9lioration=20de=20la=20gestion=20d?= =?UTF-8?q?es=20=C3=A9v=C3=A9nements.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- examples/dgfip_c/ml_primitif/ml_driver/m.ml | 16 ++++- .../ml_primitif/ml_driver/read_test.ml | 21 ++++-- .../dgfip_c/ml_primitif/ml_driver/stubs.c | 68 +++++++++++++------ src/mlang/backend_compilers/bir_to_dgfip_c.ml | 4 +- .../backend_compilers/dgfip_gen_files.ml | 15 ++-- src/mlang/test_framework/irj_parser.mly | 13 +++- src/mlang/test_framework/test_interpreter.ml | 52 +++++--------- 7 files changed, 120 insertions(+), 69 deletions(-) diff --git a/examples/dgfip_c/ml_primitif/ml_driver/m.ml b/examples/dgfip_c/ml_primitif/ml_driver/m.ml index e15dee7d2..54bd75785 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/m.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/m.ml @@ -148,5 +148,19 @@ external get_err_list : TGV.t -> string list = "ml_get_err_list" external annee_calc : unit -> int = "ml_annee_calc" external export_errs : TGV.t -> unit = "ml_export_errs" external enchainement_primitif : TGV.t -> unit = "ml_enchainement_primitif" -external set_evt_list : TGV.t -> (float * float * string * float * float * float * float * float * float) list-> unit = "ml_set_evt_list" +external set_evt_list : + TGV.t + -> ( + float + * float + * string + * float + * float + * float option + * float option + * float + * float option + ) list + -> unit += "ml_set_evt_list" diff --git a/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml b/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml index 2384728f2..ea326eed5 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml @@ -21,7 +21,6 @@ let convert_int s = try int_of_string s with _ -> 0 let convert_float s = try Float.of_string s - (* with _ -> 0.0 *) with _ -> (* to cope with badly formatted tests *) try Float.of_string (String.sub s 0 @@ -29,6 +28,10 @@ let convert_float s = ((String.index s '.') + 1) '.')) with _ -> 0.0 +let convert_float_opt s = + let rec isSpc i = i < 0 || (s.[i] = ' ' && isSpc (i - 1)) in + if isSpc (String.length s - 1) then None else Some (convert_float s) + let parse_generic s = let sl = String.split_on_char '/' s in match sl with @@ -60,6 +63,7 @@ let parse_entree_rap s = match sl with | [ num_evt; num_rappel; code; montant; sens; penalite; base_tl; date_evt; ind20 ] -> + if String.length code = 0 then err (); let sens_float = if String.length sens = 0 then err (); match sens.[0] with @@ -69,10 +73,17 @@ let parse_entree_rap s = | 'P' -> 3.0 | _ -> err () in - (convert_float num_evt, convert_float num_rappel, - code, convert_float montant, sens_float, - convert_float penalite, convert_float base_tl, - convert_float date_evt, convert_float ind20) (* TODO: improve *) + ( + convert_float num_evt, + convert_float num_rappel, + code, + convert_float montant, + sens_float, + convert_float_opt penalite, + convert_float_opt base_tl, + convert_float date_evt, + convert_float_opt ind20 + ) (* TODO: improve *) | _ -> err () let read_section_contents f parsefun = diff --git a/examples/dgfip_c/ml_primitif/ml_driver/stubs.c b/examples/dgfip_c/ml_primitif/ml_driver/stubs.c index fff6ca7eb..6f2373a0c 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/stubs.c +++ b/examples/dgfip_c/ml_primitif/ml_driver/stubs.c @@ -215,7 +215,7 @@ CAMLprim value ml_enchainement_primitif(value mlTgv) { CAMLprim value ml_set_evt_list(value mlTgv, value mlEvtList) { CAMLparam2(mlTgv, mlEvtList); - CAMLlocal2(mlList, mlEvt); + CAMLlocal3(mlList, mlEvt, mlField); T_irdata *tgv = Tgv_val(mlTgv); int len = 0; @@ -225,7 +225,7 @@ CAMLprim value ml_set_evt_list(value mlTgv, value mlEvtList) { mlList = Field(mlList, 1); } if (len > 0) { - tgv->events = (T_event *)malloc(len * sizeof (T_event)); + tgv->events = (T_event **)malloc(len * sizeof (T_event *)); } else { tgv->events = NULL; } @@ -234,24 +234,54 @@ CAMLprim value ml_set_evt_list(value mlTgv, value mlEvtList) { int i = 0; mlList = mlEvtList; while (mlList != Val_emptylist) { + T_event *evt = (T_event *)malloc(sizeof (T_event)); + tgv->events[i] = evt; mlEvt = Field(mlList, 0); - tgv->events[i].field_numero_def = 1; - tgv->events[i].field_numero_val = Double_val(Field(mlEvt, 0)); - tgv->events[i].field_rappel_def = 1; - tgv->events[i].field_rappel_val = Double_val(Field(mlEvt, 1)); - tgv->events[i].field_code_var = cherche_var(tgv, String_val(Field(mlEvt, 2))); - tgv->events[i].field_montant_def = 1; - tgv->events[i].field_montant_val = Double_val(Field(mlEvt, 3)); - tgv->events[i].field_sens_def = 1; - tgv->events[i].field_sens_val = Double_val(Field(mlEvt, 4)); - tgv->events[i].field_penalite_def = 1; - tgv->events[i].field_penalite_val = Double_val(Field(mlEvt, 5)); - tgv->events[i].field_base_tl_def = 1; - tgv->events[i].field_base_tl_val = Double_val(Field(mlEvt, 6)); - tgv->events[i].field_date_def = 1; - tgv->events[i].field_date_val = Double_val(Field(mlEvt, 7)); - tgv->events[i].field_2042_rect_def = 1; - tgv->events[i].field_2042_rect_val = Double_val(Field(mlEvt, 8)); + + evt->field_numero_def = 1; + evt->field_numero_val = Double_val(Field(mlEvt, 0)); + + evt->field_rappel_def = 1; + evt->field_rappel_val = Double_val(Field(mlEvt, 1)); + + evt->field_code_var = cherche_var(tgv, String_val(Field(mlEvt, 2))); + + evt->field_montant_def = 1; + evt->field_montant_val = Double_val(Field(mlEvt, 3)); + + evt->field_sens_def = 1; + evt->field_sens_val = Double_val(Field(mlEvt, 4)); + + mlField = Field(mlEvt, 5); + if (mlField == Val_none) { + evt->field_penalite_def = 0; + evt->field_penalite_val = 0.0; + } else { + evt->field_penalite_def = 1; + evt->field_penalite_val = Double_val(Some_val(mlField)); + } + + mlField = Field(mlEvt, 6); + if (mlField == Val_none) { + evt->field_base_tl_def = 0; + evt->field_base_tl_val = 0.0; + } else { + evt->field_base_tl_def = 1; + evt->field_base_tl_val = Double_val(Some_val(mlField)); + } + + evt->field_date_def = 1; + evt->field_date_val = Double_val(Field(mlEvt, 7)); + + mlField = Field(mlEvt, 8); + if (mlField == Val_none) { + evt->field_2042_rect_def = 0; + evt->field_2042_rect_val = 0.0; + } else { + evt->field_2042_rect_def = 1; + evt->field_2042_rect_val = Double_val(Some_val(mlField)); + } + i++; mlList = Field(mlList, 1); } diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index ceba8c59a..c69750b27 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -499,7 +499,7 @@ let generate_event_field_def (dgfip_flags : Dgfip_options.flags) def_expr (D.format_assign dgfip_flags expr_val) value_expr; - pr "ecris_varinfo(irdata, irdata->events[%s].field_%s_var, %s, %s);" idx_val + pr "ecris_varinfo(irdata, irdata->events[%s]->field_%s_var, %s, %s);" idx_val (Pos.unmark field) expr_def expr_val; pr "@]@;}@;"; pr "@]@;}"; @@ -605,7 +605,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) Format.fprintf oc "@[if(%s && 0 <= idx && idx < irdata->nb_events){@;" print_def; Format.fprintf oc - "print_string(%s, %s, irdata->events[idx].field_%s_var->%s);@]@;" + "print_string(%s, %s, irdata->events[idx]->field_%s_var->%s);@]@;" print_std pr_ctx (Pos.unmark f) name_or_alias; Format.fprintf oc "}@]@;"; Format.fprintf oc "}@;" diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index 62efb06ca..d5278867d 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -386,7 +386,7 @@ struct S_irdata { int sz_err_archive; char **err_archive; int nb_err_archive; - T_event *events; + T_event **events; int nb_events; T_print_context ctx_pr_out; T_print_context ctx_pr_err; @@ -1178,6 +1178,13 @@ void detruis_irdata(T_irdata *irdata) { if (irdata->err_finalise != NULL) free(irdata->err_finalise); if (irdata->err_sortie != NULL) free(irdata->err_sortie); if (irdata->err_archive != NULL) free(irdata->err_archive); + if (irdata->events != NULL) { + int i = 0; + for (i = 0; i < irdata->nb_events; i++) { + if (irdata->events[i] != NULL) free(irdata->events[i]); + } + free(irdata->events); + } free(irdata); } @@ -1618,12 +1625,12 @@ void pr_err_var(T_irdata *irdata, char *nom) { Format.fprintf fmt " return 0;\n"; Format.fprintf fmt " }\n"; if ef.is_var then ( - Format.fprintf fmt " info = irdata->events[idx].field_%s_var;\n" f; + Format.fprintf fmt " info = irdata->events[idx]->field_%s_var;\n" f; Format.fprintf fmt " *res_def = lis_varinfo_def(irdata, info);\n"; Format.fprintf fmt " *res_val = lis_varinfo_val(irdata, info);\n") else ( - Format.fprintf fmt " *res_def = irdata->events[idx].field_%s_def;\n" f; - Format.fprintf fmt " *res_val = irdata->events[idx].field_%s_val;\n" f); + Format.fprintf fmt " *res_def = irdata->events[idx]->field_%s_def;\n" f; + Format.fprintf fmt " *res_val = irdata->events[idx]->field_%s_val;\n" f); Format.fprintf fmt " return *res_def;\n"; Format.fprintf fmt "}\n\n") cprog.program_event_fields diff --git a/src/mlang/test_framework/irj_parser.mly b/src/mlang/test_framework/irj_parser.mly index 3131aee3f..25f00fa6b 100644 --- a/src/mlang/test_framework/irj_parser.mly +++ b/src/mlang/test_framework/irj_parser.mly @@ -124,11 +124,18 @@ rappel: month_year = integer SLASH decl_2042_rect = INTEGER? NL { + if String.length variable_code = 0 then + error $loc(variable_code) "Invalid value for 'variable_code' (must be non-empty)"; if direction <> "R" && direction <> "C" && direction <> "M" && direction <> "P" then error $loc(direction) ("Unknown value for 'direction' (type of the 'rappel', should be R, C, M or P) : " ^ direction); - let p = match penalty_code with Some p -> p | _ -> 0 in - if p < 0 || p > 99 then - error $loc(direction) ("Invalid value for 'penalty_code' (out of range 0-99) : " ^ (string_of_int p)); + (match penalty_code with + | Some p when p < 0 || 99 < p -> + error $loc(penalty_code) ("Invalid value for 'penalty_code' (out of range 0-99) : " ^ (string_of_int p)); + | _ -> ()); + (match decl_2042_rect with + | Some p when p < 0 || 1 < p -> + error $loc(decl_2042_rect) ("Invalid value for 'decl_2042_rect' (out of range 0-1) : " ^ (string_of_int p)); + | _ -> ()); {event_nb; rappel_nb; variable_code; diff --git a/src/mlang/test_framework/test_interpreter.ml b/src/mlang/test_framework/test_interpreter.ml index e084ece05..30ff3886e 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -46,49 +46,31 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : | None -> vn in match StrMap.find_opt name program.program_vars with - | Some var -> var + | Some var -> Com.RefVar var | None -> Cli.error_print "Variable inconnue: %s" vn; raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) in let fromDirection = function - | "R" -> Some 0.0 - | "C" -> Some 1.0 - | "M" -> Some 2.0 - | "P" -> Some 3.0 - | s -> - Cli.error_print "Sens du rappel: %s, devrait être parmi R, C, M et P" - s; - raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) - in - let fromPenalty = function - | None -> Some 0.0 (* None *) - | Some p when 0 <= p && p <= 99 -> Some (float p) - | Some p -> - Cli.error_print "Code de pénalité: %d, devrait être entre 0 et 99" p; - raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) - in - let from_2042_rect = function - | None -> Some 0.0 (* None *) - | Some 0 -> Some 0.0 - | Some 1 -> Some 1.0 - | Some r -> - Cli.error_print - "Indicateur de déclaration rectificative: %d, devrait être 0 ou 1" r; - raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) + | "R" -> Com.Numeric (Some 0.0) + | "C" -> Com.Numeric (Some 1.0) + | "M" -> Com.Numeric (Some 2.0) + | "P" -> Com.Numeric (Some 3.0) + | _ -> assert false in + let toNum p = Com.Numeric (Some (float p)) in + let optToNum p = Com.Numeric (Option.map float p) in let toEvent (rappel : Irj_ast.rappel) = IntMap.empty - |> IntMap.add 0 (Com.Numeric (Some (float rappel.event_nb))) - |> IntMap.add 1 (Com.Numeric (Some (float rappel.rappel_nb))) - |> IntMap.add 2 (Com.RefVar (from_var rappel.variable_code)) - |> IntMap.add 3 (Com.Numeric (Some (float rappel.change_value))) - |> IntMap.add 4 (Com.Numeric (fromDirection rappel.direction)) - |> IntMap.add 5 (Com.Numeric (fromPenalty rappel.penalty_code)) - |> IntMap.add 6 - (Com.Numeric (Option.map float rappel.base_tolerance_legale)) - |> IntMap.add 7 (Com.Numeric (Some (float rappel.month_year))) - |> IntMap.add 8 (Com.Numeric (from_2042_rect rappel.decl_2042_rect)) + |> IntMap.add 0 (toNum rappel.event_nb) + |> IntMap.add 1 (toNum rappel.rappel_nb) + |> IntMap.add 2 (from_var rappel.variable_code) + |> IntMap.add 3 (toNum rappel.change_value) + |> IntMap.add 4 (fromDirection rappel.direction) + |> IntMap.add 5 (optToNum rappel.penalty_code) + |> IntMap.add 6 (optToNum rappel.base_tolerance_legale) + |> IntMap.add 7 (toNum rappel.month_year) + |> IntMap.add 8 (optToNum rappel.decl_2042_rect) in List.map toEvent rappels in From e26fd33ac76d222195e0dbcb8399914b80479a1e Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 23 Jan 2025 15:07:32 +0100 Subject: [PATCH 13/32] =?UTF-8?q?Arrangement=20des=20=C3=A9v=C3=A9nements?= =?UTF-8?q?=20(en=20cours).?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2023/cibles.m | 4 + src/mlang/backend_compilers/bir_to_dgfip_c.ml | 20 +- src/mlang/m_frontend/check_validity.ml | 148 +++++++------ src/mlang/m_frontend/expand_macros.ml | 37 +++- src/mlang/m_frontend/mast_to_mir.ml | 203 ++++++++++++------ src/mlang/m_frontend/mlexer.mll | 3 + src/mlang/m_frontend/mparser.mly | 58 ++++- src/mlang/m_ir/com.ml | 36 +++- src/mlang/m_ir/com.mli | 15 +- src/mlang/m_ir/mir.ml | 31 ++- src/mlang/m_ir/mir_interpreter.ml | 154 +++++++------ src/mlang/m_ir/mir_interpreter.mli | 10 +- src/mlang/test_framework/test_interpreter.ml | 39 ++-- 13 files changed, 491 insertions(+), 267 deletions(-) diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index 9b6fdfa6f..28789858d 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -858,6 +858,10 @@ si nb_evenements() > 0 alors afficher_erreur "0: " nom(0, code) " = " (champ_evenement(0, code)) "\n"; champ_evenement(0, code) = 456; afficher_erreur "1: " nom(0, code) " = " (champ_evenement(0, code)) "\n"; + afficher_erreur "0: " nom(0, montant) " = " (champ_evenement(0, montant)) "\n"; + champ_evenement(0, montant) = 123.456; + afficher_erreur "1: " nom(0, montant) " = " (champ_evenement(0, montant)) "\n"; + sinon afficher_erreur "!!! AUCUN EVENEMENT !!!\n"; finsi diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index ceba8c59a..7e6bc5d5c 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -347,7 +347,7 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : (Format.sprintf "attribut_%s((T_varinfo *)%s)" (Pos.unmark a) ptr) in D.build_transitive_composition { set_vars = []; def_test; value_comp } - | EventField (me, f) -> + | EventField (me, f, _) -> let fn = Format.sprintf "event_field_%s" (Pos.unmark f) in let res = fresh_c_local "result" in let def_res = Pp.spr "def_%s" res in @@ -467,7 +467,7 @@ let generate_var_def (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t) pr "@]@;}@;" let generate_event_field_def (dgfip_flags : Dgfip_options.flags) - (idx : Mir.expression Pos.marked) (field : string Pos.marked) + (p : Mir.program) (idx : Mir.expression Pos.marked) (field : string) (expr : Mir.expression Pos.marked) (fmt : Format.formatter) : unit = let pr form = Format.fprintf fmt form in pr "@[{@;"; @@ -499,8 +499,12 @@ let generate_event_field_def (dgfip_flags : Dgfip_options.flags) def_expr (D.format_assign dgfip_flags expr_val) value_expr; - pr "ecris_varinfo(irdata, irdata->events[%s].field_%s_var, %s, %s);" idx_val - (Pos.unmark field) expr_def expr_val; + if (StrMap.find field p.program_event_fields).is_var then + pr "ecris_varinfo(irdata, irdata->events[%s]->field_%s_var, %s, %s);" + idx_val field expr_def expr_val + else ( + pr "irdata->events[%s]->field_%s_def = %s;@;" idx_val field expr_def; + pr "irdata->events[%s]->field_%s_val = %s;" idx_val field expr_val); pr "@]@;}@;"; pr "@]@;}"; pr "@]@;}@;" @@ -512,9 +516,9 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) Format.fprintf oc "@[{@;"; generate_var_def dgfip_flags (Pos.unmark m_var) vidx_opt vexpr oc; Format.fprintf oc "@]@;}@;" - | Affectation (SingleFormula (EventFieldDecl (idx, f, expr)), _) -> + | Affectation (SingleFormula (EventFieldDecl (idx, f, _, expr)), _) -> Format.fprintf oc "@[{@;"; - generate_event_field_def dgfip_flags idx f expr oc; + generate_event_field_def dgfip_flags program idx (Pos.unmark f) expr oc; Format.fprintf oc "@]@;}@;" | Affectation (MultipleFormulaes _, _) -> assert false | IfThenElse (cond, iftrue, iffalse) -> @@ -625,8 +629,8 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) let ptr = VID.gen_info_ptr var in Format.fprintf oc "print_string(%s, %s, %s->alias);@;" print_std pr_ctx ptr - | PrintEventName (e, f) -> print_name_or_alias "name" e f - | PrintEventAlias (e, f) -> print_name_or_alias "alias" e f + | PrintEventName (e, f, _) -> print_name_or_alias "name" e f + | PrintEventAlias (e, f, _) -> print_name_or_alias "alias" e f | PrintIndent e -> let locals, set, def, value = D.build_expression @@ generate_c_expr e diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index 932c502e0..966f1c431 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -319,12 +319,6 @@ module Err = struct let unknown_event_field name pos = let msg = Format.asprintf "unknown event field \"%s\"" name in Errors.raise_spanned_error msg pos - - let event_field_not_a_reference name pos = - let msg = - Format.asprintf "event field \"%s\" is not a variable reference" name - in - Errors.raise_spanned_error msg pos end type syms = Com.DomainId.t Pos.marked Com.DomainIdMap.t @@ -1077,7 +1071,7 @@ let rec fold_var_expr | Some _ -> Err.tmp_vars_have_no_attrs var_pos | None -> ())); fold_var v Both env acc - | EventField (e, f) -> ( + | EventField (e, f, _) -> ( if is_filter then Err.forbidden_expresion_in_filter expr_pos; match StrMap.find_opt (Pos.unmark f) env.prog.prog_event_fields with | Some _ -> fold_var_expr fold_var is_filter acc e env @@ -1189,6 +1183,22 @@ let cats_variable_from_decl_list (l : Mast.var_category_id list) let rec check_instructions (instrs : Mast.instruction Pos.marked list) (is_rule : bool) (env : var_env) : program * Mast.instruction Pos.marked list * StrSet.t * StrSet.t = + let check_it_var env var = + let var_pos = Pos.get_position var in + let var_name = Mast.get_normal_var (Pos.unmark var) in + (match StrMap.find_opt var_name env.prog.prog_vars with + | Some Com.Var.{ name = _, old_pos; _ } -> + Err.variable_already_declared var_name old_pos var_pos + | None -> ()); + (match StrMap.find_opt var_name env.tmp_vars with + | Some (_, old_pos) -> + Err.variable_already_declared var_name old_pos var_pos + | None -> ()); + (match StrMap.find_opt var_name env.ref_vars with + | Some old_pos -> Err.variable_already_declared var_name old_pos var_pos + | None -> ()); + (var_name, var_pos) + in let rec aux (env, res, in_vars, out_vars) = function | [] -> (env, List.rev res, in_vars, out_vars) | m_instr :: il -> ( @@ -1215,12 +1225,11 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) let out_vars = StrSet.add out_var out_vars in aux (env, m_instr :: res, in_vars, out_vars) il else aux (env, m_instr :: res, in_vars, out_vars) il - | Com.SingleFormula (EventFieldDecl (idx, f, e)) -> + | Com.SingleFormula (EventFieldDecl (idx, f, _, e)) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let f_name, f_pos = f in (match StrMap.find_opt f_name env.prog.prog_event_fields with - | Some ef when ef.is_var -> () - | Some _ -> Err.event_field_not_a_reference f_name f_pos + | Some _ -> () | None -> Err.unknown_event_field f_name f_pos); let in_vars_index = check_expression false idx env in let in_vars_expr = check_expression false e env in @@ -1340,7 +1349,8 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) | Com.PrintString _ -> () | Com.PrintName v | Com.PrintAlias v -> ignore (check_variable v Both env) - | Com.PrintEventName (e, f) | Com.PrintEventAlias (e, f) -> ( + | Com.PrintEventName (e, f, _) | Com.PrintEventAlias (e, f, _) + -> ( match StrMap.find_opt (Pos.unmark f) env.prog.prog_event_fields with @@ -1355,24 +1365,7 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) aux (env, m_instr :: res, in_vars, out_vars) il | Com.Iterate (var, vars, var_params, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; - let var_pos = Pos.get_position var in - let var_name = - match Pos.unmark var with - | Mast.Normal var -> var - | Mast.Generic _ -> assert false - in - (match StrMap.find_opt var_name env.prog.prog_vars with - | Some Com.Var.{ name = _, old_pos; _ } -> - Err.variable_already_declared var_name old_pos var_pos - | None -> ()); - (match StrMap.find_opt var_name env.tmp_vars with - | Some (_, old_pos) -> - Err.variable_already_declared var_name old_pos var_pos - | None -> ()); - (match StrMap.find_opt var_name env.ref_vars with - | Some old_pos -> - Err.variable_already_declared var_name old_pos var_pos - | None -> ()); + let var_name, var_pos = check_it_var env var in let env' = { env with ref_vars = StrMap.add var_name var_pos env.ref_vars } in @@ -1399,24 +1392,7 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) let res_instr = Com.Iterate (var, vars, var_params, res_instrs) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il | Com.Iterate_values (var, var_intervals, instrs) -> - let var_pos = Pos.get_position var in - let var_name = - match Pos.unmark var with - | Mast.Normal var -> var - | Mast.Generic _ -> assert false - in - (match StrMap.find_opt var_name env.prog.prog_vars with - | Some Com.Var.{ name = _, old_pos; _ } -> - Err.variable_already_declared var_name old_pos var_pos - | None -> ()); - (match StrMap.find_opt var_name env.tmp_vars with - | Some (_, old_pos) -> - Err.variable_already_declared var_name old_pos var_pos - | None -> ()); - (match StrMap.find_opt var_name env.ref_vars with - | Some old_pos -> - Err.variable_already_declared var_name old_pos var_pos - | None -> ()); + let var_name, var_pos = check_it_var env var in let env' = { env with @@ -1463,20 +1439,7 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) StrMap.empty vars); List.iter (fun (var, vcats, expr) -> - let var_pos = Pos.get_position var in - let var_name = Mast.get_normal_var (Pos.unmark var) in - (match StrMap.find_opt var_name env.prog.prog_vars with - | Some Com.Var.{ name = _, old_pos; _ } -> - Err.variable_already_declared var_name old_pos var_pos - | None -> ()); - (match StrMap.find_opt var_name env.tmp_vars with - | Some (_, old_pos) -> - Err.variable_already_declared var_name old_pos var_pos - | None -> ()); - (match StrMap.find_opt var_name env.ref_vars with - | Some old_pos -> - Err.variable_already_declared var_name old_pos var_pos - | None -> ()); + let var_name, var_pos = check_it_var env var in ignore (mast_to_catvars vcats env.prog.prog_var_cats); let env = { @@ -1492,6 +1455,40 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) let env = { env with prog } in let res_instr = Com.Restore (vars, var_params, res_instrs) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il + | Com.ArrangeEvents (sort, filter, instrs) -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + (match sort with + | Some (var0, var1, expr) -> + let var0_name, var0_pos = check_it_var env var0 in + let var1_name, var1_pos = check_it_var env var1 in + let env = + { + env with + tmp_vars = + env.tmp_vars + |> StrMap.add var0_name (None, var0_pos) + |> StrMap.add var1_name (None, var1_pos); + } + in + ignore (check_expression false expr env) + | None -> ()); + (match filter with + | Some (var, expr) -> + let var_name, var_pos = check_it_var env var in + let env = + { + env with + tmp_vars = StrMap.add var_name (None, var_pos) env.tmp_vars; + } + in + ignore (check_expression false expr env) + | None -> ()); + let prog, res_instrs, _in_instrs, _out_instrs = + check_instructions instrs is_rule env + in + let env = { env with prog } in + let res_instr = Com.ArrangeEvents (sort, filter, res_instrs) in + aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il | Com.RaiseError (m_err, m_var_opt) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let err_name, err_pos = m_err in @@ -2545,6 +2542,11 @@ let complete_vars_stack (prog : program) : program = | Com.Restore (_, _, instrs) -> let nbRef, nbIt = aux_instrs instrs in (max nbRef 1, nbIt) + | Com.ArrangeEvents (sort, filter, instrs) -> + let nbItSort = match sort with Some _ -> 2 | None -> 0 in + let nbItFilter = match filter with Some _ -> 1 | None -> 0 in + let nbRef, nbIt = aux_instrs instrs in + (nbRef, max nbIt (max nbItSort nbItFilter)) | Com.Affectation _ | Com.Print _ | Com.ComputeTarget _ | Com.RaiseError _ | Com.CleanErrors | Com.ExportErrors | Com.FinalizeErrors -> (0, 0) @@ -2606,7 +2608,7 @@ let complete_vars_stack (prog : program) : program = in let nbV, szV, nbRefV, tdata = aux_expr tdata mev in (max nbI nbV, max szI szV, max nbRefI nbRefV, tdata) - | SingleFormula (EventFieldDecl (mei, _, mev)) -> + | SingleFormula (EventFieldDecl (mei, _, _, mev)) -> let nbI, szI, nbRefI, tdata = aux_expr tdata mei in let nbV, szV, nbRefV, tdata = aux_expr tdata mev in (max nbI nbV, max szI szV, max nbRefI nbRefV, tdata) @@ -2645,8 +2647,8 @@ let complete_vars_stack (prog : program) : program = match a with | Com.PrintString _ | Com.PrintName _ | Com.PrintAlias _ -> (nb, sz, nbRef, tdata) - | Com.PrintEventName (me, _) - | Com.PrintEventAlias (me, _) + | Com.PrintEventName (me, _, _) + | Com.PrintEventAlias (me, _, _) | Com.PrintIndent me | Com.PrintExpr (me, _, _) -> let nb', sz', nbRef', tdata = aux_expr tdata me in @@ -2697,6 +2699,22 @@ let complete_vars_stack (prog : program) : program = let sz = max sz sz' in let nbRef = 1 + max nbRef nbRef' in (nb, sz, nbRef, tdata) + | Com.ArrangeEvents (sort, filter, instrs) -> + let n', (nb', sz', nbRef', tdata) = + match sort with + | Some (_, _, expr) -> (2, aux_expr tdata expr) + | None -> (0, (0, 0, 0, tdata)) + in + let n'', (nb'', sz'', nbRef'', tdata) = + match filter with + | Some (_, expr) -> (1, aux_expr tdata expr) + | None -> (0, (0, 0, 0, tdata)) + in + let nb, sz, nbRef, tdata = aux_instrs tdata instrs in + let nb = max n' n'' + max nb (max nb' nb'') in + let sz = max n' n'' + max sz (max sz' sz'') in + let nbRef = max nbRef (max nbRef' nbRef'') in + (nb, sz, nbRef, tdata) | Com.RaiseError _ | Com.CleanErrors | Com.ExportErrors | Com.FinalizeErrors -> (0, 0, 0, tdata) @@ -2707,7 +2725,7 @@ let complete_vars_stack (prog : program) : program = | Com.TestInSet (_, me, _) | Com.Unop (_, me) | Com.Index (_, me) - | Com.EventField (me, _) -> + | Com.EventField (me, _, _) -> aux_expr tdata me | Com.Comparison (_, me0, me1) | Com.Binop (_, me0, me1) -> let nb0, sz0, nbRef0, tdata = aux_expr tdata me0 in diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index 3f1e2d497..7e505e963 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -617,9 +617,9 @@ let rec expand_expression (const_map : const_context) (loop_map : loop_context) | Var v, v_pos -> (Attribut ((v, v_pos), a), expr_pos) | Literal (Float _), v_pos -> Err.constant_cannot_have_an_attribut v_pos | _ -> assert false) - | EventField (e, f) -> + | EventField (e, f, i) -> let e' = expand_expression const_map loop_map e in - (EventField (e', f), expr_pos) + (EventField (e', f, i), expr_pos) | Size var -> ( match expand_variable const_map loop_map var with | Var v, v_pos -> (Size (v, v_pos), expr_pos) @@ -646,10 +646,10 @@ let expand_formula (const_map : const_context) let idx' = Option.map (expand_expression const_map ParamsMap.empty) idx in let e' = expand_expression const_map ParamsMap.empty e in (Com.SingleFormula (VarDecl (v', idx', e')), form_pos) :: prev - | Com.SingleFormula (EventFieldDecl (idx, f, e)) -> + | Com.SingleFormula (EventFieldDecl (idx, f, i, e)) -> let idx' = expand_expression const_map ParamsMap.empty idx in let e' = expand_expression const_map ParamsMap.empty e in - (Com.SingleFormula (EventFieldDecl (idx', f, e')), form_pos) :: prev + (Com.SingleFormula (EventFieldDecl (idx', f, i, e')), form_pos) :: prev | Com.MultipleFormulaes (lvs, VarDecl (v, idx, e)) -> let loop_context_provider = expand_loop_variables lvs const_map in let translator loop_map = @@ -666,12 +666,12 @@ let expand_formula (const_map : const_context) in let res = loop_context_provider translator in List.rev res @ prev - | Com.MultipleFormulaes (lvs, EventFieldDecl (idx, f, e)) -> + | Com.MultipleFormulaes (lvs, EventFieldDecl (idx, f, i, e)) -> let loop_context_provider = expand_loop_variables lvs const_map in let translator loop_map = let idx' = expand_expression const_map loop_map idx in let e' = expand_expression const_map loop_map e in - (Com.SingleFormula (EventFieldDecl (idx', f, e')), form_pos) + (Com.SingleFormula (EventFieldDecl (idx', f, i, e')), form_pos) in let res = loop_context_provider translator in List.rev res @ prev @@ -705,12 +705,12 @@ let rec expand_instruction (const_map : const_context) List.map (fun arg -> match Pos.unmark arg with - | Com.PrintEventName (expr, f) -> + | Com.PrintEventName (expr, f, i) -> let expr' = expand_expression const_map ParamsMap.empty expr in - (Com.PrintEventName (expr', f), Pos.get_position arg) - | Com.PrintEventAlias (expr, f) -> + (Com.PrintEventName (expr', f, i), Pos.get_position arg) + | Com.PrintEventAlias (expr, f, i) -> let expr' = expand_expression const_map ParamsMap.empty expr in - (Com.PrintEventAlias (expr', f), Pos.get_position arg) + (Com.PrintEventAlias (expr', f, i), Pos.get_position arg) | Com.PrintIndent expr -> let expr' = expand_expression const_map ParamsMap.empty expr in (Com.PrintIndent expr', Pos.get_position arg) @@ -746,6 +746,23 @@ let rec expand_instruction (const_map : const_context) | Com.Restore (vars, var_params, instrs) -> let instrs' = expand_instructions const_map instrs in (Com.Restore (vars, var_params, instrs'), instr_pos) :: prev + | Com.ArrangeEvents (sort, filter, instrs) -> + let sort' = + match sort with + | Some (var0, var1, expr) -> + let expr' = expand_expression const_map ParamsMap.empty expr in + Some (var0, var1, expr') + | None -> None + in + let filter' = + match filter with + | Some (var, expr) -> + let expr' = expand_expression const_map ParamsMap.empty expr in + Some (var, expr') + | None -> None + in + let instrs' = expand_instructions const_map instrs in + (Com.ArrangeEvents (sort', filter', instrs'), instr_pos) :: prev | Com.VerifBlock instrs -> let instrs' = expand_instructions const_map instrs in (Com.VerifBlock instrs', instr_pos) :: prev diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index ef71a822d..160c80d81 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -57,14 +57,14 @@ let translate_variable (var_data : Com.Var.t StrMap.t) (** {2 Translation of expressions}*) -let rec translate_expression (cats : Com.CatVar.data Com.CatVar.Map.t) +let rec translate_expression (p : Check_validity.program) (var_data : Com.Var.t StrMap.t) (f : Mast.expression Pos.marked) : Mir.expression Pos.marked = let open Com in let expr = match Pos.unmark f with | TestInSet (positive, e, values) -> - let new_e = translate_expression cats var_data e in + let new_e = translate_expression p var_data e in let new_set_values = List.map (function @@ -81,8 +81,8 @@ let rec translate_expression (cats : Com.CatVar.data Com.CatVar.Map.t) in TestInSet (positive, new_e, new_set_values) | Comparison (op, e1, e2) -> - let new_e1 = translate_expression cats var_data e1 in - let new_e2 = translate_expression cats var_data e2 in + let new_e1 = translate_expression p var_data e1 in + let new_e2 = translate_expression p var_data e2 in Comparison (op, new_e1, new_e2) | Binop (op, e1, e2) -> (* if @@ -94,35 +94,36 @@ let rec translate_expression (cats : Com.CatVar.data Com.CatVar.Map.t) constant substitutions that could wrongly trigger the warning *) Errors.print_spanned_warning "Nullifying constant multiplication found." (Pos.get_position f);*) - let new_e1 = translate_expression cats var_data e1 in - let new_e2 = translate_expression cats var_data e2 in + let new_e1 = translate_expression p var_data e1 in + let new_e2 = translate_expression p var_data e2 in Binop (op, new_e1, new_e2) | Unop (op, e) -> - let new_e = translate_expression cats var_data e in + let new_e = translate_expression p var_data e in Unop (op, new_e) | Index (t, i) -> let t_var = translate_variable var_data t in - let new_i = translate_expression cats var_data i in + let new_i = translate_expression p var_data i in Index ( (match Pos.unmark t_var with | Var v -> (v, Pos.get_position f) | _ -> assert false (* should not happen *)), new_i ) | Conditional (e1, e2, e3) -> - let new_e1 = translate_expression cats var_data e1 in - let new_e2 = translate_expression cats var_data e2 in - let new_e3 = Option.map (translate_expression cats var_data) e3 in + let new_e1 = translate_expression p var_data e1 in + let new_e2 = translate_expression p var_data e2 in + let new_e3 = Option.map (translate_expression p var_data) e3 in Conditional (new_e1, new_e2, new_e3) | FuncCall (f_name, args) -> let new_args = - List.map (fun arg -> translate_expression cats var_data arg) args + List.map (fun arg -> translate_expression p var_data arg) args in FuncCall (f_name, new_args) | Literal l -> Literal l | Var var -> let new_var = translate_variable var_data (Pos.same_pos_as var f) in Pos.unmark new_var - | NbCategory cs -> NbCategory (Check_validity.mast_to_catvars cs cats) + | NbCategory cs -> + NbCategory (Check_validity.mast_to_catvars cs p.prog_var_cats) | Attribut (v, a) -> ( if CatVar.Map.fold @@ -131,7 +132,7 @@ let rec translate_expression (cats : Com.CatVar.data Com.CatVar.Map.t) && StrMap.fold (fun attr _ res -> res && attr <> Pos.unmark a) attributs true) - cats true + p.prog_var_cats true then Errors.raise_spanned_error "unknown attribut" (Pos.get_position a); let v_name = match Pos.unmark v with @@ -148,9 +149,10 @@ let rec translate_expression (cats : Com.CatVar.data Com.CatVar.Map.t) | _ -> let msg = Format.sprintf "unknown variable %s" v_name in Errors.raise_spanned_error msg (Pos.get_position v)) - | EventField (e, f) -> - let new_e = translate_expression cats var_data e in - EventField (new_e, f) + | EventField (e, f, _) -> + let new_e = translate_expression p var_data e in + let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in + EventField (new_e, f, i) | Size v -> ( let v_name = match Pos.unmark v with @@ -173,9 +175,8 @@ let rec translate_expression (cats : Com.CatVar.data Com.CatVar.Map.t) (** {2 Translation of source file items}*) -let rec translate_prog (error_decls : Com.Error.t StrMap.t) - (cats : Com.CatVar.data Com.CatVar.Map.t) (var_data : Com.Var.t StrMap.t) - (it_depth : int) (itval_depth : int) prog = +let rec translate_prog (p : Check_validity.program) + (var_data : Com.Var.t StrMap.t) (it_depth : int) (itval_depth : int) prog = let rec aux res = function | [] -> List.rev res | (Com.Affectation (SingleFormula decl, _), pos) :: il -> @@ -188,25 +189,26 @@ let rec translate_prog (error_decls : Com.Error.t StrMap.t) | _ -> assert false (* should not happen *) in - let idx' = Option.map (translate_expression cats var_data) idx in - let e' = translate_expression cats var_data e in + let idx' = Option.map (translate_expression p var_data) idx in + let e' = translate_expression p var_data e in Com.VarDecl (var, idx', e') - | EventFieldDecl (idx, f, e) -> - let idx' = translate_expression cats var_data idx in - let e' = translate_expression cats var_data e in - Com.EventFieldDecl (idx', f, e') + | EventFieldDecl (idx, f, _, e) -> + let idx' = translate_expression p var_data idx in + let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in + let e' = translate_expression p var_data e in + Com.EventFieldDecl (idx', f, i, e') in let m_form = (Com.SingleFormula decl', pos) in aux ((Com.Affectation m_form, pos) :: res) il | (Com.Affectation (MultipleFormulaes _, _), _) :: _ -> assert false | (Com.IfThenElse (e, ilt, ile), pos) :: il -> - let expr = translate_expression cats var_data e in + let expr = translate_expression p var_data e in let prog_then = aux [] ilt in let prog_else = aux [] ile in aux ((Com.IfThenElse (expr, prog_then, prog_else), pos) :: res) il | (Com.WhenDoElse (wdl, ed), pos) :: il -> let map_wdl (expr, dl, pos) = - let expr' = translate_expression cats var_data expr in + let expr' = translate_expression p var_data expr in let dl' = aux [] dl in (expr', dl', pos) in @@ -265,17 +267,23 @@ let rec translate_prog (error_decls : Com.Error.t StrMap.t) Format.sprintf "unknown variable %s" name in Errors.raise_spanned_error msg (Pos.get_position v)) - | Com.PrintEventName (e, f) -> - let e' = translate_expression cats var_data e in - Com.PrintEventName (e', f) - | Com.PrintEventAlias (e, f) -> - let e' = translate_expression cats var_data e in - Com.PrintEventAlias (e', f) + | Com.PrintEventName (e, f, _) -> + let e' = translate_expression p var_data e in + let i = + (StrMap.find (Pos.unmark f) p.prog_event_fields).index + in + Com.PrintEventName (e', f, i) + | Com.PrintEventAlias (e, f, _) -> + let e' = translate_expression p var_data e in + let i = + (StrMap.find (Pos.unmark f) p.prog_event_fields).index + in + Com.PrintEventAlias (e', f, i) | Com.PrintIndent e -> - Com.PrintIndent (translate_expression cats var_data e) + Com.PrintIndent (translate_expression p var_data e) | Com.PrintExpr (e, min, max) -> Com.PrintExpr - (translate_expression cats var_data e, min, max) + (translate_expression p var_data e, min, max) in Pos.same_pos_as mir_arg arg :: res) [] args) @@ -283,11 +291,7 @@ let rec translate_prog (error_decls : Com.Error.t StrMap.t) aux ((Com.Print (std, mir_args), pos) :: res) il | (Com.Iterate (vn, vars, var_params, instrs), pos) :: il -> let var_pos = Pos.get_position vn in - let var_name = - match Pos.unmark vn with - | Mast.Normal name -> name - | Mast.Generic _ -> assert false - in + let var_name = Mast.get_normal_var (Pos.unmark vn) in (match StrMap.find_opt var_name var_data with | Some v -> let msg = @@ -309,24 +313,21 @@ let rec translate_prog (error_decls : Com.Error.t StrMap.t) let var_params' = List.map (fun (vcats, expr) -> - let catSet = Check_validity.mast_to_catvars vcats cats in - let mir_expr = translate_expression cats var_data expr in + let catSet = + Check_validity.mast_to_catvars vcats p.prog_var_cats + in + let mir_expr = translate_expression p var_data expr in (catSet, mir_expr)) var_params in let prog_it = - translate_prog error_decls cats var_data (it_depth + 1) itval_depth - instrs + translate_prog p var_data (it_depth + 1) itval_depth instrs in let m_var = Pos.same_pos_as var vn in aux ((Com.Iterate (m_var, vars', var_params', prog_it), pos) :: res) il | (Com.Iterate_values (vn, var_intervals, instrs), pos) :: il -> let var_pos = Pos.get_position vn in - let var_name = - match Pos.unmark vn with - | Mast.Normal name -> name - | Mast.Generic _ -> assert false - in + let var_name = Mast.get_normal_var (Pos.unmark vn) in (match StrMap.find_opt var_name var_data with | Some v -> let msg = @@ -343,15 +344,14 @@ let rec translate_prog (error_decls : Com.Error.t StrMap.t) let var_intervals' = List.map (fun (e0, e1, step) -> - let e0' = translate_expression cats var_data e0 in - let e1' = translate_expression cats var_data e1 in - let step' = translate_expression cats var_data step in + let e0' = translate_expression p var_data e0 in + let e1' = translate_expression p var_data e1 in + let step' = translate_expression p var_data step in (e0', e1', step')) var_intervals in let prog_it = - translate_prog error_decls cats var_data it_depth (itval_depth + 1) - instrs + translate_prog p var_data it_depth (itval_depth + 1) instrs in let m_var = Pos.same_pos_as var vn in aux @@ -375,17 +375,84 @@ let rec translate_prog (error_decls : Com.Error.t StrMap.t) Com.Var.new_ref ~name:(var_name, var_pos) ~loc_int:it_depth in let var_data = StrMap.add var_name var var_data in - let catSet = Check_validity.mast_to_catvars vcats cats in - let mir_expr = translate_expression cats var_data expr in + let catSet = + Check_validity.mast_to_catvars vcats p.prog_var_cats + in + let mir_expr = translate_expression p var_data expr in (Pos.mark var_pos var, catSet, mir_expr)) var_params in - let prog_rest = - translate_prog error_decls cats var_data it_depth itval_depth instrs - in + let prog_rest = translate_prog p var_data it_depth itval_depth instrs in aux ((Com.Restore (vars', var_params', prog_rest), pos) :: res) il + | (Com.ArrangeEvents (sort, filter, instrs), pos) :: il -> + let sort', itval_depth' = + match sort with + | Some (var0, var1, expr) -> + let var0_pos = Pos.get_position var0 in + let var0_name = Mast.get_normal_var (Pos.unmark var0) in + (match StrMap.find_opt var0_name var_data with + | Some v -> + let msg = + Format.asprintf "variable already declared %a" + Pos.format_position (Pos.get_position v.name) + in + Errors.raise_spanned_error msg pos + | _ -> ()); + let var0' = + Com.Var.new_temp ~name:(var0_name, var0_pos) ~is_table:None + ~loc_int:itval_depth + in + let var1_pos = Pos.get_position var1 in + let var1_name = Mast.get_normal_var (Pos.unmark var1) in + (match StrMap.find_opt var1_name var_data with + | Some v -> + let msg = + Format.asprintf "variable already declared %a" + Pos.format_position (Pos.get_position v.name) + in + Errors.raise_spanned_error msg pos + | _ -> ()); + let var1' = + Com.Var.new_temp ~name:(var1_name, var1_pos) ~is_table:None + ~loc_int:(itval_depth + 1) + in + let var_data = + var_data |> StrMap.add var0_name var0' + |> StrMap.add var1_name var1' + in + let m_var0 = Pos.same_pos_as var0' var0 in + let m_var1 = Pos.same_pos_as var1' var1 in + let expr' = translate_expression p var_data expr in + (Some (m_var0, m_var1, expr'), itval_depth + 2) + | None -> (None, itval_depth) + in + let filter', itval_depth' = + match filter with + | Some (var, expr) -> + let var_pos = Pos.get_position var in + let var_name = Mast.get_normal_var (Pos.unmark var) in + (match StrMap.find_opt var_name var_data with + | Some v -> + let msg = + Format.asprintf "variable already declared %a" + Pos.format_position (Pos.get_position v.name) + in + Errors.raise_spanned_error msg pos + | _ -> ()); + let var' = + Com.Var.new_temp ~name:(var_name, var_pos) ~is_table:None + ~loc_int:itval_depth + in + let var_data = StrMap.add var_name var' var_data in + let m_var = Pos.same_pos_as var' var in + let expr' = translate_expression p var_data expr in + (Some (m_var, expr'), max itval_depth' (itval_depth + 1)) + | None -> (None, itval_depth') + in + let instrs' = translate_prog p var_data it_depth itval_depth' instrs in + aux ((Com.ArrangeEvents (sort', filter', instrs'), pos) :: res) il | (Com.RaiseError (err_name, var_opt), pos) :: il -> - let err_decl = StrMap.find (Pos.unmark err_name) error_decls in + let err_decl = StrMap.find (Pos.unmark err_name) p.prog_errors in let m_err_decl = Pos.same_pos_as err_decl err_name in aux ((Com.RaiseError (m_err_decl, var_opt), pos) :: res) il | (Com.CleanErrors, pos) :: il -> aux ((Com.CleanErrors, pos) :: res) il @@ -399,9 +466,9 @@ let rec translate_prog (error_decls : Com.Error.t StrMap.t) in aux [] prog -let get_targets (is_function : bool) (error_decls : Com.Error.t StrMap.t) - (cats : Com.CatVar.data Com.CatVar.Map.t) (var_data : Com.Var.t StrMap.t) - (ts : Mast.target StrMap.t) : Mir.target_data Com.TargetMap.t = +let get_targets (is_function : bool) (p : Check_validity.program) + (var_data : Com.Var.t StrMap.t) (ts : Mast.target StrMap.t) : + Mir.target_data Com.TargetMap.t = StrMap.fold (fun _ (t : Mast.target) targets -> let target_name = t.target_name in @@ -464,7 +531,7 @@ let get_targets (is_function : bool) (error_decls : Com.Error.t StrMap.t) | None -> None in let target_prog = - translate_prog error_decls cats tmp_var_data + translate_prog p tmp_var_data (List.length target_args - target_nb_refs) itval_depth t.target_prog in @@ -515,10 +582,8 @@ let translate (p : Mast.program) (main_target : string) : Mir.program = StrMap.map map_chainings prog.prog_chainings in let errs = prog.prog_errors in - let functions = - get_targets true errs var_category_map var_data prog_functions - in - let targets = get_targets false errs var_category_map var_data prog_targets in + let functions = get_targets true prog var_data prog_functions in + let targets = get_targets false prog var_data prog_targets in Mir. { program_safe_prefix = prog.prog_prefix; diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index f4adb72d3..e29e6910a 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -68,6 +68,7 @@ rule token = parse | "application" -> APPLICATION | "apres" -> AFTER | "argument" -> INPUT_ARG + | "arranger_evenements" -> ARRANGE_EVENTS | "attribut" -> ATTRIBUT | "autorise" -> AUTHORIZE | "avec" -> WITH @@ -88,6 +89,7 @@ rule token = parse | "evenement" -> EVENT | "exporte_erreurs" -> EXPORT_ERRORS | "faire" -> DO + | "filtrer" -> FILTER | "finalise_erreurs" -> FINALIZE_ERRORS | "finquand" -> ENDWHEN | "finsi" -> ENDIF @@ -109,6 +111,7 @@ rule token = parse | "non" -> NOT | "numero_compl" -> COMPL_NUMBER | "numero_verif" -> VERIF_NUMBER + | "trier" -> SORT | "ou" -> OR | "par_defaut" -> BY_DEFAULT | "pour" -> FOR diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index fedd21b41..5d1e6423f 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -58,7 +58,7 @@ along with this program. If not, see . %token INFORMATIVE OUTPUT FONCTION VARIABLE ATTRIBUT %token BASE GIVEN_BACK COMPUTABLE BY_DEFAULT %token DOMAIN SPECIALIZE AUTHORIZE VERIFIABLE -%token EVENT VALUE STEP EVENT_FIELD +%token EVENT VALUE STEP EVENT_FIELD ARRANGE_EVENTS SORT FILTER %token EOF @@ -715,6 +715,41 @@ instruction: in Some (Restore (List.rev var_list, List.rev var_cats, List.rev instrs)) } +| ARRANGE_EVENTS COLON + arr_params = nonempty_list(with_pos(arrange_events_param)) + IN LPAREN instrs = instruction_list_rev RPAREN { + let sort, filter = + let fold (sort, sort_pos, filter, filter_pos) = function + | (`ArrangeEventsSort (v0, v1, e), pos) when sort = None -> + (Some (v0, v1, e), pos, filter, filter_pos) + | (`ArrangeEventsFilter (v, e), pos) when filter = None -> + (sort, sort_pos, Some (v, e), pos) + | (`ArrangeEventsSort _, pos) -> + let msg = + Format.asprintf + "event sorting already specified at %a" + Pos.format_position sort_pos + in + Errors.raise_spanned_error msg pos + | (`ArrangeEventsFilter _, pos) -> + let msg = + Format.asprintf + "event filter already specified at %a" + Pos.format_position sort_pos + in + Errors.raise_spanned_error msg pos + in + let sort, _, filter, _ = + List.fold_left fold (None, Pos.no_pos, None, Pos.no_pos) arr_params + in + match sort, filter with + | None, None -> + let msg = "event organizer needs a sort or a filter specification" in + Errors.raise_spanned_error msg (mk_position $sloc) + | _, _ -> sort, filter + in + Some (ArrangeEvents (sort, filter, List.rev instrs)) + } | RAISE_ERROR e_name = symbol_with_pos var = with_pos(variable_name)? SEMICOLON { Some (RaiseError (e_name, var)) } @@ -762,8 +797,8 @@ print_argument: | f = with_pos(print_function) LPAREN expr = with_pos(sum_expression) COMMA field = symbol_with_pos RPAREN { match Pos.unmark f with - | "nom" -> Com.PrintEventName (expr, field) - | "alias" -> Com.PrintEventAlias (expr, field) + | "nom" -> Com.PrintEventName (expr, field, -1) + | "alias" -> Com.PrintEventAlias (expr, field, -1) | _ -> assert false } | INDENT LPAREN e = with_pos(expression) RPAREN { Com.PrintIndent e } @@ -837,7 +872,6 @@ it_param: } | expr0 = with_pos(expression) RANGE expr1 = with_pos(expression) STEP step = with_pos(expression) COLON { - `VarInterval (expr0, expr1, step) } @@ -879,6 +913,18 @@ rest_param_category: rest_param_with_expr: | WITH expr = with_pos(expression) COLON { expr } +arrange_events_param: +| SORT v0 = symbol_with_pos COMMA v1 = symbol_with_pos + COLON WITH expr = with_pos(expression) COLON { + let var0 = Pos.same_pos_as (Normal (Pos.unmark v0)) v0 in + let var1 = Pos.same_pos_as (Normal (Pos.unmark v1)) v1 in + `ArrangeEventsSort (var0, var1, expr) + } +| FILTER v = symbol_with_pos COLON WITH expr = with_pos(expression) COLON { + let var = Pos.same_pos_as (Normal (Pos.unmark v)) v in + `ArrangeEventsFilter (var, expr) + } + formula_kind: | f = formula { SingleFormula f } | fs = for_formula { let (lv, ft) = fs in MultipleFormulaes (lv, ft) } @@ -895,7 +941,7 @@ lvalue: formula: | EVENT_FIELD LPAREN idx = with_pos(expression) COMMA f = symbol_with_pos RPAREN EQUALS e = with_pos(expression) { - EventFieldDecl (idx, f, e) + EventFieldDecl (idx, f, -1, e) } | lvalue = lvalue EQUALS e = with_pos(expression) { let v, idx = lvalue in @@ -1182,7 +1228,7 @@ function_call: Attribut ((parse_variable $sloc (fst var), snd var), attr) } | EVENT_FIELD LPAREN m_expr = with_pos(sum_expression) COMMA field = symbol_with_pos RPAREN { - EventField (m_expr, field) + EventField (m_expr, field, -1) } | SIZE LPAREN var = symbol_with_pos RPAREN { Size (parse_variable $sloc (fst var), snd var) diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 59618c8d7..5d6e2cbea 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -293,7 +293,7 @@ end type event_field = { name : string Pos.marked; index : int; is_var : bool } -type 'v event_value = Numeric of float option | RefVar of 'v +type ('n, 'v) event_value = Numeric of 'n | RefVar of 'v module DomainId = StrSet @@ -413,7 +413,7 @@ type 'v expression = | NbDiscordances | NbInformatives | NbBloquantes - | EventField of 'v m_expression * string Pos.marked + | EventField of 'v m_expression * string Pos.marked * int and 'v m_expression = 'v expression Pos.marked @@ -452,8 +452,8 @@ type 'v print_arg = | PrintString of string | PrintName of 'v Pos.marked | PrintAlias of 'v Pos.marked - | PrintEventName of 'v m_expression * string Pos.marked - | PrintEventAlias of 'v m_expression * string Pos.marked + | PrintEventName of 'v m_expression * string Pos.marked * int + | PrintEventAlias of 'v m_expression * string Pos.marked * int | PrintIndent of 'v m_expression | PrintExpr of 'v m_expression * int * int @@ -461,7 +461,8 @@ type 'v formula_loop = 'v loop_variables Pos.marked type 'v formula_decl = | VarDecl of 'v Pos.marked * 'v m_expression option * 'v m_expression - | EventFieldDecl of 'v m_expression * string Pos.marked * 'v m_expression + | EventFieldDecl of + 'v m_expression * string Pos.marked * int * 'v m_expression type 'v formula = | SingleFormula of 'v formula_decl @@ -495,6 +496,10 @@ type ('v, 'e) instruction = 'v Pos.marked list * ('v Pos.marked * Pos.t CatVar.Map.t * 'v m_expression) list * ('v, 'e) m_instruction list + | ArrangeEvents of + ('v Pos.marked * 'v Pos.marked * 'v m_expression) option + * ('v Pos.marked * 'v m_expression) option + * ('v, 'e) m_instruction list | RaiseError of 'e Pos.marked * string Pos.marked option | CleanErrors | ExportErrors @@ -671,7 +676,7 @@ let rec format_expression form_var fmt = | Attribut (v, a) -> Format.fprintf fmt "attribut(%a, %s)" form_var (Pos.unmark v) (Pos.unmark a) - | EventField (e, f) -> + | EventField (e, f, _) -> Format.fprintf fmt "champ_evenement(%a, %s)" form_expr (Pos.unmark e) (Pos.unmark f) | Size v -> Format.fprintf fmt "taille(%a)" form_var (Pos.unmark v) @@ -686,9 +691,9 @@ let format_print_arg form_var fmt = | PrintString s -> Format.fprintf fmt "\"%s\"" s | PrintName v -> Format.fprintf fmt "nom(%a)" (Pp.unmark form_var) v | PrintAlias v -> Format.fprintf fmt "alias(%a)" (Pp.unmark form_var) v - | PrintEventName (e, f) -> + | PrintEventName (e, f, _) -> Format.fprintf fmt "nom(%a, %s)" form_expr (Pos.unmark e) (Pos.unmark f) - | PrintEventAlias (e, f) -> + | PrintEventAlias (e, f, _) -> Format.fprintf fmt "alias(%a, %s)" form_expr (Pos.unmark e) (Pos.unmark f) | PrintIndent e -> Format.fprintf fmt "indenter(%a)" @@ -714,7 +719,7 @@ let format_formula_decl form_var fmt = function Format.fprintf fmt "[%a]" (format_expression form_var) (Pos.unmark vi) | None -> ()); Format.fprintf fmt " = %a" (format_expression form_var) (Pos.unmark e) - | EventFieldDecl (idx, f, e) -> + | EventFieldDecl (idx, f, _, e) -> Format.fprintf fmt "champ_evenement(%a,%s) = %a" (format_expression form_var) (Pos.unmark idx) (Pos.unmark f) @@ -821,6 +826,19 @@ let rec format_instruction form_var form_err = (Pp.list_space format_var_param) var_params; Format.fprintf fmt "@[ %a@]@\n)@\n" form_instrs rb + | ArrangeEvents (s, f, itb) -> + Format.fprintf fmt "arrange_evenements@;:"; + (match s with + | Some (v0, v1, e) -> + Format.fprintf fmt "trier %a,%a : avec %a@;" form_var + (Pos.unmark v0) form_var (Pos.unmark v1) form_expr (Pos.unmark e) + | None -> ()); + (match f with + | Some (v, e) -> + Format.fprintf fmt "filter %a : avec %a@;" form_var (Pos.unmark v) + form_expr (Pos.unmark e) + | None -> ()); + Format.fprintf fmt ": dans (@[ %a@]@\n)@\n" form_instrs itb | RaiseError (err, var_opt) -> Format.fprintf fmt "leve_erreur %a %s\n" form_err (Pos.unmark err) (match var_opt with Some var -> " " ^ Pos.unmark var | None -> "") diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 633d6515c..044720238 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -152,7 +152,7 @@ end type event_field = { name : string Pos.marked; index : int; is_var : bool } -type 'v event_value = Numeric of float option | RefVar of 'v +type ('n, 'v) event_value = Numeric of 'n | RefVar of 'v module DomainId : StrSet.T @@ -271,7 +271,7 @@ type 'v expression = | NbDiscordances | NbInformatives | NbBloquantes - | EventField of 'v m_expression * string Pos.marked + | EventField of 'v m_expression * string Pos.marked * int and 'v m_expression = 'v expression Pos.marked @@ -301,8 +301,8 @@ type 'v print_arg = | PrintString of string | PrintName of 'v Pos.marked | PrintAlias of 'v Pos.marked - | PrintEventName of 'v m_expression * string Pos.marked - | PrintEventAlias of 'v m_expression * string Pos.marked + | PrintEventName of 'v m_expression * string Pos.marked * int + | PrintEventAlias of 'v m_expression * string Pos.marked * int | PrintIndent of 'v m_expression | PrintExpr of 'v m_expression * int * int @@ -314,7 +314,8 @@ type 'v formula_loop = 'v loop_variables Pos.marked type 'v formula_decl = | VarDecl of 'v Pos.marked * 'v m_expression option * 'v m_expression - | EventFieldDecl of 'v m_expression * string Pos.marked * 'v m_expression + | EventFieldDecl of + 'v m_expression * string Pos.marked * int * 'v m_expression type 'v formula = | SingleFormula of 'v formula_decl @@ -348,6 +349,10 @@ type ('v, 'e) instruction = 'v Pos.marked list * ('v Pos.marked * Pos.t CatVar.Map.t * 'v m_expression) list * ('v, 'e) m_instruction list + | ArrangeEvents of + ('v Pos.marked * 'v Pos.marked * 'v m_expression) option + * ('v Pos.marked * 'v m_expression) option + * ('v, 'e) m_instruction list | RaiseError of 'e Pos.marked * string Pos.marked option | CleanErrors | ExportErrors diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 1a04c7747..677245202 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -215,10 +215,12 @@ let expand_functions (p : program) : program = let m_expr = expand_functions_expr v_expr in ( Affectation (SingleFormula (VarDecl (v_id, m_idx_opt, m_expr)), pos), instr_pos ) - | Affectation (SingleFormula (EventFieldDecl (v_idx, f, v_expr)), pos) -> + | Affectation (SingleFormula (EventFieldDecl (v_idx, f, i, v_expr)), pos) + -> let m_idx = expand_functions_expr v_idx in let m_expr = expand_functions_expr v_expr in - ( Affectation (SingleFormula (EventFieldDecl (m_idx, f, m_expr)), pos), + ( Affectation + (SingleFormula (EventFieldDecl (m_idx, f, i, m_expr)), pos), instr_pos ) | Affectation (MultipleFormulaes _, _) -> assert false | IfThenElse (i, t, e) -> @@ -245,12 +247,12 @@ let expand_functions (p : program) : program = (fun m_arg -> let arg, arg_pos = m_arg in match arg with - | Com.PrintEventName (e, f) -> + | Com.PrintEventName (e, f, i) -> let e' = expand_functions_expr e in - (Com.PrintEventName (e', f), arg_pos) - | Com.PrintEventAlias (e, f) -> + (Com.PrintEventName (e', f, i), arg_pos) + | Com.PrintEventAlias (e, f, i) -> let e' = expand_functions_expr e in - (Com.PrintEventAlias (e', f), arg_pos) + (Com.PrintEventAlias (e', f, i), arg_pos) | Com.PrintIndent e -> let e' = expand_functions_expr e in (Com.PrintIndent e', arg_pos) @@ -292,6 +294,23 @@ let expand_functions (p : program) : program = in let instrs' = List.map map_instr instrs in (Restore (vars, filters', instrs'), instr_pos) + | ArrangeEvents (sort, filter, instrs) -> + let sort' = + match sort with + | Some (var0, var1, expr) -> + let expr' = expand_functions_expr expr in + Some (var0, var1, expr') + | None -> None + in + let filter' = + match filter with + | Some (var, expr) -> + let expr' = expand_functions_expr expr in + Some (var, expr') + | None -> None + in + let instrs' = List.map map_instr instrs in + (ArrangeEvents (sort', filter', instrs'), instr_pos) | RaiseError _ | CleanErrors | ExportErrors | FinalizeErrors -> m_instr | ComputeDomain _ | ComputeChaining _ | ComputeVerifs _ -> assert false in diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 754149aca..31b7d94bc 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -47,7 +47,8 @@ module type S = sig mutable ctx_nb_bloquantes : int; mutable ctx_finalized_anos : (Com.Error.t * string option) list; mutable ctx_exported_anos : (Com.Error.t * string option) list; - mutable ctx_events : Com.Var.t Com.event_value StrMap.t IntMap.t; + mutable ctx_event_tab : (value, Com.Var.t) Com.event_value Array.t Array.t; + mutable ctx_events : int Array.t; } val empty_ctx : Mir.program -> ctx @@ -59,7 +60,10 @@ module type S = sig val update_ctx_with_inputs : ctx -> Com.literal Com.Var.Map.t -> unit val update_ctx_with_events : - ctx -> Mir.program -> Com.Var.t Com.event_value IntMap.t list -> unit + ctx -> + Mir.program -> + (Com.literal, Com.Var.t) Com.event_value IntMap.t list -> + unit type run_error = | NanOrInf of string * Mir.expression Pos.marked @@ -127,7 +131,8 @@ struct mutable ctx_nb_bloquantes : int; mutable ctx_finalized_anos : (Com.Error.t * string option) list; mutable ctx_exported_anos : (Com.Error.t * string option) list; - mutable ctx_events : Com.Var.t Com.event_value StrMap.t IntMap.t; + mutable ctx_event_tab : (value, Com.Var.t) Com.event_value Array.t Array.t; + mutable ctx_events : int Array.t; } let empty_ctx (p : Mir.program) : ctx = @@ -152,7 +157,8 @@ struct ctx_nb_bloquantes = 0; ctx_finalized_anos = []; ctx_exported_anos = []; - ctx_events = IntMap.empty; + ctx_event_tab = [||]; + ctx_events = [||]; } let literal_to_value (l : Com.literal) : value = @@ -181,28 +187,40 @@ struct value_inputs let update_ctx_with_events (ctx : ctx) (p : Mir.program) - (events : Com.Var.t Com.event_value IntMap.t list) : unit = - let ctx_events = - let fold (map, idx) (evt : Com.Var.t Com.event_value IntMap.t) = - let foldEvt id ev map = - match IntMap.find_opt id p.program_event_field_idxs with - | Some fname -> ( - match StrMap.find_opt fname p.program_event_fields with - | Some ef -> ( - match (ev, ef.is_var) with - | Com.Numeric _, false | Com.RefVar _, true -> - StrMap.add fname ev map - | _ -> Errors.raise_error "Wrong event field type") - | None -> Errors.raise_error "Wrong event field") - | None -> - Errors.raise_error - (Format.sprintf "Too much event fields: index %d for size %d" id - (IntMap.cardinal p.program_event_field_idxs)) - in - (IntMap.add idx (IntMap.fold foldEvt evt StrMap.empty) map, idx + 1) + (events : (Com.literal, Com.Var.t) Com.event_value IntMap.t list) : unit = + let nbEvt = List.length events in + let ctx_event_tab = Array.make nbEvt [||] in + let fold idx (evt : (Com.literal, Com.Var.t) Com.event_value IntMap.t) = + let nbEvtFields = IntMap.cardinal evt in + let nbProgFields = IntMap.cardinal p.program_event_field_idxs in + if nbEvtFields > nbProgFields then + Errors.raise_error + (Format.sprintf "Too much event fields: index %d for size %d" + (nbEvtFields - 1) nbProgFields); + let map = Array.make nbEvtFields (Com.Numeric Undefined) in + let iter id ev = + match IntMap.find_opt id p.program_event_field_idxs with + | Some fname -> ( + match StrMap.find_opt fname p.program_event_fields with + | Some ef -> ( + match (ev, ef.is_var) with + | Com.Numeric Com.Undefined, false -> + map.(id) <- Com.Numeric Undefined + | Com.Numeric (Com.Float f), false -> + map.(id) <- Com.Numeric (Number (N.of_float f)) + | Com.RefVar v, true -> map.(id) <- Com.RefVar v + | _ -> Errors.raise_error "Wrong event field type") + | None -> Errors.raise_error "Wrong event field") + | None -> + Errors.raise_error + (Format.sprintf "Too much event fields: index %d for size %d" id + nbProgFields) in - fst (List.fold_left fold (IntMap.empty, 0) events) + IntMap.iter iter evt; + ctx_event_tab.(idx) <- map; + idx + 1 in + ignore (List.fold_left fold 0 events); let max_field_length = StrMap.fold (fun s _ r -> max r (String.length s)) @@ -213,16 +231,20 @@ struct Format.fprintf fmt "%s%s" s (String.make (max_field_length - l + 1) ' ') in let pp_ev fmt = function - | Com.Numeric None -> Pp.string fmt "indefini" - | Com.Numeric (Some f) -> Pp.float fmt f + | Com.Numeric Undefined -> Pp.string fmt "indefini" + | Com.Numeric (Number v) -> N.format_t fmt v | Com.RefVar v -> Pp.string fmt (Com.Var.name_str v) in - IntMap.iter - (fun i m -> - Format.eprintf "%d@." i; - StrMap.iter (fun s v -> Format.eprintf " %a%a@." pp_field s pp_ev v) m) - ctx_events; - ctx.ctx_events <- ctx_events + for i = 0 to Array.length ctx_event_tab - 1 do + Format.eprintf "%d@." i; + let map = ctx_event_tab.(i) in + for j = 0 to Array.length map - 1 do + let s = IntMap.find j p.program_event_field_idxs in + Format.eprintf " %a%a@." pp_field s pp_ev map.(j) + done + done; + ctx.ctx_event_tab <- ctx_event_tab; + ctx.ctx_events <- Array.init nbEvt Fun.id type run_error = | NanOrInf of string * Mir.expression Pos.marked @@ -470,7 +492,7 @@ struct | None -> Undefined | Some f -> Number (N.of_int f))) | FuncCall ((NbEvents, _), _) -> - let card = IntMap.cardinal ctx.ctx_events in + let card = Array.length ctx.ctx_events in Number (N.of_int @@ Int64.of_int @@ card) | FuncCall ((Func fn, _), args) -> let fd = Com.TargetMap.find fn p.program_functions in @@ -488,18 +510,16 @@ struct match StrMap.find_opt (Pos.unmark a) (Com.Var.attrs var) with | Some l -> Number (N.of_float (float (Pos.unmark l))) | None -> Undefined) - | EventField (e, f) -> ( + | EventField (e, _, j) -> ( let new_e = evaluate_expr ctx p e in match new_e with - | Number z when N.(z >=. zero ()) -> ( + | Number z when N.(z >=. zero ()) -> let i = Int64.to_int N.(to_int z) in - match IntMap.find_opt i ctx.ctx_events with - | Some m -> ( - match StrMap.find (Pos.unmark f) m with - | Com.Numeric (Some v) -> Number N.(of_float v) - | Com.Numeric None -> Undefined - | Com.RefVar var -> get_var_value ctx var 0) - | None -> Undefined) + if 0 <= i && i < Array.length ctx.ctx_events then + match ctx.ctx_event_tab.(ctx.ctx_events.(i)).(j) with + | Com.Numeric v -> v + | Com.RefVar var -> get_var_value ctx var 0 + else Undefined | _ -> Undefined) | Size var -> ( let var, _ = get_var ctx (Pos.unmark var) in @@ -592,19 +612,20 @@ struct match vidx_opt with | None -> set_var_value p ctx vari vexpr | Some ei -> set_var_value_tab p ctx vari ei vexpr) - | EventFieldDecl (idx, f, expr) -> ( + | EventFieldDecl (idx, _, j, expr) -> ( let new_idx = evaluate_expr ctx p idx in match new_idx with | Number z when N.(z >=. zero ()) -> ( let i = Int64.to_int N.(to_int z) in - match IntMap.find_opt i ctx.ctx_events with - | Some m -> ( - match StrMap.find (Pos.unmark f) m with - | Com.RefVar var -> - let vari = get_var ctx var in - set_var_value p ctx vari expr - | Com.Numeric _ -> assert false) - | None -> ()) + if 0 <= i && i < Array.length ctx.ctx_events then + match ctx.ctx_event_tab.(ctx.ctx_events.(i)).(j) with + | Com.RefVar var -> + let vari = get_var ctx var in + set_var_value p ctx vari expr + | Com.Numeric _ -> + let value = evaluate_expr ctx p expr in + ctx.ctx_event_tab.(ctx.ctx_events.(i)).(j) <- + Com.Numeric value) | _ -> ())) | Com.Affectation (Com.MultipleFormulaes _, _) -> assert false | Com.IfThenElse (b, t, f) -> ( @@ -677,29 +698,23 @@ struct | PrintAlias (var, _) -> let var, _ = get_var ctx var in pr_raw ctx_pr (Com.Var.alias_str var) - | PrintEventName (e, f) -> ( + | PrintEventName (e, _, j) -> ( match evaluate_expr ctx p e with | Number x -> ( let i = Int64.to_int (N.to_int x) in - match IntMap.find_opt i ctx.ctx_events with - | Some m -> ( - match StrMap.find_opt (Pos.unmark f) m with - | Some (Com.RefVar var) -> - pr_raw ctx_pr (Com.Var.name_str var) - | _ -> ()) - | None -> ()) + if 0 <= i && i < Array.length ctx.ctx_events then + match ctx.ctx_event_tab.(ctx.ctx_events.(i)).(j) with + | Com.RefVar var -> pr_raw ctx_pr (Com.Var.name_str var) + | _ -> ()) | Undefined -> ()) - | PrintEventAlias (e, f) -> ( + | PrintEventAlias (e, _, j) -> ( match evaluate_expr ctx p e with | Number x -> ( let i = Int64.to_int (N.to_int x) in - match IntMap.find_opt i ctx.ctx_events with - | Some m -> ( - match StrMap.find_opt (Pos.unmark f) m with - | Some (Com.RefVar var) -> - pr_raw ctx_pr (Com.Var.alias_str var) - | _ -> ()) - | None -> ()) + if 0 <= i && i < Array.length ctx.ctx_events then + match ctx.ctx_event_tab.(ctx.ctx_events.(i)).(j) with + | Com.RefVar var -> pr_raw ctx_pr (Com.Var.alias_str var) + | _ -> ()) | Undefined -> ()) | PrintIndent e -> let diff = @@ -1003,8 +1018,9 @@ let prepare_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : unit = | _ -> () let evaluate_program (p : Mir.program) (inputs : Com.literal Com.Var.Map.t) - (events : Com.Var.t Com.event_value IntMap.t list) (sort : Cli.value_sort) - (roundops : Cli.round_ops) : float option StrMap.t * StrSet.t = + (events : (Com.literal, Com.Var.t) Com.event_value IntMap.t list) + (sort : Cli.value_sort) (roundops : Cli.round_ops) : + float option StrMap.t * StrSet.t = prepare_interp sort roundops; let module Interp = (val get_interp sort roundops : S) in let ctx = Interp.empty_ctx p in diff --git a/src/mlang/m_ir/mir_interpreter.mli b/src/mlang/m_ir/mir_interpreter.mli index 078f18767..1a968b859 100644 --- a/src/mlang/m_ir/mir_interpreter.mli +++ b/src/mlang/m_ir/mir_interpreter.mli @@ -68,7 +68,8 @@ module type S = sig mutable ctx_nb_bloquantes : int; mutable ctx_finalized_anos : (Com.Error.t * string option) list; mutable ctx_exported_anos : (Com.Error.t * string option) list; - mutable ctx_events : Com.Var.t Com.event_value StrMap.t IntMap.t; + mutable ctx_event_tab : (value, Com.Var.t) Com.event_value Array.t Array.t; + mutable ctx_events : int Array.t; } (** Interpretation context *) @@ -81,7 +82,10 @@ module type S = sig val update_ctx_with_inputs : ctx -> Com.literal Com.Var.Map.t -> unit val update_ctx_with_events : - ctx -> Mir.program -> Com.Var.t Com.event_value IntMap.t list -> unit + ctx -> + Mir.program -> + (Com.literal, Com.Var.t) Com.event_value IntMap.t list -> + unit (** Interpreter runtime errors *) type run_error = @@ -160,7 +164,7 @@ val get_interp : Cli.value_sort -> Cli.round_ops -> (module S) val evaluate_program : Mir.program -> Com.literal Com.Var.Map.t -> - Com.Var.t Com.event_value IntMap.t list -> + (Com.literal, Com.Var.t) Com.event_value IntMap.t list -> Cli.value_sort -> Cli.round_ops -> float option StrMap.t * StrSet.t diff --git a/src/mlang/test_framework/test_interpreter.ml b/src/mlang/test_framework/test_interpreter.ml index e084ece05..5bca96d04 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -21,7 +21,9 @@ let find_var_of_name (p : Mir.program) (name : string Pos.marked) : Com.Var.t = let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : (Com.literal Com.Var.Map.t * float StrMap.t * StrSet.t) - * (Com.Var.t Com.event_value IntMap.t list * float StrMap.t * StrSet.t) + * ((Com.literal, Com.Var.t) Com.event_value IntMap.t list + * float StrMap.t + * StrSet.t) option = let inputVars = let ancsded = find_var_of_name program ("V_ANCSDED", Pos.no_pos) in @@ -31,7 +33,7 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : let var = find_var_of_name program (var, var_pos) in let lit = match value with - | Irj_ast.I i -> Com.Float (float_of_int i) + | Irj_ast.I i -> Com.Float (float i) | F f -> Com.Float f in Com.Var.Map.add var lit in_f) @@ -52,26 +54,30 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) in let fromDirection = function - | "R" -> Some 0.0 - | "C" -> Some 1.0 - | "M" -> Some 2.0 - | "P" -> Some 3.0 + | "R" -> Com.Float 0.0 + | "C" -> Com.Float 1.0 + | "M" -> Com.Float 2.0 + | "P" -> Com.Float 3.0 | s -> Cli.error_print "Sens du rappel: %s, devrait être parmi R, C, M et P" s; raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) in let fromPenalty = function - | None -> Some 0.0 (* None *) - | Some p when 0 <= p && p <= 99 -> Some (float p) + | None -> Com.Float 0.0 (* None *) + | Some p when 0 <= p && p <= 99 -> Com.Float (float p) | Some p -> Cli.error_print "Code de pénalité: %d, devrait être entre 0 et 99" p; raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) in + let fromBaseTl = function + | Some f -> Com.Float (float f) + | None -> Com.Undefined + in let from_2042_rect = function - | None -> Some 0.0 (* None *) - | Some 0 -> Some 0.0 - | Some 1 -> Some 1.0 + | None -> Com.Float 0.0 (* None *) + | Some 0 -> Com.Float 0.0 + | Some 1 -> Com.Float 1.0 | Some r -> Cli.error_print "Indicateur de déclaration rectificative: %d, devrait être 0 ou 1" r; @@ -79,15 +85,14 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : in let toEvent (rappel : Irj_ast.rappel) = IntMap.empty - |> IntMap.add 0 (Com.Numeric (Some (float rappel.event_nb))) - |> IntMap.add 1 (Com.Numeric (Some (float rappel.rappel_nb))) + |> IntMap.add 0 (Com.Numeric (Com.Float (float rappel.event_nb))) + |> IntMap.add 1 (Com.Numeric (Com.Float (float rappel.rappel_nb))) |> IntMap.add 2 (Com.RefVar (from_var rappel.variable_code)) - |> IntMap.add 3 (Com.Numeric (Some (float rappel.change_value))) + |> IntMap.add 3 (Com.Numeric (Com.Float (float rappel.change_value))) |> IntMap.add 4 (Com.Numeric (fromDirection rappel.direction)) |> IntMap.add 5 (Com.Numeric (fromPenalty rappel.penalty_code)) - |> IntMap.add 6 - (Com.Numeric (Option.map float rappel.base_tolerance_legale)) - |> IntMap.add 7 (Com.Numeric (Some (float rappel.month_year))) + |> IntMap.add 6 (Com.Numeric (fromBaseTl rappel.base_tolerance_legale)) + |> IntMap.add 7 (Com.Numeric (Com.Float (float rappel.month_year))) |> IntMap.add 8 (Com.Numeric (from_2042_rect rappel.decl_2042_rect)) in List.map toEvent rappels From ad82995e8d02aa1b1bd05e2e2f47d042e1beb3bf Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Fri, 24 Jan 2025 19:36:40 +0100 Subject: [PATCH 14/32] =?UTF-8?q?Arrangement=20des=20=C3=A9v=C3=A9nements,?= =?UTF-8?q?=20suite.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2023/cibles.m | 2 +- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 51 ++++++++++++++++--- 2 files changed, 46 insertions(+), 7 deletions(-) diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index a5595d702..ae089ea74 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -879,7 +879,7 @@ si nb_evenements() > 0 alors champ_evenement(I, rappel) = champ_evenement(J, rappel) et champ_evenement(I, montant) <= champ_evenement(J, montant) ) -: filtrer I : avec 32 <= champ_evenement(I, rappel) et champ_evenement(I, rappel) <= 55 +#{: filtrer I : avec 32 <= champ_evenement(I, rappel) et champ_evenement(I, rappel) <= 55}# : dans ( calculer cible afficher_evenements; ) diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index a0aee3119..1a4f66b45 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -841,14 +841,53 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@]@;}"; pr "@;irdata->events = %s;" events_tmp; pr "@;irdata->nb_events = %s;" cpt_i + | None -> + pr "@;@[while(%s < %s) {" cpt_j nb_events_sav; + pr "@;%s[%s] = irdata->events[%s];" events_tmp cpt_j cpt_j; + pr "@;%s++;" cpt_j; + pr "@]@;}"; + pr "@;irdata->events = %s;" events_tmp); + (match sort with + | Some (m_var0, m_var1, expr) -> + ( (* +void mergeSort(int *a, int n) { + int *b = (int * )malloc(n * (sizeof (int))); + for (int width = 1; width < n; width = 2 * width) { + for (int iLeft = 0; iLeft < n; iLeft = iLeft + 2 * width) { + int iRight = iLeft + width; + int iEnd = iLeft + 2 * width; + if (iRight > n) iRight = n; + if (iEnd > n) iEnd = n; + { + int i = iLeft; + int j = iRight; + for (int k = iLeft; k < iEnd; k++) { + int cpt = 0; + { + cpt = a[i] <= a[j]; + } + if (i < iRight && (j >= iEnd || cpt)) { + b[k] = a[i]; + i = i + 1; + } else { + b[k] = a[j]; + j = j + 1; + } + } + } + } + for (int i = 0; i < n; i++) { + a[i] = b[i]; + } + } + free(b); +} +*) ) | None -> ()); pr "@;%a" (generate_stmts dgfip_flags program) stmts; - (match filter with - | Some _ -> - pr "@;free(irdata->events);"; - pr "@;irdata->events = %s;" events_sav; - pr "@;irdata->nb_events = %s;" nb_events_sav - | None -> ()); + pr "@;free(irdata->events);"; + pr "@;irdata->events = %s;" events_sav; + pr "@;irdata->nb_events = %s;" nb_events_sav; pr "@]@;}@;" | Restore (vars, var_params, stmts) -> let pr fmt = Format.fprintf oc fmt in From 14cbd60b73916dfbae834b323772b6fd5bd710e6 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 28 Jan 2025 10:32:25 +0100 Subject: [PATCH 15/32] =?UTF-8?q?Arrange=20=C3=A9v=C3=A9nements?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2023/cibles.m | 2 +- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 108 ++++++++++++------ src/mlang/m_ir/mir_interpreter.ml | 33 +----- src/mlang/utils/sorting.ml | 27 +++++ src/mlang/utils/sorting.mli | 1 + 5 files changed, 103 insertions(+), 68 deletions(-) create mode 100644 src/mlang/utils/sorting.ml create mode 100644 src/mlang/utils/sorting.mli diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index ae089ea74..a5595d702 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -879,7 +879,7 @@ si nb_evenements() > 0 alors champ_evenement(I, rappel) = champ_evenement(J, rappel) et champ_evenement(I, montant) <= champ_evenement(J, montant) ) -#{: filtrer I : avec 32 <= champ_evenement(I, rappel) et champ_evenement(I, rappel) <= 55}# +: filtrer I : avec 32 <= champ_evenement(I, rappel) et champ_evenement(I, rappel) <= 55 : dans ( calculer cible afficher_evenements; ) diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index 1a4f66b45..0672365d9 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -833,7 +833,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) def (D.format_assign dgfip_flags cond_val) value; - pr "@;@[if(%s && %s) {" cond_def cond_val; + pr "@;@[if(%s && (%s != 0.0)) {" cond_def cond_val; pr "@;%s[%s] = irdata->events[%s];" events_tmp cpt_i cpt_j; pr "@;%s++;" cpt_i; pr "@]@;}"; @@ -849,40 +849,78 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;irdata->events = %s;" events_tmp); (match sort with | Some (m_var0, m_var1, expr) -> - ( (* -void mergeSort(int *a, int n) { - int *b = (int * )malloc(n * (sizeof (int))); - for (int width = 1; width < n; width = 2 * width) { - for (int iLeft = 0; iLeft < n; iLeft = iLeft + 2 * width) { - int iRight = iLeft + width; - int iEnd = iLeft + 2 * width; - if (iRight > n) iRight = n; - if (iEnd > n) iEnd = n; - { - int i = iLeft; - int j = iRight; - for (int k = iLeft; k < iEnd; k++) { - int cpt = 0; - { - cpt = a[i] <= a[j]; - } - if (i < iRight && (j >= iEnd || cpt)) { - b[k] = a[i]; - i = i + 1; - } else { - b[k] = a[j]; - j = j + 1; - } - } - } - } - for (int i = 0; i < n; i++) { - a[i] = b[i]; - } - } - free(b); -} -*) ) + pr "@;/* merge sort */"; + pr "@;@[{"; + pr + "@;\ + T_event **b = (T_event **)malloc(irdata->nb_events * (sizeof \ + (T_event *)));"; + pr "@;int width;"; + pr "@;int iLeft;"; + pr "@;int i;"; + pr + "@;\ + @[for (width = 1; width < irdata->nb_events; width = 2 * \ + width) {"; + pr + "@;\ + @[for (iLeft = 0; iLeft < irdata->nb_events; iLeft = iLeft + \ + 2 * width) {"; + pr "@;int iRight = iLeft + width;"; + pr "@;int iEnd = iLeft + 2 * width;"; + pr "@;if (iRight > irdata->nb_events) iRight = irdata->nb_events;"; + pr "@;if (iEnd > irdata->nb_events) iEnd = irdata->nb_events;"; + pr "@;@[{"; + pr "@;int i = iLeft;"; + pr "@;int j = iRight;"; + pr "@;int k;"; + pr "@;@[for (k = iLeft; k < iEnd; k++) {"; + pr "@;int cpt = 0;"; + pr "@;@[{"; + (* Comparaison *) + let var0 = Pos.unmark m_var0 in + let ref0_def = VID.gen_def var0 "" in + let ref0_val = VID.gen_val var0 "" in + let var1 = Pos.unmark m_var1 in + let ref1_def = VID.gen_def var1 "" in + let ref1_val = VID.gen_val var1 "" in + let cmp_def = fresh_c_local "cmp_def" in + let cmp_val = fresh_c_local "cmp_val" in + let locals, set, def, value = + D.build_expression @@ generate_c_expr expr + in + pr "@;char %s;" cmp_def; + pr "@;double %s;" cmp_val; + pr "@;%s = 1;" ref0_def; + pr "@;%s = (double)i;" ref0_val; + pr "@;%s = 1;" ref1_def; + pr "@;%s = (double)j;" ref1_val; + pr "@;@[{@;%a%a%a@;%a@]@;}" D.format_local_declarations locals + (D.format_set_vars dgfip_flags) + set + (D.format_assign dgfip_flags cmp_def) + def + (D.format_assign dgfip_flags cmp_val) + value; + pr "@;cpt = %s && (%s != 0.0);" cmp_def cmp_val; + (* ----------- *) + pr "@]@;}"; + pr "@;@[if (i < iRight && (j >= iEnd || cpt)) {"; + pr "@;b[k] = irdata->events[i];"; + pr "@;i = i + 1;"; + pr "@]@;@;@[} else {"; + pr "@;b[k] = irdata->events[j];"; + pr "@;j = j + 1;"; + pr "@]@;}"; + pr "@]@;}"; + pr "@]@;}"; + pr "@]@;}"; + pr "@;@[for (i = 0; i < irdata->nb_events; i++) {"; + pr "@;irdata->events[i] = b[i];"; + pr "@]@;}"; + pr "@]@;}"; + pr "@;free(b);"; + pr "@]@;}" | None -> ()); pr "@;%a" (generate_stmts dgfip_flags program) stmts; pr "@;free(irdata->events);"; diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 84ca67550..3f21b24fd 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -893,38 +893,7 @@ struct | Number _ -> true | Undefined -> false in - let mergeSort cmp a = - let merge cmp a iLeft iRight iEnd b = - let rec aux i j k = - if k < iEnd then - if i < iRight && (j >= iEnd || cmp a.(i) a.(j)) then ( - b.(k) <- a.(i); - aux (i + 1) j (k + 1)) - else ( - b.(k) <- a.(j); - aux i (j + 1) (k + 1)) - in - aux iLeft iRight iLeft - in - let b = Array.copy a in - let n = Array.length a in - let rec aux a b cp width = - if width < n then ( - let rec aux' i = - if i < n then ( - merge cmp a i - (min (i + width) n) - (min (i + (2 * width)) n) - b; - aux' (i + (2 * width))) - in - aux' 0; - aux b a (not cp) (2 * width)) - else if cp then Array.blit a 0 b 0 n - in - aux a b false 1 - in - mergeSort sort_fun events + Sort.mergeSort sort_fun events | None -> ()); ctx.ctx_events <- events :: ctx.ctx_events; evaluate_stmts tn canBlock p ctx stmts; diff --git a/src/mlang/utils/sorting.ml b/src/mlang/utils/sorting.ml new file mode 100644 index 000000000..80d0b12fd --- /dev/null +++ b/src/mlang/utils/sorting.ml @@ -0,0 +1,27 @@ +let mergeSort cmp a = + let merge cmp a iLeft iRight iEnd b = + let rec aux i j k = + if k < iEnd then + if i < iRight && (j >= iEnd || cmp a.(i) a.(j)) then ( + b.(k) <- a.(i); + aux (i + 1) j (k + 1)) + else ( + b.(k) <- a.(j); + aux i (j + 1) (k + 1)) + in + aux iLeft iRight iLeft + in + let b = Array.copy a in + let n = Array.length a in + let rec aux a b cp width = + if width < n then ( + let rec aux' i = + if i < n then ( + merge cmp a i (min (i + width) n) (min (i + (2 * width)) n) b; + aux' (i + (2 * width))) + in + aux' 0; + aux b a (not cp) (2 * width)) + else if cp then Array.blit a 0 b 0 n + in + aux a b false 1 diff --git a/src/mlang/utils/sorting.mli b/src/mlang/utils/sorting.mli new file mode 100644 index 000000000..314acce9f --- /dev/null +++ b/src/mlang/utils/sorting.mli @@ -0,0 +1 @@ +val mergeSort : ('a -> 'a -> bool) -> 'a Array.t -> unit From 443b0b9982b17409a1357c5231f4f88247f31729 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 28 Jan 2025 10:36:22 +0100 Subject: [PATCH 16/32] =?UTF-8?q?Arrange=20=C3=A9v=C3=A9nements=20(correct?= =?UTF-8?q?ion)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/m_ir/mir_interpreter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 3f21b24fd..7139b1948 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -893,7 +893,7 @@ struct | Number _ -> true | Undefined -> false in - Sort.mergeSort sort_fun events + Sorting.mergeSort sort_fun events | None -> ()); ctx.ctx_events <- events :: ctx.ctx_events; evaluate_stmts tn canBlock p ctx stmts; From 4521c452c16ebce6926b3f82f4d0f6a4076581e3 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 28 Jan 2025 16:23:44 +0100 Subject: [PATCH 17/32] =?UTF-8?q?Restauration=20des=20=C3=A9v=C3=A9nements?= =?UTF-8?q?=20(listes).?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2021/cibles.m | 3 +- m_ext/2023/cibles.m | 75 +- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 647 +++++++----------- .../backend_compilers/dgfip_gen_files.ml | 43 +- src/mlang/m_frontend/check_validity.ml | 35 +- src/mlang/m_frontend/expand_macros.ml | 12 +- src/mlang/m_frontend/mast_to_mir.ml | 7 +- src/mlang/m_frontend/mlexer.mll | 2 + src/mlang/m_frontend/mparser.mly | 29 +- src/mlang/m_ir/com.ml | 32 +- src/mlang/m_ir/com.mli | 1 + src/mlang/m_ir/mir.ml | 9 +- src/mlang/m_ir/mir_interpreter.ml | 58 +- 13 files changed, 482 insertions(+), 471 deletions(-) diff --git a/m_ext/2021/cibles.m b/m_ext/2021/cibles.m index 33c4d7788..3caf386b0 100644 --- a/m_ext/2021/cibles.m +++ b/m_ext/2021/cibles.m @@ -648,8 +648,7 @@ si present(IAD11) alors ) afficher_erreur "\n"; restaurer -: FLAG_PVRO -: TOTO +: variables FLAG_PVRO, TOTO : variable RESTREV : categorie saisie contexte : avec present(RESTREV) : apres ( FLAG_PVRO = indefini; diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index a5595d702..b45c76d80 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -815,44 +815,49 @@ si nb_discordances() + nb_informatives() > 0 alors TOTO = truc(TOTO, truc(4, truc(7, 9))); afficher_erreur "truc: " (TOTO) "\n"; +cible afficher_evenement: +application: iliad; +arguments: I; +afficher_erreur (I) ": "; +si (present(champ_evenement(I, numero))) alors afficher_erreur (champ_evenement(I, numero)); finsi +afficher_erreur "/"; +si (present(champ_evenement(I, rappel))) alors afficher_erreur (champ_evenement(I, rappel)); finsi +afficher_erreur "/" alias(I, code) "," nom(I, code) "/"; +si (present(champ_evenement(I, montant))) alors afficher_erreur (champ_evenement(I, montant)); finsi +afficher_erreur "/"; +si (present(champ_evenement(I, sens))) alors + si (champ_evenement(I, sens) = 0) alors + afficher_erreur "R"; + sinon_si (champ_evenement(I, sens) = 1) alors + afficher_erreur "C"; + sinon_si (champ_evenement(I, sens) = 2) alors + afficher_erreur "M"; + sinon_si (champ_evenement(I, sens) = 3) alors + afficher_erreur "P"; + finsi +finsi +afficher_erreur "/"; +si (present(champ_evenement(I, penalite))) alors afficher_erreur (champ_evenement(I, penalite)); finsi +afficher_erreur "/"; +si (present(champ_evenement(I, base_tl))) alors afficher_erreur (champ_evenement(I, base_tl)); finsi +afficher_erreur "/"; +si (present(champ_evenement(I, date))) alors afficher_erreur (champ_evenement(I, date)); finsi +afficher_erreur "/"; +si (present(champ_evenement(I, 2042_rect))) alors afficher_erreur (champ_evenement(I, 2042_rect)); finsi + cible afficher_evenements: application: iliad; iterer : variable I : 0 .. (nb_evenements() - 1) increment 1 : dans ( - afficher_erreur (I) ": "; - si (present(champ_evenement(I, numero))) alors afficher_erreur (champ_evenement(I, numero)); finsi - afficher_erreur "/"; - si (present(champ_evenement(I, rappel))) alors afficher_erreur (champ_evenement(I, rappel)); finsi - afficher_erreur "/" alias(I, code) "," nom(I, code) "/"; - si (present(champ_evenement(I, montant))) alors afficher_erreur (champ_evenement(I, montant)); finsi - afficher_erreur "/"; - si (present(champ_evenement(I, sens))) alors - si (champ_evenement(I, sens) = 0) alors - afficher_erreur "R"; - sinon_si (champ_evenement(I, sens) = 1) alors - afficher_erreur "C"; - sinon_si (champ_evenement(I, sens) = 2) alors - afficher_erreur "M"; - sinon_si (champ_evenement(I, sens) = 3) alors - afficher_erreur "P"; - finsi - finsi - afficher_erreur "/"; - si (present(champ_evenement(I, penalite))) alors afficher_erreur (champ_evenement(I, penalite)); finsi - afficher_erreur "/"; - si (present(champ_evenement(I, base_tl))) alors afficher_erreur (champ_evenement(I, base_tl)); finsi - afficher_erreur "/"; - si (present(champ_evenement(I, date))) alors afficher_erreur (champ_evenement(I, date)); finsi - afficher_erreur "/"; - si (present(champ_evenement(I, 2042_rect))) alors afficher_erreur (champ_evenement(I, 2042_rect)); finsi + calculer cible afficher_evenement : avec I; afficher_erreur "\n"; ) cible test: application: iliad; -variables_temporaires: A0, A1; +variables_temporaires: A0, A1, EVT; A0 = 1.6; A1 = 3.6; calculer cible test_boucle : avec A0, A1; @@ -883,6 +888,22 @@ et champ_evenement(I, montant) <= champ_evenement(J, montant) : dans ( calculer cible afficher_evenements; ) +afficher_erreur "\n"; +EVT = 26; +afficher_erreur "0: "; +calculer cible afficher_evenement : avec EVT; +afficher_erreur "\n"; +restaurer +: evenements EVT +: apres ( + champ_evenement(EVT, montant) = 111111.111111; + afficher_erreur "1: "; + calculer cible afficher_evenement : avec EVT; + afficher_erreur "\n"; +) +afficher_erreur "2: "; +calculer cible afficher_evenement : avec EVT; +afficher_erreur "\n"; cible enchainement_primitif: application: iliad; diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index 0672365d9..7ba571e78 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -397,299 +397,221 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : D.build_transitive_composition { set_vars = []; def_test; value_comp } | NbCategory _ | FuncCallLoop _ | Loop _ -> assert false -let generate_m_assign (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t) - (offset : D.offset) (oc : Format.formatter) (se : D.expression_composition) - : unit = +let generate_expr_with_res_in dgfip_flags oc res_def res_val expr = let pr form = Format.fprintf oc form in - let def_var = D.generate_variable ~def_flag:true offset var in - let val_var = D.generate_variable offset var in - let locals, set, def, value = D.build_expression se in + let locals, set, def, value = D.build_expression @@ generate_c_expr expr in if D.is_always_true def then - pr "%a%a%a@;@[{@;%a@]@;}" D.format_local_declarations locals + pr "@;@[{@;%a@;%a@;%a@;%a@]@;}" D.format_local_declarations locals (D.format_set_vars dgfip_flags) set - (D.format_assign dgfip_flags def_var) + (D.format_assign dgfip_flags res_def) def - (D.format_assign dgfip_flags val_var) + (D.format_assign dgfip_flags res_val) value else - pr "%a%a%a@,@[if(%s){@;%a@]@,}@,else %s = 0.;" + pr "@;@[{@;%a@;%a@;%a@;@[if (%s) {%a@]@;} else %s = 0.0;@]@;}" D.format_local_declarations locals (D.format_set_vars dgfip_flags) set - (D.format_assign dgfip_flags def_var) - def def_var - (D.format_assign dgfip_flags val_var) - value val_var; + (D.format_assign dgfip_flags res_def) + def res_def + (D.format_assign dgfip_flags res_val) + value res_val + +let generate_m_assign (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t) + (offset : D.offset) (oc : Format.formatter) + (expr : Mir.expression Pos.marked) : unit = + let var_def = D.generate_variable ~def_flag:true offset var in + let var_val = D.generate_variable offset var in + generate_expr_with_res_in dgfip_flags oc var_def var_val expr; (* If the trace flag is set, we print the value of all non-temp variables *) if dgfip_flags.flg_trace && not (Com.Var.is_temp var) then - pr "@;aff2(\"%s\", irdata, %s);" + Format.fprintf oc "@;aff2(\"%s\", irdata, %s);" (Pos.unmark var.Com.Var.name) (VID.gen_pos_from_start var) let generate_var_def (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t) (vidx_opt : Mir.expression Pos.marked option) - (vexpr : Mir.expression Pos.marked) (fmt : Format.formatter) : unit = - let pr form = Format.fprintf fmt form in + (vexpr : Mir.expression Pos.marked) (oc : Format.formatter) : unit = + let pr form = Format.fprintf oc form in + let size = VID.gen_size var in match vidx_opt with | None -> - let se = generate_c_expr vexpr in if Com.Var.is_ref var then ( - pr "@[{@;"; - let idx = fresh_c_local "idxPROUT" in + pr "@;@[{"; + let idx = fresh_c_local "idx" in pr "@;int %s;" idx; - pr "@;@[for(%s = 0; %s < %s; %s++) {" idx idx (VID.gen_size var) - idx; - pr "@;%a" (generate_m_assign dgfip_flags var (GetValueExpr idx)) se; + pr "@;@[for (%s = 0; %s < %s; %s++) {" idx idx size idx; + pr "%a" (generate_m_assign dgfip_flags var (GetValueExpr idx)) vexpr; pr "@]@;}"; - pr "@]@;}@;") - else generate_m_assign dgfip_flags var None fmt se + pr "@]@;}") + else generate_m_assign dgfip_flags var None oc vexpr | Some ei -> - pr "@[{@;"; - let idx_val = fresh_c_local "mpp_idx" in - let idx_def = idx_val ^ "_d" in - let locals_idx, set_idx, def_idx, value_idx = - D.build_expression @@ generate_c_expr ei - in - pr "char %s;@;long %s;@;%a%a%a@;%a@;" idx_def idx_val - D.format_local_declarations locals_idx - (D.format_set_vars dgfip_flags) - set_idx - (D.format_assign dgfip_flags idx_def) - def_idx - (D.format_assign dgfip_flags idx_val) - value_idx; - let size = VID.gen_size var in - pr "@[if(%s && 0 <= %s && %s < %s){@;%a@]@;}" idx_def idx_val idx_val - size - (generate_m_assign dgfip_flags var (GetValueExpr idx_val)) - (generate_c_expr vexpr); - pr "@]@;}@;" + pr "@;@[{"; + let idx = fresh_c_local "idx" in + let idx_def = idx ^ "_def" in + let idx_val = idx ^ "_val" in + pr "@;char %s;@;double %s;@;int %s;" idx_def idx_val idx; + generate_expr_with_res_in dgfip_flags oc idx_def idx_val ei; + pr "@;%s = (int)%s;" idx idx_val; + pr "@;@[if (%s && 0 <= %s && %s < %s) {" idx_def idx idx size; + pr "%a" (generate_m_assign dgfip_flags var (GetValueExpr idx)) vexpr; + pr "@]@;}"; + pr "@]@;}" let generate_event_field_def (dgfip_flags : Dgfip_options.flags) - (p : Mir.program) (idx : Mir.expression Pos.marked) (field : string) - (expr : Mir.expression Pos.marked) (fmt : Format.formatter) : unit = - let pr form = Format.fprintf fmt form in - pr "@[{@;"; - let idx_val = fresh_c_local "mpp_idx" in - let idx_def = idx_val ^ "_d" in - let locals_idx, set_idx, def_idx, value_idx = - D.build_expression @@ generate_c_expr idx - in - pr "char %s;@;long %s;@;%a%a%a@;%a@;" idx_def idx_val - D.format_local_declarations locals_idx - (D.format_set_vars dgfip_flags) - set_idx - (D.format_assign dgfip_flags idx_def) - def_idx - (D.format_assign dgfip_flags idx_val) - value_idx; - pr "@[if(%s && 0 <= %s && %s < irdata->nb_events){@;" idx_def idx_val - idx_val; - let expr_val = fresh_c_local "mpp_expr" in - let expr_def = expr_val ^ "_d" in - let locals_expr, set_expr, def_expr, value_expr = - D.build_expression @@ generate_c_expr expr - in - pr "@[{@;char %s;@;double %s;@;%a%a%a@;%a@;" expr_def expr_val - D.format_local_declarations locals_expr - (D.format_set_vars dgfip_flags) - set_expr - (D.format_assign dgfip_flags expr_def) - def_expr - (D.format_assign dgfip_flags expr_val) - value_expr; + (p : Mir.program) (idx_expr : Mir.expression Pos.marked) (field : string) + (expr : Mir.expression Pos.marked) (oc : Format.formatter) : unit = + let pr form = Format.fprintf oc form in + pr "@;@[{"; + let idx = fresh_c_local "idx" in + let idx_def = idx ^ "_def" in + let idx_val = idx ^ "_val" in + pr "@;char %s;@;double %s;@;int %s;" idx_def idx_val idx; + generate_expr_with_res_in dgfip_flags oc idx_def idx_val idx_expr; + pr "@;%s = (int)%s;" idx idx_val; + pr "@;@[if (%s && 0 <= %s && %s < irdata->nb_events) {" idx_def idx idx; + let res = fresh_c_local "res" in + let res_def = res ^ "_def" in + let res_val = res ^ "_val" in + pr "@;char %s;@;double %s;" res_def res_val; + generate_expr_with_res_in dgfip_flags oc res_def res_val expr; if (StrMap.find field p.program_event_fields).is_var then - pr "ecris_varinfo(irdata, irdata->events[%s]->field_%s_var, %s, %s);" - idx_val field expr_def expr_val + pr "@;ecris_varinfo(irdata, irdata->events[%s]->field_%s_var, %s, %s);" idx + field res_def res_val else ( - pr "irdata->events[%s]->field_%s_def = %s;@;" idx_val field expr_def; - pr "irdata->events[%s]->field_%s_val = %s;" idx_val field expr_val); - pr "@]@;}@;"; + pr "@;irdata->events[%s]->field_%s_def = %s;" idx field res_def; + pr "@;irdata->events[%s]->field_%s_val = %s;" idx field res_val); pr "@]@;}"; - pr "@]@;}@;" + pr "@]@;}" let rec generate_stmt (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (oc : Format.formatter) (stmt : Mir.m_instruction) = + let pr fmt = Format.fprintf oc fmt in match Pos.unmark stmt with | Affectation (SingleFormula (VarDecl (m_var, vidx_opt, vexpr)), _) -> - Format.fprintf oc "@[{@;"; + pr "@;@[{"; generate_var_def dgfip_flags (Pos.unmark m_var) vidx_opt vexpr oc; - Format.fprintf oc "@]@;}@;" + pr "@]@;}" | Affectation (SingleFormula (EventFieldDecl (idx, f, _, expr)), _) -> - Format.fprintf oc "@[{@;"; + pr "@;@[{"; generate_event_field_def dgfip_flags program idx (Pos.unmark f) expr oc; - Format.fprintf oc "@]@;}@;" + pr "@]@;}" | Affectation (MultipleFormulaes _, _) -> assert false - | IfThenElse (cond, iftrue, iffalse) -> - Format.fprintf oc "@[{@,"; - let cond_val = fresh_c_local "mpp_cond" in - let cond_def = cond_val ^ "_d" in - let locals, set, def, value = - D.build_expression @@ generate_c_expr cond - in - Format.fprintf oc "char %s;@;double %s;@;%a%a%a@;%a@;" cond_def cond_val - D.format_local_declarations locals - (D.format_set_vars dgfip_flags) - set - (D.format_assign dgfip_flags cond_def) - def - (D.format_assign dgfip_flags cond_val) - value; - Format.fprintf oc "@[if(%s && %s) {@,%a@]@,}" cond_def cond_val - (generate_stmts dgfip_flags program) - iftrue; - if iffalse <> [] then - Format.fprintf oc "@[else if(%s){@,%a@]@,}" cond_def - (generate_stmts dgfip_flags program) - iffalse; - Format.fprintf oc "@]@,}@;" + | IfThenElse (cond_expr, iftrue, iffalse) -> + pr "@;@[{"; + let cond = fresh_c_local "cond" in + let cond_def = cond ^ "_def" in + let cond_val = cond ^ "_val" in + pr "@;char %s;@;double %s;" cond_def cond_val; + generate_expr_with_res_in dgfip_flags oc cond_def cond_val cond_expr; + pr "@;@[if (%s && (%s != 0.0)) {" cond_def cond_val; + pr "@;%a" (generate_stmts dgfip_flags program) iftrue; + if iffalse <> [] then ( + pr "@]@;@[} else if (%s) {" cond_def; + pr "@;%a" (generate_stmts dgfip_flags program) iffalse); + pr "@]@;}"; + pr "@]@;}" | WhenDoElse (wdl, ed) -> - let pr fmt_str = Format.fprintf oc fmt_str in let goto_label = fresh_c_local "when_do_block" in let fin_label = fresh_c_local "when_do_end" in - let cond_val = fresh_c_local "when_do_cond" in - let cond_def = cond_val ^ "_d" in - pr "@[{@;"; - pr "char %s;@;" cond_def; - pr "double %s;@;" cond_val; + let cond = fresh_c_local "when_do_cond" in + let cond_def = cond ^ "_def" in + let cond_val = cond ^ "_val" in + pr "@;@[{"; + pr "@;char %s;@;double %s;" cond_def cond_val; let rec aux = function | (expr, dl, _) :: l -> - let locals, set, def, value = - D.build_expression @@ generate_c_expr expr - in - pr "@[{@;"; - pr "%a@;" D.format_local_declarations locals; - pr "%a@;" (D.format_set_vars dgfip_flags) set; - pr "%a@;" (D.format_assign dgfip_flags cond_def) def; - pr "%a@;" (D.format_assign dgfip_flags cond_val) value; - pr "@[if(%s) {@;" cond_def; - pr "if (! %s) goto %s;@;" cond_val goto_label; - pr "%a@]@;" (generate_stmts dgfip_flags program) dl; - pr "}@;"; - pr "@]@;}@;"; + generate_expr_with_res_in dgfip_flags oc cond_def cond_val expr; + pr "@;@[if(%s) {" cond_def; + pr "@;if (! %s) goto %s;" cond_val goto_label; + pr "@;%a" (generate_stmts dgfip_flags program) dl; + pr "@]@;}"; aux l | [] -> () in aux wdl; - pr "goto %s;@;" fin_label; - pr "%s:@;" goto_label; - pr "%a@;" (generate_stmts dgfip_flags program) (Pos.unmark ed); - pr "%s:{}@]@;" fin_label; - pr "}@;" + pr "@;goto %s;" fin_label; + pr "@;%s:" goto_label; + pr "@;%a" (generate_stmts dgfip_flags program) (Pos.unmark ed); + pr "@;%s:{}" fin_label; + pr "@]@;}" | VerifBlock stmts -> let goto_label = fresh_c_local "verif_block" in - let pr fmt = Format.fprintf oc fmt in - pr "@[{@;"; - pr " if (setjmp(irdata->jmp_bloq) != 0) {@;"; - pr " goto %s;@;" goto_label; - pr " }@;"; - pr "%a@;" (generate_stmts dgfip_flags program) stmts; - pr "%s:;@]@;}" goto_label + pr "@;@[{"; + pr "@;if (setjmp(irdata->jmp_bloq) != 0) goto %s;" goto_label; + pr "@;%a" (generate_stmts dgfip_flags program) stmts; + pr "%s:;" goto_label; + pr "@]@;}" | Print (std, args) -> let print_std, pr_ctx = match std with | StdOut -> ("stdout", "&(irdata->ctx_pr_out)") | StdErr -> ("stderr", "&(irdata->ctx_pr_err)") in - let print_val = fresh_c_local "mpp_print" in - let print_def = print_val ^ "_d" in + let print = fresh_c_local "print" in + let print_def = print ^ "_def" in + let print_val = print ^ "_val" in + pr "@;@[{"; + pr "@;char %s;@;double %s;@;int %s;" print_def print_val print; let print_name_or_alias name_or_alias e f = let ef = StrMap.find (Pos.unmark f) program.program_event_fields in if ef.is_var then ( - let locals, set, def, value = - D.build_expression @@ generate_c_expr e - in - Format.fprintf oc "@[{%a%a%a@;%a@;@]}@;" - D.format_local_declarations locals - (D.format_set_vars dgfip_flags) - set - (D.format_assign dgfip_flags print_def) - def - (D.format_assign dgfip_flags print_val) - value; - Format.fprintf oc "@[{@;int idx = (int)floor(%s);@;" print_val; - Format.fprintf oc - "@[if(%s && 0 <= idx && idx < irdata->nb_events){@;" print_def; - Format.fprintf oc - "print_string(%s, %s, irdata->events[idx]->field_%s_var->%s);@]@;" - print_std pr_ctx (Pos.unmark f) name_or_alias; - Format.fprintf oc "}@]@;"; - Format.fprintf oc "}@;") + generate_expr_with_res_in dgfip_flags oc print_def print_val e; + pr "@;%s = (int)%s;" print print_val; + pr "@;@[if (%s && 0 <= %s && %s < irdata->nb_events) {" print_def + print print; + pr "@;print_string(%s, %s, irdata->events[%s]->field_%s_var->%s);" + print_std pr_ctx print (Pos.unmark f) name_or_alias; + pr "@]@;}") in - Format.fprintf oc "@[{@,char %s;@;double %s;@;" print_def print_val; List.iter (fun (arg : Com.Var.t Com.print_arg Pos.marked) -> match Pos.unmark arg with | PrintString s -> - Format.fprintf oc "print_string(%s, %s, \"%s\");@;" print_std - pr_ctx (str_escape s) + pr "@;print_string(%s, %s, \"%s\");" print_std pr_ctx + (str_escape s) | PrintName (var, _) -> let ptr = VID.gen_info_ptr var in - Format.fprintf oc "print_string(%s, %s, %s->name);@;" print_std - pr_ctx ptr + pr "@;print_string(%s, %s, %s->name);" print_std pr_ctx ptr | PrintAlias (var, _) -> let ptr = VID.gen_info_ptr var in - Format.fprintf oc "print_string(%s, %s, %s->alias);@;" print_std - pr_ctx ptr + pr "@;print_string(%s, %s, %s->alias);" print_std pr_ctx ptr | PrintEventName (e, f, _) -> print_name_or_alias "name" e f | PrintEventAlias (e, f, _) -> print_name_or_alias "alias" e f | PrintIndent e -> - let locals, set, def, value = - D.build_expression @@ generate_c_expr e - in - Format.fprintf oc "@[{%a%a%a@;%a@;@]}@;" - D.format_local_declarations locals - (D.format_set_vars dgfip_flags) - set - (D.format_assign dgfip_flags print_def) - def - (D.format_assign dgfip_flags print_val) - value; - Format.fprintf oc "@[if(%s){@;" print_def; - Format.fprintf oc "set_print_indent(%s, %s, %s);@]@;" print_std - pr_ctx print_val; - Format.fprintf oc "}@;" + generate_expr_with_res_in dgfip_flags oc print_def print_val e; + pr "@;@[if (%s) {" print_def; + pr "@;set_print_indent(%s, %s, %s);" print_std pr_ctx print_val; + pr "@]@;}" | PrintExpr (e, min, max) -> - let locals, set, def, value = - D.build_expression @@ generate_c_expr e - in - Format.fprintf oc "@[{%a%a%a@;%a@;@]}@;" - D.format_local_declarations locals - (D.format_set_vars dgfip_flags) - set - (D.format_assign dgfip_flags print_def) - def - (D.format_assign dgfip_flags print_val) - value; - Format.fprintf oc "@[if(%s){@;" print_def; - Format.fprintf oc "print_double(%s, %s, %s, %d, %d);@]@;" - print_std pr_ctx print_val min max; - Format.fprintf oc "@[} else {@;"; - Format.fprintf oc "print_string(%s, %s, \"indefini\");@]@;}@;" - print_std pr_ctx) + generate_expr_with_res_in dgfip_flags oc print_def print_val e; + pr "@;@[if (%s) {" print_def; + pr "@;print_double(%s, %s, %s, %d, %d);" print_std pr_ctx + print_val min max; + pr "@]@;@[} else {"; + pr "@;print_string(%s, %s, \"indefini\");" print_std pr_ctx; + pr "@]@;}") args; - Format.fprintf oc "@]@;}@;" + pr "@]@;}" | ComputeTarget ((tn, _), targs) -> - let pr fmt = Format.fprintf oc fmt in ignore (List.fold_left (fun n ((v : Com.Var.t), _) -> let ref_idx = Format.sprintf "irdata->ref_org + %d" n in let ref_info = Format.sprintf "irdata->info_ref[%s]" ref_idx in let v_info_p = VID.gen_info_ptr v in - pr "%s = %s;@;" ref_info v_info_p; + pr "@;%s = %s;" ref_info v_info_p; let ref_def = Format.sprintf "irdata->def_ref[%s]" ref_idx in let v_def_p = VID.gen_def_ptr v in - pr "%s = %s;@;" ref_def v_def_p; + pr "@;%s = %s;" ref_def v_def_p; let ref_val = Format.sprintf "irdata->ref[%s]" ref_idx in let v_val_p = VID.gen_val_ptr v in - pr "%s = %s;@;" ref_val v_val_p; + pr "@;%s = %s;" ref_val v_val_p; n + 1) 0 targs); - Format.fprintf oc "%s(irdata);" tn + pr "@;%s(irdata);" tn | Iterate (m_var, vars, var_params, stmts) -> - let pr fmt = Format.fprintf oc fmt in let it_name = fresh_c_local "iterate" in let var = Pos.unmark m_var in let ref_info = VID.gen_info_ptr var in @@ -697,15 +619,12 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) let ref_val = VID.gen_val_ptr var in List.iter (fun (v, _) -> - pr "@[{@;"; - let v_info_p = VID.gen_info_ptr v in - pr "%s = %s;@;" ref_info v_info_p; - let v_def_p = VID.gen_def_ptr v in - pr "%s = %s;@;" ref_def v_def_p; - let v_val_p = VID.gen_val_ptr v in - pr "%s = %s;@;" ref_val v_val_p; - pr "%a@;" (generate_stmts dgfip_flags program) stmts; - pr "@]@;}@;") + pr "@;@[{"; + pr "@;%s = %s;" ref_info (VID.gen_info_ptr v); + pr "@;%s = %s;" ref_def (VID.gen_def_ptr v); + pr "@;%s = %s;" ref_val (VID.gen_val_ptr v); + pr "@;%a" (generate_stmts dgfip_flags program) stmts; + pr "@]@;}") vars; List.iter (fun (vcs, expr) -> @@ -713,97 +632,68 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) (fun vc _ -> let vcd = Com.CatVar.Map.find vc program.program_var_categories in let ref_tab = VID.gen_tab vcd.loc in - let cond_val = "cond_" ^ it_name in - let cond_def = cond_val ^ "_d" in - let locals, set, def, value = - D.build_expression @@ generate_c_expr expr - in - pr "@[{@;"; - pr "T_varinfo_%s *tab_%s = varinfo_%s;@;" vcd.id_str it_name + let cond = fresh_c_local "cond" in + let cond_def = cond ^ "_def" in + let cond_val = cond ^ "_val" in + pr "@;@[{"; + pr "@;T_varinfo_%s *tab_%s = varinfo_%s;" vcd.id_str it_name vcd.id_str; - pr "int nb_%s = 0;@;" it_name; - pr "@[while (nb_%s < NB_%s) {@;" it_name vcd.id_str; - pr "char %s;@;" cond_def; - pr "double %s;@;" cond_val; - pr "%s = (T_varinfo *)tab_%s;@;" ref_info it_name; - pr "%s = &(D%s[%s->idx]);@;" ref_def ref_tab ref_info; - pr "%s = &(%s[%s->idx]);@;" ref_val ref_tab ref_info; - pr "@[{@;"; - pr "%a" D.format_local_declarations locals; - pr "%a" (D.format_set_vars dgfip_flags) set; - pr "%a@;" (D.format_assign dgfip_flags cond_def) def; - pr "%a" (D.format_assign dgfip_flags cond_val) value; - pr "@]@;"; - pr "}@;"; - pr "@[if(%s && %s){@;" cond_def cond_val; - pr "%a@]@;" (generate_stmts dgfip_flags program) stmts; - pr "}@;"; - pr "tab_%s++;@;" it_name; - pr "nb_%s++;" it_name; + pr "@;int nb_%s = 0;" it_name; + pr "@;@[while (nb_%s < NB_%s) {" it_name vcd.id_str; + pr "@;char %s;@;double %s;" cond_def cond_val; + pr "@;%s = (T_varinfo *)tab_%s;" ref_info it_name; + pr "@;%s = &(D%s[%s->idx]);" ref_def ref_tab ref_info; + pr "@;%s = &(%s[%s->idx]);" ref_val ref_tab ref_info; + generate_expr_with_res_in dgfip_flags oc cond_def cond_val expr; + pr "@;@[if (%s && %s != 0.0) {" cond_def cond_val; + pr "@;%a" (generate_stmts dgfip_flags program) stmts; pr "@]@;}"; - pr "@]@;}@;") + pr "@;tab_%s++;" it_name; + pr "@;nb_%s++;" it_name; + pr "@]@;}"; + pr "@]@;}") vcs) var_params | Iterate_values (m_var, var_intervals, stmts) -> - let pr fmt = Format.fprintf oc fmt in let var = Pos.unmark m_var in let itval_def = VID.gen_def var "" in let itval_val = VID.gen_val var "" in - let itval_name = fresh_c_local "iterate_values" in - let itval_e0_val = Format.sprintf "%s_e0" itval_name in - let itval_e1_val = Format.sprintf "%s_e1" itval_name in - let itval_step_val = Format.sprintf "%s_step" itval_name in - let itval_e0_def = Format.sprintf "%s_def" itval_e0_val in - let itval_e1_def = Format.sprintf "%s_def" itval_e1_val in - let itval_step_def = Format.sprintf "%s_def" itval_step_val in + let itval_name = fresh_c_local "itval" in + let e0_def = Format.sprintf "%s_e0_def" itval_name in + let e0_val = Format.sprintf "%s_e0_val" itval_name in + let e1_def = Format.sprintf "%s_e1_def" itval_name in + let e1_val = Format.sprintf "%s_e1_val" itval_name in + let step_def = Format.sprintf "%s_step_def" itval_name in + let step_val = Format.sprintf "%s_step_val" itval_name in List.iter (fun (e0, e1, step) -> - let locals_e0, set_e0, def_e0, value_e0 = - D.build_expression @@ generate_c_expr e0 - in - let locals_e1, set_e1, def_e1, value_e1 = - D.build_expression @@ generate_c_expr e1 - in - let locals_step, set_step, def_step, value_step = - D.build_expression @@ generate_c_expr step - in - pr "@[{@;"; - pr "char %s;@;double %s;@;" itval_e0_def itval_e0_val; - pr "char %s;@;double %s;@;" itval_e1_def itval_e1_val; - pr "char %s;@;double %s;@;" itval_step_def itval_step_val; - pr "%a" D.format_local_declarations locals_e0; - pr "%a" D.format_local_declarations locals_e1; - pr "%a" D.format_local_declarations locals_step; - pr "%a" (D.format_set_vars dgfip_flags) set_e0; - pr "%a" (D.format_set_vars dgfip_flags) set_e1; - pr "%a" (D.format_set_vars dgfip_flags) set_step; - pr "%a@;" (D.format_assign dgfip_flags itval_e0_def) def_e0; - pr "%a@;" (D.format_assign dgfip_flags itval_e1_def) def_e1; - pr "%a@;" (D.format_assign dgfip_flags itval_step_def) def_step; - pr "%a@;" (D.format_assign dgfip_flags itval_e0_val) value_e0; - pr "%a@;" (D.format_assign dgfip_flags itval_e1_val) value_e1; - pr "%a@;" (D.format_assign dgfip_flags itval_step_val) value_step; - pr "@[if(%s && %s && %s && %s != 0.0){@;" itval_e0_def - itval_e1_def itval_step_def itval_step_val; + pr "@;@[{"; + pr "@;char %s;@;double %s;" e0_def e0_val; + pr "@;char %s;@;double %s;" e1_def e1_val; + pr "@;char %s;@;double %s;" step_def step_val; + generate_expr_with_res_in dgfip_flags oc e0_def e0_val e0; + generate_expr_with_res_in dgfip_flags oc e1_def e1_val e1; + generate_expr_with_res_in dgfip_flags oc step_def step_val step; + pr "@;@[if(%s && %s && %s && %s != 0.0){" e0_def e1_def step_def + step_val; pr - "@[for(%s = 1, %s = %s; (%s > 0.0 ? %s <= %s : %s >= %s); \ - %s = %s + %s){@;" - itval_def itval_val itval_e0_val itval_step_val itval_val - itval_e1_val itval_val itval_e1_val itval_val itval_val - itval_step_val; - pr "%a@]@;" (generate_stmts dgfip_flags program) stmts; - pr "}@;"; - pr "@]@;}@;"; + "@;\ + @[for (%s = 1, %s = %s; (%s > 0.0 ? %s <= %s : %s >= %s); %s \ + = %s + %s) {" + itval_def itval_val e0_val step_val itval_val e1_val itval_val + e1_val itval_val itval_val step_val; + pr "@;%a" (generate_stmts dgfip_flags program) stmts; + pr "@]@;}"; + pr "@]@;}"; pr "@]@;}") var_intervals | ArrangeEvents (sort, filter, stmts) -> - let pr fmt = Format.fprintf oc fmt in let events_sav = fresh_c_local "events_sav" in let events_tmp = fresh_c_local "events_tmp" in let nb_events_sav = fresh_c_local "nb_events_sav" in let cpt_i = fresh_c_local "i" in let cpt_j = fresh_c_local "j" in - pr "@[{"; + pr "@;@[{"; pr "@;T_event **%s = irdata->events;" events_sav; pr "@;int %s = irdata->nb_events;" nb_events_sav; pr "@;T_event **%s = NULL;" events_tmp; @@ -817,23 +707,14 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) let var = Pos.unmark m_var in let ref_def = VID.gen_def var "" in let ref_val = VID.gen_val var "" in - let cond_def = fresh_c_local "cond_def" in - let cond_val = fresh_c_local "cond_val" in - let locals, set, def, value = - D.build_expression @@ generate_c_expr expr - in - pr "@;char %s;" cond_def; - pr "@;double %s;" cond_val; + let cond = fresh_c_local "cond" in + let cond_def = cond ^ "_def" in + let cond_val = cond ^ "_val" in + pr "@;char %s;@;double %s;" cond_def cond_val; pr "@;%s = 1;" ref_def; pr "@;%s = (double)%s;" ref_val cpt_j; - pr "@;@[{@;%a%a%a@;%a@]@;}" D.format_local_declarations locals - (D.format_set_vars dgfip_flags) - set - (D.format_assign dgfip_flags cond_def) - def - (D.format_assign dgfip_flags cond_val) - value; - pr "@;@[if(%s && (%s != 0.0)) {" cond_def cond_val; + generate_expr_with_res_in dgfip_flags oc cond_def cond_val expr; + pr "@;@[if (%s && %s != 0.0) {" cond_def cond_val; pr "@;%s[%s] = irdata->events[%s];" events_tmp cpt_i cpt_j; pr "@;%s++;" cpt_i; pr "@]@;}"; @@ -842,7 +723,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;irdata->events = %s;" events_tmp; pr "@;irdata->nb_events = %s;" cpt_i | None -> - pr "@;@[while(%s < %s) {" cpt_j nb_events_sav; + pr "@;@[while (%s < %s) {" cpt_j nb_events_sav; pr "@;%s[%s] = irdata->events[%s];" events_tmp cpt_j cpt_j; pr "@;%s++;" cpt_j; pr "@]@;}"; @@ -886,23 +767,13 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) let ref1_val = VID.gen_val var1 "" in let cmp_def = fresh_c_local "cmp_def" in let cmp_val = fresh_c_local "cmp_val" in - let locals, set, def, value = - D.build_expression @@ generate_c_expr expr - in - pr "@;char %s;" cmp_def; - pr "@;double %s;" cmp_val; + pr "@;char %s;@;double %s;" cmp_def cmp_val; pr "@;%s = 1;" ref0_def; pr "@;%s = (double)i;" ref0_val; pr "@;%s = 1;" ref1_def; pr "@;%s = (double)j;" ref1_val; - pr "@;@[{@;%a%a%a@;%a@]@;}" D.format_local_declarations locals - (D.format_set_vars dgfip_flags) - set - (D.format_assign dgfip_flags cmp_def) - def - (D.format_assign dgfip_flags cmp_val) - value; - pr "@;cpt = %s && (%s != 0.0);" cmp_def cmp_val; + generate_expr_with_res_in dgfip_flags oc cmp_def cmp_val expr; + pr "@;cpt = %s && %s != 0.0;" cmp_def cmp_val; (* ----------- *) pr "@]@;}"; pr "@;@[if (i < iRight && (j >= iEnd || cpt)) {"; @@ -926,16 +797,17 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;free(irdata->events);"; pr "@;irdata->events = %s;" events_sav; pr "@;irdata->nb_events = %s;" nb_events_sav; - pr "@]@;}@;" - | Restore (vars, var_params, stmts) -> - let pr fmt = Format.fprintf oc fmt in - pr "@[{@;"; + pr "@]@;}" + | Restore (vars, var_params, evts, stmts) -> + pr "@;@[{"; let rest_name = fresh_c_local "restore" in - pr "T_env_sauvegarde *%s = NULL;@;" rest_name; + let rest_evt_name = fresh_c_local "restore_evt" in + pr "@;T_env_sauvegarde *%s = NULL;" rest_name; + pr "@;T_env_sauvegarde_evt *%s = NULL;" rest_evt_name; List.iter (fun m_v -> let v = Pos.unmark m_v in - pr "env_sauvegarder(&%s, %s, %s, %s);@;" rest_name (VID.gen_def_ptr v) + pr "@;env_sauvegarder(&%s, %s, %s, %s);" rest_name (VID.gen_def_ptr v) (VID.gen_val_ptr v) (VID.gen_size v)) vars; List.iter @@ -949,42 +821,50 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) let ref_info = VID.gen_info_ptr var in let ref_def = VID.gen_def_ptr var in let ref_val = VID.gen_val_ptr var in - let cond_val = "cond_" ^ it_name in - let cond_def = cond_val ^ "_d" in - let locals, set, def, value = - D.build_expression @@ generate_c_expr expr - in - pr "@[{@;"; - pr "T_varinfo_%s *tab_%s = varinfo_%s;@;" vcd.id_str it_name + let cond = fresh_c_local "cond" in + let cond_def = cond ^ "_def" in + let cond_val = cond ^ "_val" in + pr "@;@[{"; + pr "@;T_varinfo_%s *tab_%s = varinfo_%s;" vcd.id_str it_name vcd.id_str; - pr "int nb_%s = 0;@;" it_name; - pr "@[while (nb_%s < NB_%s) {@;" it_name vcd.id_str; - pr "char %s;@;" cond_def; - pr "double %s;@;" cond_val; - pr "%s = (T_varinfo *)tab_%s;@;" ref_info it_name; - pr "%s = &(D%s[%s->idx]);@;" ref_def ref_tab ref_info; - pr "%s = &(%s[%s->idx]);@;" ref_val ref_tab ref_info; - pr "@[{@;"; - pr "%a" D.format_local_declarations locals; - pr "%a" (D.format_set_vars dgfip_flags) set; - pr "%a@;" (D.format_assign dgfip_flags cond_def) def; - pr "%a" (D.format_assign dgfip_flags cond_val) value; - pr "@]@;"; - pr "}@;"; - pr "@[if(%s && %s){@;" cond_def cond_val; - pr "env_sauvegarder(&%s, %s, %s, %s);" rest_name + pr "@;int nb_%s = 0;" it_name; + pr "@;@[while (nb_%s < NB_%s) {" it_name vcd.id_str; + pr "@;char %s;@;double %s;" cond_def cond_val; + pr "@;%s = (T_varinfo *)tab_%s;" ref_info it_name; + pr "@;%s = &(D%s[%s->idx]);" ref_def ref_tab ref_info; + pr "@;%s = &(%s[%s->idx]);" ref_val ref_tab ref_info; + generate_expr_with_res_in dgfip_flags oc cond_def cond_val expr; + pr "@;@[if (%s && %s != 0.0){" cond_def cond_val; + pr "@;env_sauvegarder(&%s, %s, %s, %s);" rest_name (VID.gen_def_ptr var) (VID.gen_val_ptr var) (VID.gen_size var); - pr "@]@;"; - pr "}@;"; - pr "tab_%s++;@;" it_name; - pr "nb_%s++;" it_name; pr "@]@;}"; - pr "@]@;}@;") + pr "@;tab_%s++;" it_name; + pr "@;nb_%s++;" it_name; + pr "@]@;}"; + pr "@]@;}") vcs) var_params; - pr "%a@;" (generate_stmts dgfip_flags program) stmts; - pr "env_restaurer(&%s);@;" rest_name; - pr "@]}@;" + List.iter + (fun expr -> + let idx = fresh_c_local "idx" in + let idx_def = idx ^ "_def" in + let idx_val = idx ^ "_val" in + pr "@;@[{"; + pr "@;char %s;@;double %s;" idx_def idx_val; + pr "@;int %s;" idx; + generate_expr_with_res_in dgfip_flags oc idx_def idx_val expr; + pr "@;%s = (int)%s;" idx idx_val; + pr "@;@[if (%s && 0 <= %s && %s < irdata->nb_events) {" idx_def + idx idx; + pr "@;env_sauvegarder_evt(&%s, irdata->events[%s]);@;" rest_evt_name + idx; + pr "@]@;}"; + pr "@]@;}") + evts; + pr "@;%a" (generate_stmts dgfip_flags program) stmts; + pr "@;env_restaurer(&%s);@;" rest_name; + pr "@;env_restaurer_evt(&%s);@;" rest_evt_name; + pr "@]@;}" | RaiseError (m_err, var_opt) -> let err = Pos.unmark m_err in let err_name = Pos.unmark err.Com.Error.name in @@ -993,22 +873,20 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) | Some var -> Format.sprintf "\"%s\"" (Pos.unmark var) | None -> "NULL" in - Format.fprintf oc "add_erreur(irdata, &erreur_%s, %s);@;" err_name code - | CleanErrors -> Format.fprintf oc "nettoie_erreur(irdata);@;" - | ExportErrors -> Format.fprintf oc "exporte_erreur(irdata);@;" - | FinalizeErrors -> Format.fprintf oc "finalise_erreur(irdata);@;" + pr "@;add_erreur(irdata, &erreur_%s, %s);" err_name code + | CleanErrors -> Format.fprintf oc "@;nettoie_erreur(irdata);" + | ExportErrors -> Format.fprintf oc "@;exporte_erreur(irdata);" + | FinalizeErrors -> Format.fprintf oc "@;finalise_erreur(irdata);" | ComputeDomain _ | ComputeChaining _ | ComputeVerifs _ -> assert false and generate_stmts (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (oc : Format.formatter) (stmts : Mir.m_instruction list) = - Format.fprintf oc "@["; - Format.pp_print_list (generate_stmt dgfip_flags program) oc stmts; - Format.fprintf oc "@]" + Format.pp_print_list (generate_stmt dgfip_flags program) oc stmts let generate_var_tmp_decls (oc : Format.formatter) (tf : Mir.target_data) = let pr fmt = Format.fprintf oc fmt in if tf.target_sz_tmps > 0 then ( - pr "@[{"; + pr "@;@[{"; pr "@;int i;"; pr "@;T_varinfo *info;"; pr "@;@[for (i = 0; i < %d; i++) {" tf.target_sz_tmps; @@ -1033,8 +911,7 @@ let generate_var_tmp_decls (oc : Format.formatter) (tf : Mir.target_data) = tf.target_tmp_vars; pr "@]@;}"); if tf.target_nb_refs > 0 then - pr "@;irdata->ref_org = irdata->ref_org + %d;" tf.target_nb_refs; - pr "@;" + pr "@;irdata->ref_org = irdata->ref_org + %d;" tf.target_nb_refs let generate_function_prototype (add_semicolon : bool) (oc : Format.formatter) (fd : Mir.target_data) = @@ -1053,17 +930,19 @@ let generate_function (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (oc : Format.formatter) (fn : string) = let pr fmt = Format.fprintf oc fmt in let fd = Com.TargetMap.find fn program.program_functions in - pr "@[%a{@;" (generate_function_prototype false) fd; - pr "%a@;" generate_var_tmp_decls fd; - if dgfip_flags.flg_trace then pr "aff1(\"debut %s\\n\");@;" fn; - pr "%a@;" (generate_stmts dgfip_flags program) fd.target_prog; - if dgfip_flags.flg_trace then pr "aff1(\"fin %s\\n\");@;" fn; + pr "@;@[%a {" (generate_function_prototype false) fd; + pr "%a" generate_var_tmp_decls fd; + pr "@;"; + if dgfip_flags.flg_trace then pr "@;aff1(\"debut %s\\n\");" fn; + pr "%a" (generate_stmts dgfip_flags program) fd.target_prog; + if dgfip_flags.flg_trace then pr "@;aff1(\"fin %s\\n\");" fn; pr "@;"; if fd.target_nb_refs > 0 then - pr "irdata->ref_org = irdata->ref_org - %d;@;" fd.target_nb_refs; + pr "@;irdata->ref_org = irdata->ref_org - %d;" fd.target_nb_refs; if fd.target_sz_tmps > 0 then - pr "irdata->tmps_org = irdata->tmps_org - %d;@;" fd.target_sz_tmps; - pr "return 1;@]@;}@\n@\n" + pr "@;irdata->tmps_org = irdata->tmps_org - %d;" fd.target_sz_tmps; + pr "@;return 1;"; + pr "@]@;}@;" let generate_functions (dgfip_flags : Dgfip_options.flags) (program : Mir.program) @@ -1085,17 +964,19 @@ let generate_target (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (oc : Format.formatter) (f : string) = let pr fmt = Format.fprintf oc fmt in let tf = Com.TargetMap.find f program.program_targets in - pr "@[%a{@;" (generate_target_prototype false) f; - pr "%a@;" generate_var_tmp_decls tf; - if dgfip_flags.flg_trace then pr "aff1(\"debut %s\\n\");@;" f; - pr "%a@;" (generate_stmts dgfip_flags program) tf.target_prog; - if dgfip_flags.flg_trace then pr "aff1(\"fin %s\\n\");@;" f; + pr "@;@[%a {" (generate_target_prototype false) f; + pr "%a" generate_var_tmp_decls tf; + pr "@;"; + if dgfip_flags.flg_trace then pr "@;aff1(\"debut %s\\n\");" f; + pr "%a" (generate_stmts dgfip_flags program) tf.target_prog; + if dgfip_flags.flg_trace then pr "@;aff1(\"fin %s\\n\");" f; pr "@;"; if tf.target_nb_refs > 0 then - pr "irdata->ref_org = irdata->ref_org - %d;@;" tf.target_nb_refs; + pr "@;irdata->ref_org = irdata->ref_org - %d;" tf.target_nb_refs; if tf.target_sz_tmps > 0 then - pr "irdata->tmps_org = irdata->tmps_org - %d;@;" tf.target_sz_tmps; - pr "return irdata->discords;@]@;}@\n@\n" + pr "@;irdata->tmps_org = irdata->tmps_org - %d;" tf.target_sz_tmps; + pr "@;return irdata->discords;"; + pr "@]@;}@;" let generate_targets (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (filemap : (out_channel * Format.formatter) StrMap.t) = @@ -1139,7 +1020,7 @@ let generate_c_program (dgfip_flags : Dgfip_options.flags) let fn = Filename.concat folder (file_str ^ ".c") in let oc = open_out fn in let fmt = Format.formatter_of_out_channel oc in - Format.fprintf fmt "#include \"mlang.h\"\n\n"; + Format.fprintf fmt "#include \"mlang.h\"@;@;"; Some (oc, fmt) in StrMap.update file_str update filemap) @@ -1150,6 +1031,6 @@ let generate_c_program (dgfip_flags : Dgfip_options.flags) generate_targets dgfip_flags program filemap; StrMap.iter (fun _ (oc, fmt) -> - Format.fprintf fmt "\n@?"; + Format.fprintf fmt "@;@?"; close_out oc) filemap diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index d5278867d..57af5d774 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -543,8 +543,16 @@ typedef struct S_env_sauvegarde { struct S_env_sauvegarde *suite; } T_env_sauvegarde; +typedef struct S_env_sauvegarde_evt { + T_event sauv_evt; + T_event *orig_evt; + struct S_env_sauvegarde_evt *suite; +} T_env_sauvegarde_evt; + extern void env_sauvegarder(T_env_sauvegarde **liste, char *oDef, double *oVal, int sz); extern void env_restaurer(T_env_sauvegarde **liste); +extern void env_sauvegarder_evt(T_env_sauvegarde_evt **liste, T_event *evt); +extern void env_restaurer_evt(T_env_sauvegarde_evt **liste); extern int nb_informatives(T_irdata *irdata); extern int nb_discordances(T_irdata *irdata); extern int nb_anomalies(T_irdata *irdata); @@ -1029,13 +1037,46 @@ void env_restaurer(T_env_sauvegarde **liste) { while (*liste != NULL) { courant = *liste; - *liste = courant-> suite; + *liste = courant->suite; *(courant->orig_def) = courant->sauv_def; *(courant->orig_val) = courant->sauv_val; free(courant); } } +static void copy_evt(T_event *src, T_event *dst) { +|}; + StrMap.iter + (fun f (ef : Com.event_field) -> + if ef.is_var then + Format.fprintf fmt " dst->field_%s_var = src->field_%s_var;\n" f f + else ( + Format.fprintf fmt " dst->field_%s_def = src->field_%s_def;\n" f f; + Format.fprintf fmt " dst->field_%s_val = src->field_%s_val;\n" f f)) + cprog.program_event_fields; + Format.fprintf fmt "%s" + {| + } + +void env_sauvegarder_evt(T_env_sauvegarde_evt **liste, T_event *evt) { + T_env_sauvegarde_evt *nouveau = (T_env_sauvegarde_evt *)malloc(sizeof (T_env_sauvegarde_evt)); + copy_evt(evt, &(nouveau->sauv_evt)); + nouveau->orig_evt = evt; + nouveau->suite = *liste; + *liste = nouveau; +} + +void env_restaurer_evt(T_env_sauvegarde_evt **liste) { + T_env_sauvegarde_evt *courant; + + while (*liste != NULL) { + courant = *liste; + *liste = courant->suite; + copy_evt(&(courant->sauv_evt), courant->orig_evt); + free(courant); + } +} + void set_print_indent(FILE *std, T_print_context *pr_ctx, double diff) { long d = (long)floor(diff + 0.5); pr_ctx->indent = max(0, pr_ctx->indent + d); diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index 966f1c431..5aa4885ef 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -1424,7 +1424,7 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) out_vars |> StrSet.union (out_instrs |> StrSet.remove var_name) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il - | Com.Restore (vars, var_params, instrs) -> + | Com.Restore (vars, var_params, evts, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; ignore (List.fold_left @@ -1449,11 +1449,14 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) in ignore (check_expression false expr env)) var_params; + List.iter + (fun expr -> ignore (check_expression false expr env)) + evts; let prog, res_instrs, _, _ = check_instructions instrs is_rule env in let env = { env with prog } in - let res_instr = Com.Restore (vars, var_params, res_instrs) in + let res_instr = Com.Restore (vars, var_params, evts, res_instrs) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il | Com.ArrangeEvents (sort, filter, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; @@ -2539,7 +2542,7 @@ let complete_vars_stack (prog : program) : program = | Com.Iterate_values (_, _, instrs) -> let nbRef, nbIt = aux_instrs instrs in (nbRef, nbIt + 1) - | Com.Restore (_, _, instrs) -> + | Com.Restore (_, _, _, instrs) -> let nbRef, nbIt = aux_instrs instrs in (max nbRef 1, nbIt) | Com.ArrangeEvents (sort, filter, instrs) -> @@ -2686,18 +2689,26 @@ let complete_vars_stack (prog : program) : program = let sz = 1 + max sz sz' in let nbRef = max nbRef nbRef' in (nb, sz, nbRef, tdata) - | Com.Restore (_, mel, instrs) -> - let fold (nb, sz, nbRef, tdata) (_, _, me) = - let nb', sz', nbRef', tdata = aux_expr tdata me in - (max nb nb', max sz sz', max nbRef nbRef', tdata) - in + | Com.Restore (_, var_params, evts, instrs) -> let nb', sz', nbRef', tdata = - List.fold_left fold (0, 0, 0, tdata) mel + let fold (nb, sz, nbRef, tdata) (_, _, me) = + let nb', sz', nbRef', tdata = aux_expr tdata me in + (max nb nb', max sz sz', max nbRef nbRef', tdata) + in + List.fold_left fold (0, 0, 0, tdata) var_params + in + let nb'', sz'', nbRef'', tdata = + let fold (nb, sz, nbRef, tdata) me = + let nb', sz', nbRef', tdata = aux_expr tdata me in + (max nb nb', max sz sz', max nbRef nbRef', tdata) + in + List.fold_left fold (0, 0, 0, tdata) evts in let nb, sz, nbRef, tdata = aux_instrs tdata instrs in - let nb = max nb nb' in - let sz = max sz sz' in - let nbRef = 1 + max nbRef nbRef' in + let nb = max nb (max nb' nb'') in + let sz = max sz (max sz' sz'') in + (* ??? *) + let nbRef = 1 + max nbRef (max nbRef' nbRef'') in (nb, sz, nbRef, tdata) | Com.ArrangeEvents (sort, filter, instrs) -> let n', (nb', sz', nbRef', tdata) = diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index 7e505e963..70c9ba1b2 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -743,9 +743,17 @@ let rec expand_instruction (const_map : const_context) in let instrs' = expand_instructions const_map instrs in (Com.Iterate_values (name, var_intervals', instrs'), instr_pos) :: prev - | Com.Restore (vars, var_params, instrs) -> + | Com.Restore (vars, var_params, evts, instrs) -> + let var_params' = + List.map + (fun (v, c, e) -> + let e' = expand_expression const_map ParamsMap.empty e in + (v, c, e')) + var_params + in + let evts' = List.map (expand_expression const_map ParamsMap.empty) evts in let instrs' = expand_instructions const_map instrs in - (Com.Restore (vars, var_params, instrs'), instr_pos) :: prev + (Com.Restore (vars, var_params', evts', instrs'), instr_pos) :: prev | Com.ArrangeEvents (sort, filter, instrs) -> let sort' = match sort with diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 160c80d81..641964929 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -357,7 +357,7 @@ let rec translate_prog (p : Check_validity.program) aux ((Com.Iterate_values (m_var, var_intervals', prog_it), pos) :: res) il - | (Com.Restore (vars, var_params, instrs), pos) :: il -> + | (Com.Restore (vars, var_params, evts, instrs), pos) :: il -> let vars' = List.map (fun vn -> @@ -382,8 +382,11 @@ let rec translate_prog (p : Check_validity.program) (Pos.mark var_pos var, catSet, mir_expr)) var_params in + let evts' = List.map (translate_expression p var_data) evts in let prog_rest = translate_prog p var_data it_depth itval_depth instrs in - aux ((Com.Restore (vars', var_params', prog_rest), pos) :: res) il + aux + ((Com.Restore (vars', var_params', evts', prog_rest), pos) :: res) + il | (Com.ArrangeEvents (sort, filter, instrs), pos) :: il -> let sort', itval_depth' = match sort with diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index d732ad40a..fc8f4b6e2 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -87,6 +87,7 @@ rule token = parse | "erreur" -> ERROR | "et" -> AND | "evenement" -> EVENT + | "evenements" -> EVENTS | "exporte_erreurs" -> EXPORT_ERRORS | "faire" -> DO | "filtrer" -> FILTER @@ -134,6 +135,7 @@ rule token = parse | "un" -> ONE | "valeur" -> VALUE | "variable" -> VARIABLE + | "variables" -> VARIABLES | "variables_temporaires" -> TEMP_VARS | "verif" -> VERIFICATION | "verifiable" -> VERIFIABLE diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 94d9c2958..441a5bd0b 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -55,10 +55,10 @@ along with this program. If not, see . %token RAISE_ERROR EXPORT_ERRORS CLEAN_ERRORS FINALIZE_ERRORS %token ITERATE CATEGORY RESTORE AFTER %token ERROR ANOMALY DISCORDANCE -%token INFORMATIVE OUTPUT FONCTION VARIABLE ATTRIBUT +%token INFORMATIVE OUTPUT FONCTION VARIABLE VARIABLES ATTRIBUT %token BASE GIVEN_BACK COMPUTABLE BY_DEFAULT %token DOMAIN SPECIALIZE AUTHORIZE VERIFIABLE -%token EVENT VALUE STEP EVENT_FIELD ARRANGE_EVENTS SORT FILTER +%token EVENT EVENTS VALUE STEP EVENT_FIELD ARRANGE_EVENTS SORT FILTER %token EOF @@ -706,14 +706,22 @@ instruction: } | RESTORE COLON rest_params = nonempty_list(rest_param) AFTER LPAREN instrs = instruction_list_rev RPAREN { - let var_list, var_cats = - let fold (var_list, var_cats) = function - | `VarList vl -> (List.rev vl) @ var_list, var_cats - | `VarCatsRest vc -> var_list, vc @ var_cats + let var_list, var_cats, event_list = + let fold (var_list, var_cats, event_list) = function + | `VarList vl -> (List.rev vl) @ var_list, var_cats, event_list + | `VarCatsRest vc -> var_list, vc @ var_cats, event_list + | `EventList el -> var_list, var_cats, el @ event_list in - List.fold_left fold ([], []) rest_params + List.fold_left fold ([], [], []) rest_params in - Some (Restore (List.rev var_list, List.rev var_cats, List.rev instrs)) + Some ( + Restore ( + List.rev var_list, + List.rev var_cats, + List.rev event_list, + List.rev instrs + ) + ) } | ARRANGE_EVENTS COLON arr_params = nonempty_list(with_pos(arrange_events_param)) @@ -879,7 +887,7 @@ it_param_with_expr: | WITH expr = with_pos(expression) COLON { expr } rest_param: -| vars = separated_nonempty_list(COMMA, symbol_with_pos) COLON { +| VARIABLES vars = separated_nonempty_list(COMMA, symbol_with_pos) COLON { let vl = List.map (fun vn -> Pos.same_pos_as (Normal (Pos.unmark vn)) vn) vars in @@ -891,6 +899,9 @@ rest_param: let filters = List.map (fun (vcats, expr) -> (var, vcats, expr)) vparams in `VarCatsRest filters } +| EVENTS expr_list = separated_nonempty_list(COMMA, with_pos(expression)) COLON { + `EventList expr_list; + } rest_param_category: | CATEGORY vcat_list = separated_nonempty_list(COMMA, with_pos(var_category_id)) diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 5d6e2cbea..0d74bf715 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -495,6 +495,7 @@ type ('v, 'e) instruction = | Restore of 'v Pos.marked list * ('v Pos.marked * Pos.t CatVar.Map.t * 'v m_expression) list + * 'v m_expression list * ('v, 'e) m_instruction list | ArrangeEvents of ('v Pos.marked * 'v Pos.marked * 'v m_expression) option @@ -814,18 +815,33 @@ let rec format_instruction form_var form_err = (Pp.list_space format_var_intervals) var_intervals; Format.fprintf fmt "@[ %a@]@\n)@\n" form_instrs itb - | Restore (vars, var_params, rb) -> + | Restore (vars, var_params, evts, rb) -> + let format_vars fmt = function + | [] -> () + | vars -> + Format.fprintf fmt "@;: variables %a" + (Pp.list_comma (Pp.unmark form_var)) + vars + in let format_var_param fmt (var, vcs, expr) = - Format.fprintf fmt ": variable %a : categorie %a : avec %a@\n" + Format.fprintf fmt "@;: variable %a : categorie %a : avec %a" (Pp.unmark form_var) var (CatVar.Map.pp_keys ()) vcs form_expr (Pos.unmark expr) in - Format.fprintf fmt "restaure@;: %a@;: %a@;: apres (" - (Pp.list_comma (Pp.unmark form_var)) - vars - (Pp.list_space format_var_param) - var_params; - Format.fprintf fmt "@[ %a@]@\n)@\n" form_instrs rb + let format_var_params fmt = function + | [] -> () + | var_params -> Pp.list "" format_var_param fmt var_params + in + let format_evts fmt = function + | [] -> () + | evts -> + Format.fprintf fmt "@;: evenements %a" + (Pp.list_comma (Pp.unmark form_expr)) + evts + in + Format.fprintf fmt "restaure%a%a%a@;: apres (" format_vars vars + format_var_params var_params format_evts evts; + Format.fprintf fmt "@[ %a@]@;)@;" form_instrs rb | ArrangeEvents (s, f, itb) -> Format.fprintf fmt "arrange_evenements@;:"; (match s with diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 044720238..00a84f60f 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -348,6 +348,7 @@ type ('v, 'e) instruction = | Restore of 'v Pos.marked list * ('v Pos.marked * Pos.t CatVar.Map.t * 'v m_expression) list + * 'v m_expression list * ('v, 'e) m_instruction list | ArrangeEvents of ('v Pos.marked * 'v Pos.marked * 'v m_expression) option diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 677245202..ce1fcda49 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -286,14 +286,15 @@ let expand_functions (p : program) : program = in let instrs' = List.map map_instr instrs in (Iterate_values (v_id, var_intervals', instrs'), instr_pos) - | Restore (vars, filters, instrs) -> - let filters' = + | Restore (vars, var_params, evts, instrs) -> + let var_params' = List.map (fun (v, cs, e) -> (v, cs, expand_functions_expr e)) - filters + var_params in + let evts' = List.map expand_functions_expr evts in let instrs' = List.map map_instr instrs in - (Restore (vars, filters', instrs'), instr_pos) + (Restore (vars, var_params', evts', instrs'), instr_pos) | ArrangeEvents (sort, filter, instrs) -> let sort' = match sort with diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 7139b1948..05efa7e1e 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -796,48 +796,63 @@ struct | Undefined -> ()) | Undefined -> ()) var_intervals - | Com.Restore (vars, var_params, stmts) -> - let backup = + | Com.Restore (vars, var_params, evts, stmts) -> + let backup_vars = List.fold_left - (fun backup (m_v : Com.Var.t Pos.marked) -> + (fun backup_vars (m_v : Com.Var.t Pos.marked) -> let v, vi = m_v |> Pos.unmark |> get_var ctx in - let rec aux backup i = - if i = Com.Var.size v then backup + let rec aux backup_vars i = + if i = Com.Var.size v then backup_vars else let value = get_var_value ctx v i in - aux ((v, vi + i, value) :: backup) (i + 1) + aux ((v, vi + i, value) :: backup_vars) (i + 1) in - aux backup 0) + aux backup_vars 0) [] vars in - let backup = + let backup_vars = List.fold_left - (fun backup ((m_var : Com.Var.t Pos.marked), vcs, expr) -> + (fun backup_vars ((m_var : Com.Var.t Pos.marked), vcs, expr) -> let var = Pos.unmark m_var in let var_i = match var.loc with LocRef (_, i) -> i | _ -> assert false in Com.CatVar.Map.fold - (fun vc _ backup -> + (fun vc _ backup_vars -> StrMap.fold - (fun _ v backup -> + (fun _ v backup_vars -> if Com.CatVar.compare (Com.Var.cat v) vc = 0 then ( let var, vi = get_var ctx v in ctx.ctx_ref.(ctx.ctx_ref_org + var_i) <- (var, vi); match evaluate_expr ctx p expr with | Number z when N.(z =. one ()) -> - let rec aux backup i = - if i = Com.Var.size var then backup + let rec aux backup_vars i = + if i = Com.Var.size var then backup_vars else let value = get_var_value ctx var i in - aux ((v, vi + i, value) :: backup) (i + 1) + aux ((v, vi + i, value) :: backup_vars) (i + 1) in - aux backup 0 - | _ -> backup) - else backup) - p.program_vars backup) - vcs backup) - backup var_params + aux backup_vars 0 + | _ -> backup_vars) + else backup_vars) + p.program_vars backup_vars) + vcs backup_vars) + backup_vars var_params + in + let backup_evts = + List.fold_left + (fun backup_evts expr -> + match evaluate_expr ctx p expr with + | Number z -> + let i = N.(to_int z) |> Int64.to_int in + let events0 = List.hd ctx.ctx_events in + if 0 <= i && i < Array.length events0 then + let j = events0.(i) in + let evt = Array.copy ctx.ctx_event_tab.(j) in + (j, evt) :: backup_evts + else backup_evts + | _ -> backup_evts) + [] evts in evaluate_stmts tn canBlock p ctx stmts; List.iter @@ -848,7 +863,8 @@ struct | Com.Var.Ref -> assert false | Com.Var.Arg -> (List.hd ctx.ctx_args).(i) <- value | Com.Var.Res -> ctx.ctx_res <- value :: List.tl ctx.ctx_res) - backup + backup_vars; + List.iter (fun (j, evt) -> ctx.ctx_event_tab.(j) <- evt) backup_evts | Com.ArrangeEvents (sort, filter, stmts) -> let events = match filter with From 286150fdb2c7150ce6bf10bbe8a9755712377953 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 30 Jan 2025 13:08:45 +0100 Subject: [PATCH 18/32] =?UTF-8?q?Restauration=20des=20=C3=A9v=C3=A9nements?= =?UTF-8?q?=20(pr=C3=A9dicats).?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2023/cibles.m | 53 ++++++++++--- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 30 +++++++- src/mlang/backend_compilers/decoupledExpr.ml | 11 +++ src/mlang/backend_compilers/decoupledExpr.mli | 4 + src/mlang/m_frontend/check_validity.ml | 77 +++++++++++++------ src/mlang/m_frontend/expand_macros.ml | 12 ++- src/mlang/m_frontend/mast_to_mir.ml | 19 ++++- src/mlang/m_frontend/mlexer.mll | 1 + src/mlang/m_frontend/mparser.mly | 23 ++++-- src/mlang/m_ir/com.ml | 21 +++-- src/mlang/m_ir/com.mli | 3 +- src/mlang/m_ir/mir.ml | 7 +- src/mlang/m_ir/mir_interpreter.ml | 30 +++++++- src/mlang/m_ir/mir_number.ml | 24 ++++++ src/mlang/m_ir/mir_number.mli | 2 + 15 files changed, 257 insertions(+), 60 deletions(-) diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index b45c76d80..d43875129 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -889,21 +889,50 @@ et champ_evenement(I, montant) <= champ_evenement(J, montant) calculer cible afficher_evenements; ) afficher_erreur "\n"; -EVT = 26; -afficher_erreur "0: "; -calculer cible afficher_evenement : avec EVT; -afficher_erreur "\n"; -restaurer -: evenements EVT -: apres ( - champ_evenement(EVT, montant) = 111111.111111; - afficher_erreur "1: "; +arranger_evenements +: trier I, J : avec champ_evenement(I, rappel) <= champ_evenement(J, rappel) +: dans ( + EVT = 25; + afficher_erreur "0: "; + calculer cible afficher_evenement : avec EVT; + afficher_erreur "\n"; + iterer : variable I : 0 .. nb_evenements() increment 1 : dans ( + si inf(champ_evenement(I, rappel) % 2) = 0 alors + afficher_erreur "0: "; + calculer cible afficher_evenement : avec I; + afficher_erreur "\n"; + finsi + ) + afficher_erreur "\n"; + restaurer + : evenements EVT + : evenement I : avec inf(champ_evenement(I, rappel) % 2) = 0 + : apres ( + champ_evenement(EVT, montant) = 111111.111111; + afficher_erreur "1: "; + calculer cible afficher_evenement : avec EVT; + afficher_erreur "\n"; + iterer : variable I : 0 .. nb_evenements() increment 1 : dans ( + si inf(champ_evenement(I, rappel) % 2) = 0 alors + champ_evenement(I, montant) = 111111.111111; + afficher_erreur "2: "; + calculer cible afficher_evenement : avec I; + afficher_erreur "\n"; + finsi + ) + ) + afficher_erreur "\n"; + afficher_erreur "2: "; calculer cible afficher_evenement : avec EVT; afficher_erreur "\n"; + iterer : variable I : 0 .. nb_evenements() increment 1 : dans ( + si inf(champ_evenement(I, rappel) % 2) = 0 alors + afficher_erreur "2: "; + calculer cible afficher_evenement : avec I; + afficher_erreur "\n"; + finsi + ) ) -afficher_erreur "2: "; -calculer cible afficher_evenement : avec EVT; -afficher_erreur "\n"; cible enchainement_primitif: application: iliad; diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index 7ba571e78..df214ab51 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -75,7 +75,8 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : let set_vars = se1.D.set_vars @ se2.D.set_vars in let def_test = match Pos.unmark op with - | Com.And | Com.Mul | Com.Div -> D.dand se1.def_test se2.def_test + | Com.And | Com.Mul | Com.Div | Com.Mod -> + D.dand se1.def_test se2.def_test | Com.Or | Com.Add | Com.Sub -> D.dor se1.def_test se2.def_test in let op e1 e2 = @@ -86,6 +87,7 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : | Com.Sub -> D.sub e1 e2 | Com.Mul -> D.mult e1 e2 | Com.Div -> D.ite e2 (D.div e1 e2) (D.lit 0.) + | Com.Mod -> D.ite e2 (D.modulo e1 e2) (D.lit 0.) in let value_comp = op se1.value_comp se2.value_comp in D.build_transitive_composition ~safe_def:true @@ -798,7 +800,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;irdata->events = %s;" events_sav; pr "@;irdata->nb_events = %s;" nb_events_sav; pr "@]@;}" - | Restore (vars, var_params, evts, stmts) -> + | Restore (vars, var_params, evts, evtfs, stmts) -> pr "@;@[{"; let rest_name = fresh_c_local "restore" in let rest_evt_name = fresh_c_local "restore_evt" in @@ -861,6 +863,30 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@]@;}"; pr "@]@;}") evts; + List.iter + (fun (m_var, expr) -> + let var = Pos.unmark m_var in + let idx = fresh_c_local "idx" in + let ref_def = VID.gen_def var "" in + let ref_val = VID.gen_val var "" in + let cond = fresh_c_local "cond" in + let cond_def = cond ^ "_def" in + let cond_val = cond ^ "_val" in + pr "@;@[{"; + pr "@;int %s = 0;" idx; + pr "@;@[while (%s < irdata->nb_events) {" idx; + pr "@;char %s;@;double %s;" cond_def cond_val; + pr "@;%s = 1;" ref_def; + pr "@;%s = (double)%s;" ref_val idx; + generate_expr_with_res_in dgfip_flags oc cond_def cond_val expr; + pr "@;@[if (%s && %s != 0.0){" cond_def cond_val; + pr "@;env_sauvegarder_evt(&%s, irdata->events[%s]);@;" rest_evt_name + idx; + pr "@]@;}"; + pr "@;%s++;" idx; + pr "@]@;}"; + pr "@]@;}") + evtfs; pr "@;%a" (generate_stmts dgfip_flags program) stmts; pr "@;env_restaurer(&%s);@;" rest_name; pr "@;env_restaurer_evt(&%s);@;" rest_evt_name; diff --git a/src/mlang/backend_compilers/decoupledExpr.ml b/src/mlang/backend_compilers/decoupledExpr.ml index 6a970e3a8..999b3ee51 100644 --- a/src/mlang/backend_compilers/decoupledExpr.ml +++ b/src/mlang/backend_compilers/decoupledExpr.ml @@ -315,6 +315,17 @@ let div (e1 : constr) (e2 : constr) (stacks : local_stacks) (ctx : local_vars) : (Dlit f, Val, []) | _ -> (Dbinop ("/", e1, e2), Val, lv2 @ lv1) +let modulo (e1 : constr) (e2 : constr) (stacks : local_stacks) + (ctx : local_vars) : t = + let stacks', lv1, e1 = push_with_kind stacks ctx Val e1 in + let _, lv2, e2 = push_with_kind stacks' ctx Val e2 in + match (e1, e2) with + | _, Dlit 1. -> (e1, Val, lv1) + | Dlit f1, Dlit f2 -> + let f = mod_float f1 f2 in + (Dlit f, Val, []) + | _ -> (Dfun ("fmod", [ e1; e2 ]), Val, lv2 @ lv1) + let comp op (e1 : constr) (e2 : constr) (stacks : local_stacks) (ctx : local_vars) : t = let stacks', lv1, e1 = push_with_kind stacks ctx Val e1 in diff --git a/src/mlang/backend_compilers/decoupledExpr.mli b/src/mlang/backend_compilers/decoupledExpr.mli index d76f679b3..037f389aa 100644 --- a/src/mlang/backend_compilers/decoupledExpr.mli +++ b/src/mlang/backend_compilers/decoupledExpr.mli @@ -100,6 +100,10 @@ val div : constr -> constr -> constr (** Float division. Care to guard for division by zero as it is not intrisectly guarranteed *) +val modulo : constr -> constr -> constr +(** Float modulo. Care to guard for modulo by zero as it is not intrisectly + guarranteed *) + val comp : string -> constr -> constr -> constr (** Comparison operation. The operator is given as C-style string literal *) diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index 5aa4885ef..34f49cc70 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -1197,6 +1197,10 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) (match StrMap.find_opt var_name env.ref_vars with | Some old_pos -> Err.variable_already_declared var_name old_pos var_pos | None -> ()); + (match env.res_var with + | Some (vr, old_pos) when vr = var_name -> + Err.variable_already_declared var_name old_pos var_pos + | Some _ | None -> ()); (var_name, var_pos) in let rec aux (env, res, in_vars, out_vars) = function @@ -1424,7 +1428,7 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) out_vars |> StrSet.union (out_instrs |> StrSet.remove var_name) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il - | Com.Restore (vars, var_params, evts, instrs) -> + | Com.Restore (vars, var_params, evts, evtfs, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; ignore (List.fold_left @@ -1452,11 +1456,24 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) List.iter (fun expr -> ignore (check_expression false expr env)) evts; + List.iter + (fun (var, expr) -> + let var_name, var_pos = check_it_var env var in + let env = + { + env with + tmp_vars = StrMap.add var_name (None, var_pos) env.tmp_vars; + } + in + ignore (check_expression false expr env)) + evtfs; let prog, res_instrs, _, _ = check_instructions instrs is_rule env in let env = { env with prog } in - let res_instr = Com.Restore (vars, var_params, evts, res_instrs) in + let res_instr = + Com.Restore (vars, var_params, evts, evtfs, res_instrs) + in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il | Com.ArrangeEvents (sort, filter, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; @@ -2257,7 +2274,12 @@ let eval_expr_verif (prog : program) (verif : verif) | Com.Div -> ( match (r0, r1) with | None, _ | _, None -> None - | Some f0, Some f1 -> if f1 = 0.0 then r1 else Some (f0 /. f1))) + | Some f0, Some f1 -> if f1 = 0.0 then r1 else Some (f0 /. f1)) + | Com.Mod -> ( + match (r0, r1) with + | None, _ | _, None -> None + | Some f0, Some f1 -> + if f1 = 0.0 then r1 else Some (mod_float f0 f1))) | Conditional (e0, e1, e2) -> ( let r0 = aux e0 in let r1 = aux e1 in @@ -2542,14 +2564,14 @@ let complete_vars_stack (prog : program) : program = | Com.Iterate_values (_, _, instrs) -> let nbRef, nbIt = aux_instrs instrs in (nbRef, nbIt + 1) - | Com.Restore (_, _, _, instrs) -> + | Com.Restore (_, _, _, _, instrs) -> let nbRef, nbIt = aux_instrs instrs in (max nbRef 1, nbIt) | Com.ArrangeEvents (sort, filter, instrs) -> let nbItSort = match sort with Some _ -> 2 | None -> 0 in let nbItFilter = match filter with Some _ -> 1 | None -> 0 in let nbRef, nbIt = aux_instrs instrs in - (nbRef, max nbIt (max nbItSort nbItFilter)) + (nbRef, max nbIt @@ max nbItSort nbItFilter) | Com.Affectation _ | Com.Print _ | Com.ComputeTarget _ | Com.RaiseError _ | Com.CleanErrors | Com.ExportErrors | Com.FinalizeErrors -> (0, 0) @@ -2621,18 +2643,18 @@ let complete_vars_stack (prog : program) : program = let nbI, szI, nbRefI, tdata = aux_expr tdata meI in let nbT, szT, nbRefT, tdata = aux_instrs tdata ilT in let nbE, szE, nbRefE, tdata = aux_instrs tdata ilE in - let nb = max nbI (max nbT nbE) in - let sz = max szI (max szT szE) in - let nbRef = max nbRefI (max nbRefT nbRefE) in + let nb = max nbI @@ max nbT nbE in + let sz = max szI @@ max szT szE in + let nbRef = max nbRefI @@ max nbRefT nbRefE in (nb, sz, nbRef, tdata) | Com.WhenDoElse (wdl, ed) -> let rec wde (nb, sz, nbRef, tdata) = function | (me, dl, _) :: wdl' -> let nbE, szE, nbRefE, tdata = aux_expr tdata me in let nbD, szD, nbRefD, tdata = aux_instrs tdata dl in - let nb = max nb (max nbE nbD) in - let sz = max sz (max szE szD) in - let nbRef = max nbRef (max nbRefE nbRefD) in + let nb = max nb @@ max nbE nbD in + let sz = max sz @@ max szE szD in + let nbRef = max nbRef @@ max nbRefE nbRefD in wde (nb, sz, nbRef, tdata) wdl' | [] -> let nbD, szD, nbRefD, tdata = @@ -2676,9 +2698,9 @@ let complete_vars_stack (prog : program) : program = let nb', sz', nbRef', tdata = aux_expr tdata me0 in let nb'', sz'', nbRef'', tdata = aux_expr tdata me1 in let nb''', sz''', nbRef''', tdata = aux_expr tdata mstep in - let nb = max nb (max nb' (max nb'' nb''')) in - let sz = max sz (max sz' (max sz'' sz''')) in - let nbRef = max nbRef (max nbRef' (max nbRef'' nbRef''')) in + let nb = max nb @@ max nb' @@ max nb'' nb''' in + let sz = max sz @@ max sz' @@ max sz'' sz''' in + let nbRef = max nbRef @@ max nbRef' @@ max nbRef'' nbRef''' in (nb, sz, nbRef, tdata) in let nb', sz', nbRef', tdata = @@ -2689,7 +2711,7 @@ let complete_vars_stack (prog : program) : program = let sz = 1 + max sz sz' in let nbRef = max nbRef nbRef' in (nb, sz, nbRef, tdata) - | Com.Restore (_, var_params, evts, instrs) -> + | Com.Restore (_, var_params, evts, evtfs, instrs) -> let nb', sz', nbRef', tdata = let fold (nb, sz, nbRef, tdata) (_, _, me) = let nb', sz', nbRef', tdata = aux_expr tdata me in @@ -2704,11 +2726,18 @@ let complete_vars_stack (prog : program) : program = in List.fold_left fold (0, 0, 0, tdata) evts in + let nb''', sz''', nbRef''', tdata = + let fold (nb, sz, nbRef, tdata) (_, me) = + let nb', sz', nbRef', tdata = aux_expr tdata me in + (max nb nb', max sz sz', max nbRef nbRef', tdata) + in + List.fold_left fold (0, 0, 0, tdata) evtfs + in let nb, sz, nbRef, tdata = aux_instrs tdata instrs in - let nb = max nb (max nb' nb'') in - let sz = max sz (max sz' sz'') in + let nb = max nb @@ max nb' @@ max nb'' nb''' in + let sz = max sz @@ max sz' @@ max sz'' sz''' in (* ??? *) - let nbRef = 1 + max nbRef (max nbRef' nbRef'') in + let nbRef = 1 + (max nbRef @@ max nbRef' @@ max nbRef'' nbRef''') in (nb, sz, nbRef, tdata) | Com.ArrangeEvents (sort, filter, instrs) -> let n', (nb', sz', nbRef', tdata) = @@ -2722,9 +2751,9 @@ let complete_vars_stack (prog : program) : program = | None -> (0, (0, 0, 0, tdata)) in let nb, sz, nbRef, tdata = aux_instrs tdata instrs in - let nb = max n' n'' + max nb (max nb' nb'') in - let sz = max n' n'' + max sz (max sz' sz'') in - let nbRef = max nbRef (max nbRef' nbRef'') in + let nb = max n' n'' + (max nb @@ max nb' nb'') in + let sz = max n' n'' + (max sz @@ max sz' sz'') in + let nbRef = max nbRef @@ max nbRef' nbRef'' in (nb, sz, nbRef, tdata) | Com.RaiseError _ | Com.CleanErrors | Com.ExportErrors | Com.FinalizeErrors -> @@ -2750,9 +2779,9 @@ let complete_vars_stack (prog : program) : program = | None -> (0, 0, 0, tdata) | Some meE -> aux_expr tdata meE in - let nb = max nbI (max nbT nbE) in - let sz = max szI (max szT szE) in - let nbRef = max nbRefI (max nbRefT nbRefE) in + let nb = max nbI @@ max nbT nbE in + let sz = max szI @@ max szT szE in + let nbRef = max nbRefI @@ max nbRefT nbRefE in (nb, sz, nbRef, tdata) | Com.FuncCall (func, mel) -> let fold (nb, sz, nbRef, tdata) me = diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index 70c9ba1b2..88f2a84a6 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -743,7 +743,7 @@ let rec expand_instruction (const_map : const_context) in let instrs' = expand_instructions const_map instrs in (Com.Iterate_values (name, var_intervals', instrs'), instr_pos) :: prev - | Com.Restore (vars, var_params, evts, instrs) -> + | Com.Restore (vars, var_params, evts, evtfs, instrs) -> let var_params' = List.map (fun (v, c, e) -> @@ -752,8 +752,16 @@ let rec expand_instruction (const_map : const_context) var_params in let evts' = List.map (expand_expression const_map ParamsMap.empty) evts in + let evtfs' = + List.map + (fun (v, e) -> + let e' = expand_expression const_map ParamsMap.empty e in + (v, e')) + evtfs + in let instrs' = expand_instructions const_map instrs in - (Com.Restore (vars, var_params', evts', instrs'), instr_pos) :: prev + (Com.Restore (vars, var_params', evts', evtfs', instrs'), instr_pos) + :: prev | Com.ArrangeEvents (sort, filter, instrs) -> let sort' = match sort with diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 641964929..f9634750d 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -357,7 +357,7 @@ let rec translate_prog (p : Check_validity.program) aux ((Com.Iterate_values (m_var, var_intervals', prog_it), pos) :: res) il - | (Com.Restore (vars, var_params, evts, instrs), pos) :: il -> + | (Com.Restore (vars, var_params, evts, evtfs, instrs), pos) :: il -> let vars' = List.map (fun vn -> @@ -383,9 +383,24 @@ let rec translate_prog (p : Check_validity.program) var_params in let evts' = List.map (translate_expression p var_data) evts in + let evtfs' = + List.map + (fun (vn, expr) -> + let var_pos = Pos.get_position vn in + let var_name = Mast.get_normal_var (Pos.unmark vn) in + let var = + Com.Var.new_temp ~name:(var_name, var_pos) ~is_table:None + ~loc_int:itval_depth + in + let var_data = StrMap.add var_name var var_data in + let mir_expr = translate_expression p var_data expr in + (Pos.mark var_pos var, mir_expr)) + evtfs + in let prog_rest = translate_prog p var_data it_depth itval_depth instrs in aux - ((Com.Restore (vars', var_params', evts', prog_rest), pos) :: res) + ((Com.Restore (vars', var_params', evts', evtfs', prog_rest), pos) + :: res) il | (Com.ArrangeEvents (sort, filter, instrs), pos) :: il -> let sort', itval_depth' = diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index fc8f4b6e2..71a801792 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -45,6 +45,7 @@ rule token = parse | '-' { MINUS } | '*' { TIMES } | '/' { DIV } +| '%' { MOD } | '=' { EQUALS } | "!=" { NEQ } | '>' { GT } diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 441a5bd0b..463d205d2 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -35,7 +35,7 @@ along with this program. If not, see . %token SYMBOL STRING -%token PLUS MINUS TIMES DIV +%token PLUS MINUS TIMES DIV MOD %token GTE LTE GT LT NEQ EQUALS %token SEMICOLON COLON COMMA %token AND OR NOT UNDEFINED @@ -706,19 +706,21 @@ instruction: } | RESTORE COLON rest_params = nonempty_list(rest_param) AFTER LPAREN instrs = instruction_list_rev RPAREN { - let var_list, var_cats, event_list = - let fold (var_list, var_cats, event_list) = function - | `VarList vl -> (List.rev vl) @ var_list, var_cats, event_list - | `VarCatsRest vc -> var_list, vc @ var_cats, event_list - | `EventList el -> var_list, var_cats, el @ event_list + let var_list, var_cats, event_list, event_filter = + let fold (var_list, var_cats, event_list, event_filter) = function + | `VarList vl -> (List.rev vl) @ var_list, var_cats, event_list, event_filter + | `VarCatsRest vc -> var_list, vc @ var_cats, event_list, event_filter + | `EventList el -> var_list, var_cats, el @ event_list, event_filter + | `EventFilter ef -> var_list, var_cats, event_list, ef :: event_filter in - List.fold_left fold ([], [], []) rest_params + List.fold_left fold ([], [], [], []) rest_params in Some ( Restore ( List.rev var_list, List.rev var_cats, List.rev event_list, + List.rev event_filter, List.rev instrs ) ) @@ -900,7 +902,11 @@ rest_param: `VarCatsRest filters } | EVENTS expr_list = separated_nonempty_list(COMMA, with_pos(expression)) COLON { - `EventList expr_list; + `EventList expr_list + } +| EVENT vn = symbol_with_pos COLON WITH expr = with_pos(expression) COLON { + let var = Pos.same_pos_as (Normal (Pos.unmark vn)) vn in + `EventFilter (var, expr) } rest_param_category: @@ -1188,6 +1194,7 @@ product_expression: %inline product_operator: | TIMES { Com.Mul } | DIV { Com.Div } +| MOD { Com.Mod } table_index_name: s = SYMBOL { parse_variable $sloc s } diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 0d74bf715..c75a7a2fb 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -362,7 +362,7 @@ type 'v loop_variables = type unop = Not | Minus (** Binary operators *) -type binop = And | Or | Add | Sub | Mul | Div +type binop = And | Or | Add | Sub | Mul | Div | Mod (** Comparison operators *) type comp_op = Gt | Gte | Lt | Lte | Eq | Neq @@ -496,6 +496,7 @@ type ('v, 'e) instruction = 'v Pos.marked list * ('v Pos.marked * Pos.t CatVar.Map.t * 'v m_expression) list * 'v m_expression list + * ('v Pos.marked * 'v m_expression) list * ('v, 'e) m_instruction list | ArrangeEvents of ('v Pos.marked * 'v Pos.marked * 'v m_expression) option @@ -594,7 +595,8 @@ let format_binop fmt op = | Add -> "+" | Sub -> "-" | Mul -> "*" - | Div -> "/") + | Div -> "/" + | Mod -> "%") let format_comp_op fmt op = Format.pp_print_string fmt @@ -815,7 +817,7 @@ let rec format_instruction form_var form_err = (Pp.list_space format_var_intervals) var_intervals; Format.fprintf fmt "@[ %a@]@\n)@\n" form_instrs itb - | Restore (vars, var_params, evts, rb) -> + | Restore (vars, var_params, evts, evtfs, rb) -> let format_vars fmt = function | [] -> () | vars -> @@ -839,8 +841,17 @@ let rec format_instruction form_var form_err = (Pp.list_comma (Pp.unmark form_expr)) evts in - Format.fprintf fmt "restaure%a%a%a@;: apres (" format_vars vars - format_var_params var_params format_evts evts; + let format_evtfs fmt = function + | [] -> () + | evtfs -> + List.iter + (fun (v, e) -> + Format.fprintf fmt "@;: evenement %a : avec %a" + (Pp.unmark form_var) v (Pp.unmark form_expr) e) + evtfs + in + Format.fprintf fmt "restaure%a%a%a%a@;: apres (" format_vars vars + format_var_params var_params format_evts evts format_evtfs evtfs; Format.fprintf fmt "@[ %a@]@;)@;" form_instrs rb | ArrangeEvents (s, f, itb) -> Format.fprintf fmt "arrange_evenements@;:"; diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 00a84f60f..bb0f3e8b1 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -220,7 +220,7 @@ type 'v loop_variables = type unop = Not | Minus (** Binary operators *) -type binop = And | Or | Add | Sub | Mul | Div +type binop = And | Or | Add | Sub | Mul | Div | Mod (** Comparison operators *) type comp_op = Gt | Gte | Lt | Lte | Eq | Neq @@ -349,6 +349,7 @@ type ('v, 'e) instruction = 'v Pos.marked list * ('v Pos.marked * Pos.t CatVar.Map.t * 'v m_expression) list * 'v m_expression list + * ('v Pos.marked * 'v m_expression) list * ('v, 'e) m_instruction list | ArrangeEvents of ('v Pos.marked * 'v Pos.marked * 'v m_expression) option diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index ce1fcda49..3ea672f6f 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -286,15 +286,18 @@ let expand_functions (p : program) : program = in let instrs' = List.map map_instr instrs in (Iterate_values (v_id, var_intervals', instrs'), instr_pos) - | Restore (vars, var_params, evts, instrs) -> + | Restore (vars, var_params, evts, evtfs, instrs) -> let var_params' = List.map (fun (v, cs, e) -> (v, cs, expand_functions_expr e)) var_params in let evts' = List.map expand_functions_expr evts in + let evtfs' = + List.map (fun (v, e) -> (v, expand_functions_expr e)) evtfs + in let instrs' = List.map map_instr instrs in - (Restore (vars, var_params', evts', instrs'), instr_pos) + (Restore (vars, var_params', evts', evtfs', instrs'), instr_pos) | ArrangeEvents (sort, filter, instrs) -> let sort' = match sort with diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 05efa7e1e..6c3e1d422 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -350,6 +350,9 @@ struct | Div, Undefined, _ | Div, _, Undefined -> Undefined (* yes... *) | Div, _, l2 when is_zero l2 -> Number (N.zero ()) | Div, Number i1, Number i2 -> Number N.(i1 /. i2) + | Mod, Undefined, _ | Mod, _, Undefined -> Undefined (* yes... *) + | Mod, _, l2 when is_zero l2 -> Number (N.zero ()) + | Mod, Number i1, Number i2 -> Number N.(i1 %. i2) | And, Undefined, _ | And, _, Undefined -> Undefined | Or, Undefined, Undefined -> Undefined | Or, Undefined, Number i | Or, Number i, Undefined -> Number i @@ -796,7 +799,7 @@ struct | Undefined -> ()) | Undefined -> ()) var_intervals - | Com.Restore (vars, var_params, evts, stmts) -> + | Com.Restore (vars, var_params, evts, evtfs, stmts) -> let backup_vars = List.fold_left (fun backup_vars (m_v : Com.Var.t Pos.marked) -> @@ -844,7 +847,7 @@ struct (fun backup_evts expr -> match evaluate_expr ctx p expr with | Number z -> - let i = N.(to_int z) |> Int64.to_int in + let i = z |> N.to_int |> Int64.to_int in let events0 = List.hd ctx.ctx_events in if 0 <= i && i < Array.length events0 then let j = events0.(i) in @@ -854,6 +857,29 @@ struct | _ -> backup_evts) [] evts in + let backup_evts = + List.fold_left + (fun backup_evts ((m_var : Com.Var.t Pos.marked), expr) -> + let var = Pos.unmark m_var in + let var_i = + match var.loc with LocTmp (_, i) -> i | _ -> assert false + in + let events0 = List.hd ctx.ctx_events in + let rec aux backup_evts i = + if i < Array.length events0 then ( + let vi = i |> Int64.of_int |> N.of_int in + ctx.ctx_tmps.(ctx.ctx_tmps_org + var_i) <- Number vi; + match evaluate_expr ctx p expr with + | Number z when N.(z =. one ()) -> + let j = events0.(i) in + let evt = Array.copy ctx.ctx_event_tab.(j) in + aux ((j, evt) :: backup_evts) (i + 1) + | _ -> aux backup_evts (i + 1)) + else backup_evts + in + aux backup_evts 0) + backup_evts evtfs + in evaluate_stmts tn canBlock p ctx stmts; List.iter (fun ((v : Com.Var.t), i, value) -> diff --git a/src/mlang/m_ir/mir_number.ml b/src/mlang/m_ir/mir_number.ml index 5a3342699..589a261e3 100644 --- a/src/mlang/m_ir/mir_number.ml +++ b/src/mlang/m_ir/mir_number.ml @@ -61,6 +61,8 @@ module type NumberInterface = sig val ( *. ) : t -> t -> t + val ( %. ) : t -> t -> t + val min : t -> t -> t val max : t -> t -> t @@ -127,6 +129,8 @@ module RegularFloatNumber : NumberInterface = struct let ( *. ) x y = x *. y + let ( %. ) x y = mod_float x y + let min x y = min x y let max x y = max x y @@ -198,6 +202,11 @@ module MPFRNumber : NumberInterface = struct let ( *. ) x y = Mpfrf.mul x y rounding + let ( %. ) x y = + let d = x /. y in + let n = if d >=. zero () then floor d else ceil d in + x -. (n *. y) + let min x y = if x >. y then y else x let max x y = if x >. y then x else y @@ -314,6 +323,11 @@ module IntervalNumber : NumberInterface = struct let ( *. ) x y = v (Mpfrf.mul x.down y.down Down) (Mpfrf.mul x.up y.up Up) + let ( %. ) x y = + let d = x /. y in + let n = if d >=. zero () then floor d else ceil d in + x -. (n *. y) + let min x y = if x >. y then y else x let max x y = if x >. y then x else y @@ -374,6 +388,11 @@ module RationalNumber : NumberInterface = struct let ( *. ) x y = Mpqf.mul x y + let ( %. ) x y = + let d = x /. y in + let n = if d >=. zero () then floor d else ceil d in + x -. (n *. y) + let min x y = if x >. y then y else x let max x y = if x >. y then x else y @@ -467,6 +486,11 @@ end) : NumberInterface = struct let ( *. ) x y = Mpzf.tdiv_q (Mpzf.mul x y) (precision_modulo ()) + let ( %. ) x y = + let d = x /. y in + let n = if d >=. zero () then floor d else ceil d in + x -. (n *. y) + let is_zero x = x =. zero () let min x y = if x >. y then y else x diff --git a/src/mlang/m_ir/mir_number.mli b/src/mlang/m_ir/mir_number.mli index d9ce279f7..af66b405c 100644 --- a/src/mlang/m_ir/mir_number.mli +++ b/src/mlang/m_ir/mir_number.mli @@ -59,6 +59,8 @@ module type NumberInterface = sig val ( *. ) : t -> t -> t + val ( %. ) : t -> t -> t + val min : t -> t -> t val max : t -> t -> t From 1e016c2b7f5da42360d9d3ead685bcf0eeb237c3 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 30 Jan 2025 15:53:52 +0100 Subject: [PATCH 19/32] =?UTF-8?q?Am=C3=A9lioration=20de=20la=20lisibilit?= =?UTF-8?q?=C3=A9=20du=20code=20C?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 77 +++++------ src/mlang/backend_compilers/decoupledExpr.ml | 12 +- .../backend_compilers/dgfip_gen_files.ml | 24 ++-- src/mlang/backend_compilers/dgfip_varid.ml | 127 ++++++++++++------ 4 files changed, 146 insertions(+), 94 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index df214ab51..566d22891 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -403,7 +403,7 @@ let generate_expr_with_res_in dgfip_flags oc res_def res_val expr = let pr form = Format.fprintf oc form in let locals, set, def, value = D.build_expression @@ generate_c_expr expr in if D.is_always_true def then - pr "@;@[{@;%a@;%a@;%a@;%a@]@;}" D.format_local_declarations locals + pr "@;@[{%a%a%a%a@]@;}" D.format_local_declarations locals (D.format_set_vars dgfip_flags) set (D.format_assign dgfip_flags res_def) @@ -411,7 +411,7 @@ let generate_expr_with_res_in dgfip_flags oc res_def res_val expr = (D.format_assign dgfip_flags res_val) value else - pr "@;@[{@;%a@;%a@;%a@;@[if (%s) {%a@]@;} else %s = 0.0;@]@;}" + pr "@;@[{%a%a%a@;@[if (%s) {%a@]@;} else %s = 0.0;@]@;}" D.format_local_declarations locals (D.format_set_vars dgfip_flags) set @@ -443,7 +443,8 @@ let generate_var_def (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t) pr "@;@[{"; let idx = fresh_c_local "idx" in pr "@;int %s;" idx; - pr "@;@[for (%s = 0; %s < %s; %s++) {" idx idx size idx; + pr "@;@[@[for (%s = 0;@ %s < %s;@ %s++) {@]" idx idx size + idx; pr "%a" (generate_m_assign dgfip_flags var (GetValueExpr idx)) vexpr; pr "@]@;}"; pr "@]@;}") @@ -507,11 +508,11 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) let cond_val = cond ^ "_val" in pr "@;char %s;@;double %s;" cond_def cond_val; generate_expr_with_res_in dgfip_flags oc cond_def cond_val cond_expr; - pr "@;@[if (%s && (%s != 0.0)) {" cond_def cond_val; - pr "@;%a" (generate_stmts dgfip_flags program) iftrue; + pr "@;@[if (%s && %s != 0.0) {" cond_def cond_val; + pr "%a" (generate_stmts dgfip_flags program) iftrue; if iffalse <> [] then ( pr "@]@;@[} else if (%s) {" cond_def; - pr "@;%a" (generate_stmts dgfip_flags program) iffalse); + pr "%a" (generate_stmts dgfip_flags program) iffalse); pr "@]@;}"; pr "@]@;}" | WhenDoElse (wdl, ed) -> @@ -527,7 +528,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) generate_expr_with_res_in dgfip_flags oc cond_def cond_val expr; pr "@;@[if(%s) {" cond_def; pr "@;if (! %s) goto %s;" cond_val goto_label; - pr "@;%a" (generate_stmts dgfip_flags program) dl; + pr "%a" (generate_stmts dgfip_flags program) dl; pr "@]@;}"; aux l | [] -> () @@ -535,14 +536,14 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) aux wdl; pr "@;goto %s;" fin_label; pr "@;%s:" goto_label; - pr "@;%a" (generate_stmts dgfip_flags program) (Pos.unmark ed); + pr "%a" (generate_stmts dgfip_flags program) (Pos.unmark ed); pr "@;%s:{}" fin_label; pr "@]@;}" | VerifBlock stmts -> let goto_label = fresh_c_local "verif_block" in pr "@;@[{"; pr "@;if (setjmp(irdata->jmp_bloq) != 0) goto %s;" goto_label; - pr "@;%a" (generate_stmts dgfip_flags program) stmts; + pr "%a" (generate_stmts dgfip_flags program) stmts; pr "%s:;" goto_label; pr "@]@;}" | Print (std, args) -> @@ -625,7 +626,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;%s = %s;" ref_info (VID.gen_info_ptr v); pr "@;%s = %s;" ref_def (VID.gen_def_ptr v); pr "@;%s = %s;" ref_val (VID.gen_val_ptr v); - pr "@;%a" (generate_stmts dgfip_flags program) stmts; + pr "%a" (generate_stmts dgfip_flags program) stmts; pr "@]@;}") vars; List.iter @@ -648,7 +649,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;%s = &(%s[%s->idx]);" ref_val ref_tab ref_info; generate_expr_with_res_in dgfip_flags oc cond_def cond_val expr; pr "@;@[if (%s && %s != 0.0) {" cond_def cond_val; - pr "@;%a" (generate_stmts dgfip_flags program) stmts; + pr "%a" (generate_stmts dgfip_flags program) stmts; pr "@]@;}"; pr "@;tab_%s++;" it_name; pr "@;nb_%s++;" it_name; @@ -660,13 +661,13 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) let var = Pos.unmark m_var in let itval_def = VID.gen_def var "" in let itval_val = VID.gen_val var "" in - let itval_name = fresh_c_local "itval" in - let e0_def = Format.sprintf "%s_e0_def" itval_name in - let e0_val = Format.sprintf "%s_e0_val" itval_name in - let e1_def = Format.sprintf "%s_e1_def" itval_name in - let e1_val = Format.sprintf "%s_e1_val" itval_name in - let step_def = Format.sprintf "%s_step_def" itval_name in - let step_val = Format.sprintf "%s_step_val" itval_name in + let postfix = fresh_c_local "" in + let e0_def = Format.sprintf "e0_def%s" postfix in + let e0_val = Format.sprintf "e0_val%s" postfix in + let e1_def = Format.sprintf "e1_def%s" postfix in + let e1_val = Format.sprintf "e1_val%s" postfix in + let step_def = Format.sprintf "step_def%s" postfix in + let step_val = Format.sprintf "step_val%s" postfix in List.iter (fun (e0, e1, step) -> pr "@;@[{"; @@ -676,15 +677,15 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) generate_expr_with_res_in dgfip_flags oc e0_def e0_val e0; generate_expr_with_res_in dgfip_flags oc e1_def e1_val e1; generate_expr_with_res_in dgfip_flags oc step_def step_val step; - pr "@;@[if(%s && %s && %s && %s != 0.0){" e0_def e1_def step_def + pr "@;@[if(%s && %s && %s && %s != 0.0) {" e0_def e1_def step_def step_val; pr "@;\ - @[for (%s = 1, %s = %s; (%s > 0.0 ? %s <= %s : %s >= %s); %s \ - = %s + %s) {" + @[@[for (%s = 1,@ %s = %s;@ (%s > 0.0 ? %s <= %s : %s \ + >= %s);@ %s = %s + %s) {@]" itval_def itval_val e0_val step_val itval_val e1_val itval_val e1_val itval_val itval_val step_val; - pr "@;%a" (generate_stmts dgfip_flags program) stmts; + pr "%a" (generate_stmts dgfip_flags program) stmts; pr "@]@;}"; pr "@]@;}"; pr "@]@;}") @@ -743,12 +744,12 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;int i;"; pr "@;\ - @[for (width = 1; width < irdata->nb_events; width = 2 * \ - width) {"; + @[@[for (width = 1;@ width < irdata->nb_events;@ \ + width = 2 * width) {@]"; pr "@;\ - @[for (iLeft = 0; iLeft < irdata->nb_events; iLeft = iLeft + \ - 2 * width) {"; + @[@[for (iLeft = 0;@ iLeft < irdata->nb_events;@ \ + iLeft = iLeft + 2 * width) {@]"; pr "@;int iRight = iLeft + width;"; pr "@;int iEnd = iLeft + 2 * width;"; pr "@;if (iRight > irdata->nb_events) iRight = irdata->nb_events;"; @@ -757,7 +758,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;int i = iLeft;"; pr "@;int j = iRight;"; pr "@;int k;"; - pr "@;@[for (k = iLeft; k < iEnd; k++) {"; + pr "@;@[@[for (k = iLeft;@ k < iEnd;@ k++) {@]"; pr "@;int cpt = 0;"; pr "@;@[{"; (* Comparaison *) @@ -788,14 +789,14 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@]@;}"; pr "@]@;}"; pr "@]@;}"; - pr "@;@[for (i = 0; i < irdata->nb_events; i++) {"; + pr "@;@[@[for (i = 0;@ i < irdata->nb_events;@ i++) {@]"; pr "@;irdata->events[i] = b[i];"; pr "@]@;}"; pr "@]@;}"; pr "@;free(b);"; pr "@]@;}" | None -> ()); - pr "@;%a" (generate_stmts dgfip_flags program) stmts; + pr "%a" (generate_stmts dgfip_flags program) stmts; pr "@;free(irdata->events);"; pr "@;irdata->events = %s;" events_sav; pr "@;irdata->nb_events = %s;" nb_events_sav; @@ -836,7 +837,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;%s = &(D%s[%s->idx]);" ref_def ref_tab ref_info; pr "@;%s = &(%s[%s->idx]);" ref_val ref_tab ref_info; generate_expr_with_res_in dgfip_flags oc cond_def cond_val expr; - pr "@;@[if (%s && %s != 0.0){" cond_def cond_val; + pr "@;@[if (%s && %s != 0.0) {" cond_def cond_val; pr "@;env_sauvegarder(&%s, %s, %s, %s);" rest_name (VID.gen_def_ptr var) (VID.gen_val_ptr var) (VID.gen_size var); pr "@]@;}"; @@ -879,7 +880,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;%s = 1;" ref_def; pr "@;%s = (double)%s;" ref_val idx; generate_expr_with_res_in dgfip_flags oc cond_def cond_val expr; - pr "@;@[if (%s && %s != 0.0){" cond_def cond_val; + pr "@;@[if (%s && %s != 0.0) {" cond_def cond_val; pr "@;env_sauvegarder_evt(&%s, irdata->events[%s]);@;" rest_evt_name idx; pr "@]@;}"; @@ -887,7 +888,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@]@;}"; pr "@]@;}") evtfs; - pr "@;%a" (generate_stmts dgfip_flags program) stmts; + pr "%a" (generate_stmts dgfip_flags program) stmts; pr "@;env_restaurer(&%s);@;" rest_name; pr "@;env_restaurer_evt(&%s);@;" rest_evt_name; pr "@]@;}" @@ -907,7 +908,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) and generate_stmts (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (oc : Format.formatter) (stmts : Mir.m_instruction list) = - Format.pp_print_list (generate_stmt dgfip_flags program) oc stmts + List.iter (generate_stmt dgfip_flags program oc) stmts let generate_var_tmp_decls (oc : Format.formatter) (tf : Mir.target_data) = let pr fmt = Format.fprintf oc fmt in @@ -915,7 +916,7 @@ let generate_var_tmp_decls (oc : Format.formatter) (tf : Mir.target_data) = pr "@;@[{"; pr "@;int i;"; pr "@;T_varinfo *info;"; - pr "@;@[for (i = 0; i < %d; i++) {" tf.target_sz_tmps; + pr "@;@[@[for (i = 0;@ i < %d;@ i++) {@]" tf.target_sz_tmps; pr "@;irdata->def_tmps[irdata->tmps_org + i] = 0;"; pr "@;irdata->tmps[irdata->tmps_org + i] = 0.0;"; pr "@]@;}"; @@ -956,7 +957,7 @@ let generate_function (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (oc : Format.formatter) (fn : string) = let pr fmt = Format.fprintf oc fmt in let fd = Com.TargetMap.find fn program.program_functions in - pr "@;@[%a {" (generate_function_prototype false) fd; + pr "@.@[%a {" (generate_function_prototype false) fd; pr "%a" generate_var_tmp_decls fd; pr "@;"; if dgfip_flags.flg_trace then pr "@;aff1(\"debut %s\\n\");" fn; @@ -968,7 +969,7 @@ let generate_function (dgfip_flags : Dgfip_options.flags) if fd.target_sz_tmps > 0 then pr "@;irdata->tmps_org = irdata->tmps_org - %d;" fd.target_sz_tmps; pr "@;return 1;"; - pr "@]@;}@;" + pr "@]@;}@." let generate_functions (dgfip_flags : Dgfip_options.flags) (program : Mir.program) @@ -990,7 +991,7 @@ let generate_target (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (oc : Format.formatter) (f : string) = let pr fmt = Format.fprintf oc fmt in let tf = Com.TargetMap.find f program.program_targets in - pr "@;@[%a {" (generate_target_prototype false) f; + pr "@.@[%a {" (generate_target_prototype false) f; pr "%a" generate_var_tmp_decls tf; pr "@;"; if dgfip_flags.flg_trace then pr "@;aff1(\"debut %s\\n\");" f; @@ -1002,7 +1003,7 @@ let generate_target (dgfip_flags : Dgfip_options.flags) (program : Mir.program) if tf.target_sz_tmps > 0 then pr "@;irdata->tmps_org = irdata->tmps_org - %d;" tf.target_sz_tmps; pr "@;return irdata->discords;"; - pr "@]@;}@;" + pr "@]@;}@." let generate_targets (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (filemap : (out_channel * Format.formatter) StrMap.t) = diff --git a/src/mlang/backend_compilers/decoupledExpr.ml b/src/mlang/backend_compilers/decoupledExpr.ml index 999b3ee51..3a68ae2d2 100644 --- a/src/mlang/backend_compilers/decoupledExpr.ml +++ b/src/mlang/backend_compilers/decoupledExpr.ml @@ -533,10 +533,10 @@ let rec format_dexpr (dgfip_flags : Dgfip_options.flags) fmt (de : expr) = let rec format_local_declarations fmt ((def_stk_size, val_stk_size) : local_decls) = if def_stk_size >= 0 then ( - Format.fprintf fmt "@[register int int%d;@]@," def_stk_size; + Format.fprintf fmt "@;@[register int int%d;@]" def_stk_size; format_local_declarations fmt (def_stk_size - 1, val_stk_size)) else if val_stk_size >= 0 then ( - Format.fprintf fmt "@[register double real%d;@]@," val_stk_size; + Format.fprintf fmt "@;@[register double real%d;@]" val_stk_size; format_local_declarations fmt (def_stk_size, val_stk_size - 1)) else () @@ -544,14 +544,14 @@ let format_local_vars_defs (dgfip_flags : Dgfip_options.flags) fmt (lv : local_vars) = let lv = List.rev lv in let format_one_assign fmt (_, { slot; subexpr }) = - Format.fprintf fmt "@[%a =@ %a;@]@," format_slot slot + Format.fprintf fmt "@;@[%a =@ %a;@]" format_slot slot (format_dexpr dgfip_flags) subexpr in List.iter (format_one_assign fmt) lv let format_assign (dgfip_flags : Dgfip_options.flags) (var : string) fmt ((e, _kind, lv) : t) = - Format.fprintf fmt "%a@[%s =@ %a;@]" + Format.fprintf fmt "%a@;@[%s =@ %a;@]" (format_local_vars_defs dgfip_flags) lv var (format_dexpr dgfip_flags) e @@ -559,9 +559,9 @@ let format_set_vars (dgfip_flags : Dgfip_options.flags) fmt (set_vars : (dflag * string * t) list) = List.iter (fun ((kd, vn, _expr) : dflag * string * t) -> - Pp.fpr fmt "%s %s;@;" (match kd with Def -> "char" | Val -> "double") vn) + Pp.fpr fmt "@;%s %s;" (match kd with Def -> "char" | Val -> "double") vn) set_vars; List.iter (fun ((_kd, vn, expr) : dflag * string * t) -> - Pp.fpr fmt "%a@;" (format_assign dgfip_flags vn) expr) + format_assign dgfip_flags vn fmt expr) set_vars diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index 57af5d774..34edf101f 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -404,18 +404,24 @@ typedef struct S_irdata T_irdata; cprog.program_event_fields; Format.fprintf fmt {| -#define S_ irdata->saisie -#define C_ irdata->calculee -#define B_ irdata->base -/*#define T_ irdata->tmps*/ -/*#define R_ irdata->ref*/ #define DS_ irdata->def_saisie +#define S_ irdata->saisie + #define DC_ irdata->def_calculee +#define C_ irdata->calculee + #define DB_ irdata->def_base -/*#define DT_ irdata->def_tmps*/ -/*#define DR_ irdata->def_ref*/ -/*#define IT_ irdata->info_tmps*/ -/*#define IR_ irdata->info_ref*/ +#define B_ irdata->base + +#define I_(cat,idx) ((T_varinfo *)&(varinfo_##cat[idx])) + +#define DT_(idx) (irdata->def_tmps[irdata->tmps_org + (idx)]) +#define T_(idx) (irdata->tmps[irdata->tmps_org + (idx)]) +#define IT_(idx) (&(irdata->info_tmps[irdata->tmps_org + (idx)])) + +#define DR_(idx) (irdata->def_ref[irdata->ref_org + (idx)]) +#define R_(idx) (irdata->ref[irdata->ref_org + (idx)]) +#define IR_(idx) (irdata->info_ref[irdata->ref_org + (idx)]) #define EST_SAISIE 0x00000 #define EST_CALCULEE 0x04000 diff --git a/src/mlang/backend_compilers/dgfip_varid.ml b/src/mlang/backend_compilers/dgfip_varid.ml index 4d73354d9..aeda77f22 100644 --- a/src/mlang/backend_compilers/dgfip_varid.ml +++ b/src/mlang/backend_compilers/dgfip_varid.ml @@ -14,72 +14,117 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) +(* TGV variables accessors *) + let gen_tab = function | Com.CatVar.LocComputed -> "C_" | Com.CatVar.LocBase -> "B_" | Com.CatVar.LocInput -> "S_" -let gen_tgv pre (l : Com.loc_tgv) vn off = - Printf.sprintf "%s%s[%d/*%s*/%s]" pre (gen_tab l.loc_cat) l.loc_idx vn off +let gen_tgv_def (l : Com.loc_tgv) vn off = + Pp.spr "D%s[%d/*%s*/%s]" (gen_tab l.loc_cat) l.loc_idx vn off + +let gen_tgv_val (l : Com.loc_tgv) vn off = + Pp.spr "%s[%d/*%s*/%s]" (gen_tab l.loc_cat) l.loc_idx vn off + +let gen_tgv_def_ptr (l : Com.loc_tgv) vn = + Pp.spr "(D%s + (%d)/*%s*/)" (gen_tab l.loc_cat) l.loc_idx vn + +let gen_tgv_val_ptr (l : Com.loc_tgv) vn = + Pp.spr "(%s + (%d)/*%s*/)" (gen_tab l.loc_cat) l.loc_idx vn + +let gen_tgv_info_ptr (l : Com.loc_tgv) vn = + Pp.spr "I_(%s,%d/*%s*/)" l.loc_cat_str l.loc_cat_idx vn + +(* temporary variables accessors *) + +let gen_tmp_def i vn off = Pp.spr "DT_((%d)/*%s*/%s)" i vn off + +let gen_tmp_val i vn off = Pp.spr "T_((%d)/*%s*/%s)" i vn off + +let gen_tmp_def_ptr i vn = Pp.spr "&(%s)" (gen_tmp_def i vn "") + +let gen_tmp_val_ptr i vn = Pp.spr "&(%s)" (gen_tmp_val i vn "") + +let gen_tmp_info_ptr i vn = Pp.spr "IT_((%d)/*%s*/)" i vn + +(* reference accessors *) -let gen_tgv_ptr pre (l : Com.loc_tgv) vn = - Printf.sprintf "(%s%s + (%d)/*%s*/)" pre (gen_tab l.loc_cat) l.loc_idx vn +let gen_ref_def_ptr i vn = Printf.sprintf "DR_((%d)/*%s*/)" i vn -let gen_tmp pre i vn off = - Printf.sprintf "irdata->%stmps[irdata->tmps_org + (%d)/*%s*/%s]" pre i vn off +let gen_ref_val_ptr i vn = Printf.sprintf "R_((%d)/*%s*/)" i vn -let gen_tmp_ptr pre i vn = Printf.sprintf "&(%s)" (gen_tmp pre i vn "") +let gen_ref_info_ptr i vn = Printf.sprintf "IR_((%d)/*%s*/)" i vn -let gen_ref_ptr pre i vn = - Printf.sprintf "irdata->%sref[irdata->ref_org + (%d)/*%s*/]" pre i vn +let gen_ref_def i vn off = Pp.spr "*(%s%s)" (gen_ref_def_ptr i vn) off -let gen_ref pre i vn off = Printf.sprintf "*(%s%s)" (gen_ref_ptr pre i vn) off +let gen_ref_val i vn off = Pp.spr "*(%s%s)" (gen_ref_val_ptr i vn) off + +(* arguments accessors *) + +let gen_arg_def i = Pp.spr "def_arg%d" i + +let gen_arg_val i = Pp.spr "val_arg%d" i + +let gen_arg_def_ptr i = Pp.spr "(&def_arg%d)" i + +let gen_arg_val_ptr i = Pp.spr "(&val_arg%d)" i + +(* result accessors *) + +let gen_res_def () = Pp.spr "(*def_res)" + +let gen_res_val () = Pp.spr "(*val_res)" + +let gen_res_def_ptr () = Pp.spr "def_res" + +let gen_res_val_ptr () = Pp.spr "val_res" + +(* generic accessors *) let gen_def (v : Com.Var.t) offset = let vn = Pos.unmark v.name in match v.loc with - | LocTgv (_, l) -> gen_tgv "D" l vn offset - | LocTmp (_, i) -> gen_tmp "def_" i vn offset - | LocRef (_, i) -> gen_ref "def_" i vn offset - | LocArg (_, i) -> Pp.spr "def_arg%d" i - | LocRes _ -> Pp.spr "(*def_res)" + | LocTgv (_, l) -> gen_tgv_def l vn offset + | LocTmp (_, i) -> gen_tmp_def i vn offset + | LocRef (_, i) -> gen_ref_def i vn offset + | LocArg (_, i) -> gen_arg_def i + | LocRes _ -> gen_res_def () let gen_val (v : Com.Var.t) offset = let vn = Pos.unmark v.name in match v.loc with - | LocTgv (_, l) -> gen_tgv "" l vn offset - | LocTmp (_, i) -> gen_tmp "" i vn offset - | LocRef (_, i) -> gen_ref "" i vn offset - | LocArg (_, i) -> Pp.spr "val_arg%d" i - | LocRes _ -> Pp.spr "(*val_res)" + | LocTgv (_, l) -> gen_tgv_val l vn offset + | LocTmp (_, i) -> gen_tmp_val i vn offset + | LocRef (_, i) -> gen_ref_val i vn offset + | LocArg (_, i) -> gen_arg_val i + | LocRes _ -> gen_res_val () let gen_info_ptr (v : Com.Var.t) = let vn = Pos.unmark v.name in match v.loc with - | LocTgv (_, l) -> - Printf.sprintf "((T_varinfo *)&(varinfo_%s[%d]/*%s*/))" l.loc_cat_str - l.loc_cat_idx vn - | LocTmp (_, i) -> gen_tmp_ptr "info_" i vn - | LocRef (_, i) -> gen_ref_ptr "info_" i vn + | LocTgv (_, l) -> gen_tgv_info_ptr l vn + | LocTmp (_, i) -> gen_tmp_info_ptr i vn + | LocRef (_, i) -> gen_ref_info_ptr i vn | LocArg _ | LocRes _ -> "NULL" let gen_def_ptr (v : Com.Var.t) = let vn = Pos.unmark v.name in match v.loc with - | LocTgv (_, l) -> gen_tgv_ptr "D" l vn - | LocTmp (_, i) -> gen_tmp_ptr "def_" i vn - | LocRef (_, i) -> gen_ref_ptr "def_" i vn - | LocArg (_, i) -> Pp.spr "(&def_arg%d)" i - | LocRes _ -> Pp.spr "def_res" + | LocTgv (_, l) -> gen_tgv_def_ptr l vn + | LocTmp (_, i) -> gen_tmp_def_ptr i vn + | LocRef (_, i) -> gen_ref_def_ptr i vn + | LocArg (_, i) -> gen_arg_def_ptr i + | LocRes _ -> gen_res_def_ptr () let gen_val_ptr (v : Com.Var.t) = let vn = Pos.unmark v.name in match v.loc with - | LocTgv (_, l) -> gen_tgv_ptr "" l vn - | LocTmp (_, i) -> gen_tmp_ptr "" i vn - | LocRef (_, i) -> gen_ref_ptr "" i vn - | LocArg (_, i) -> Pp.spr "(&val_arg%d)" i - | LocRes _ -> Pp.spr "val_res" + | LocTgv (_, l) -> gen_tgv_val_ptr l vn + | LocTmp (_, i) -> gen_tmp_val_ptr i vn + | LocRef (_, i) -> gen_ref_val_ptr i vn + | LocArg (_, i) -> gen_arg_val_ptr i + | LocRes _ -> gen_res_val_ptr () let gen_pos_from_start (v : Com.Var.t) = let vn = Pos.unmark v.name in @@ -92,16 +137,16 @@ let gen_pos_from_start (v : Com.Var.t) = | Com.CatVar.LocInput -> "EST_SAISIE" in Printf.sprintf "%s | %d" loc_tab l.loc_idx - | LocTmp (_, i) -> Printf.sprintf "EST_TEMPORAIRE | %d" i + | LocTmp (_, i) -> Pp.spr "EST_TEMPORAIRE | %d" i | LocRef (_, i) -> - let info = gen_ref_ptr "info_" i vn in + let info = gen_ref_info_ptr i vn in Printf.sprintf "%s->loc_cat | %s->idx" info info - | LocArg (_, i) -> Printf.sprintf "EST_ARGUMENT | %d" i - | LocRes _ -> Printf.sprintf "EST_RESULTAT | 0" + | LocArg (_, i) -> Pp.spr "EST_ARGUMENT | %d" i + | LocRes _ -> Pp.spr "EST_RESULTAT | 0" let gen_size (v : Com.Var.t) = let vn = Pos.unmark v.name in match v.loc with - | LocTgv _ | LocTmp _ -> Format.sprintf "%d" (Com.Var.size v) - | LocRef (_, i) -> Format.sprintf "(%s->size)" (gen_ref_ptr "info_" i vn) + | LocTgv _ | LocTmp _ -> Pp.spr "%d" (Com.Var.size v) + | LocRef (_, i) -> Pp.spr "(%s->size)" (gen_ref_info_ptr i vn) | LocArg _ | LocRes _ -> "1" From 3bbc9bff77d97b1463ffe81f35f5a15a9676f94b Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 30 Jan 2025 18:05:38 +0100 Subject: [PATCH 20/32] =?UTF-8?q?Ajout=20d'=C3=A9v=C3=A9nements=20(instabl?= =?UTF-8?q?e)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2023/cibles.m | 1 + src/mlang/backend_compilers/bir_to_dgfip_c.ml | 18 ++-- src/mlang/m_frontend/check_validity.ml | 31 +++++-- src/mlang/m_frontend/expand_macros.ml | 11 ++- src/mlang/m_frontend/mast_to_mir.ml | 5 +- src/mlang/m_frontend/mlexer.mll | 1 + src/mlang/m_frontend/mparser.mly | 36 +++++--- src/mlang/m_ir/com.ml | 6 +- src/mlang/m_ir/com.mli | 1 + src/mlang/m_ir/mir.ml | 5 +- src/mlang/m_ir/mir_interpreter.ml | 90 +++++++++++++------ src/mlang/m_ir/mir_interpreter.mli | 3 +- src/mlang/utils/sorting.ml | 29 +++--- src/mlang/utils/sorting.mli | 3 +- 14 files changed, 163 insertions(+), 77 deletions(-) diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index d43875129..4597ef445 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -885,6 +885,7 @@ si nb_evenements() > 0 alors et champ_evenement(I, montant) <= champ_evenement(J, montant) ) : filtrer I : avec 32 <= champ_evenement(I, rappel) et champ_evenement(I, rappel) <= 55 +: ajouter 3 : dans ( calculer cible afficher_evenements; ) diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index 566d22891..5098324e0 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -690,7 +690,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@]@;}"; pr "@]@;}") var_intervals - | ArrangeEvents (sort, filter, stmts) -> + | ArrangeEvents (sort, filter, add, stmts) -> let events_sav = fresh_c_local "events_sav" in let events_tmp = fresh_c_local "events_tmp" in let nb_events_sav = fresh_c_local "nb_events_sav" in @@ -735,6 +735,8 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) | Some (m_var0, m_var1, expr) -> pr "@;/* merge sort */"; pr "@;@[{"; + pr "@;int aBeg = 0;"; + pr "@;int aEnd = irdata->nb_events;"; pr "@;\ T_event **b = (T_event **)malloc(irdata->nb_events * (sizeof \ @@ -744,16 +746,16 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;int i;"; pr "@;\ - @[@[for (width = 1;@ width < irdata->nb_events;@ \ - width = 2 * width) {@]"; + @[@[for (width = 1;@ width < aEnd;@ width = 2 * \ + width) {@]"; pr "@;\ - @[@[for (iLeft = 0;@ iLeft < irdata->nb_events;@ \ - iLeft = iLeft + 2 * width) {@]"; + @[@[for (iLeft = aBeg;@ iLeft < aEnd;@ iLeft = iLeft \ + + 2 * width) {@]"; pr "@;int iRight = iLeft + width;"; pr "@;int iEnd = iLeft + 2 * width;"; - pr "@;if (iRight > irdata->nb_events) iRight = irdata->nb_events;"; - pr "@;if (iEnd > irdata->nb_events) iEnd = irdata->nb_events;"; + pr "@;if (iRight > aEnd) iRight = aEnd;"; + pr "@;if (iEnd > aEnd) iEnd = aEnd;"; pr "@;@[{"; pr "@;int i = iLeft;"; pr "@;int j = iRight;"; @@ -789,7 +791,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@]@;}"; pr "@]@;}"; pr "@]@;}"; - pr "@;@[@[for (i = 0;@ i < irdata->nb_events;@ i++) {@]"; + pr "@;@[@[for (i = aBeg;@ i < aEnd;@ i++) {@]"; pr "@;irdata->events[i] = b[i];"; pr "@]@;}"; pr "@]@;}"; diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index 34f49cc70..7183020c2 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -319,6 +319,10 @@ module Err = struct let unknown_event_field name pos = let msg = Format.asprintf "unknown event field \"%s\"" name in Errors.raise_spanned_error msg pos + + let event_field_need_a_variable name pos = + let msg = Format.asprintf "event field \"%s\" require a variable" name in + Errors.raise_spanned_error msg pos end type syms = Com.DomainId.t Pos.marked Com.DomainIdMap.t @@ -1475,7 +1479,7 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) Com.Restore (vars, var_params, evts, evtfs, res_instrs) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il - | Com.ArrangeEvents (sort, filter, instrs) -> + | Com.ArrangeEvents (sort, filter, add, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; (match sort with | Some (var0, var1, expr) -> @@ -1503,11 +1507,14 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) in ignore (check_expression false expr env) | None -> ()); + (match add with + | Some expr -> ignore (check_expression false expr env) + | None -> ()); let prog, res_instrs, _in_instrs, _out_instrs = check_instructions instrs is_rule env in let env = { env with prog } in - let res_instr = Com.ArrangeEvents (sort, filter, res_instrs) in + let res_instr = Com.ArrangeEvents (sort, filter, add, res_instrs) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il | Com.RaiseError (m_err, m_var_opt) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; @@ -2567,7 +2574,7 @@ let complete_vars_stack (prog : program) : program = | Com.Restore (_, _, _, _, instrs) -> let nbRef, nbIt = aux_instrs instrs in (max nbRef 1, nbIt) - | Com.ArrangeEvents (sort, filter, instrs) -> + | Com.ArrangeEvents (sort, filter, _, instrs) -> let nbItSort = match sort with Some _ -> 2 | None -> 0 in let nbItFilter = match filter with Some _ -> 1 | None -> 0 in let nbRef, nbIt = aux_instrs instrs in @@ -2739,7 +2746,7 @@ let complete_vars_stack (prog : program) : program = (* ??? *) let nbRef = 1 + (max nbRef @@ max nbRef' @@ max nbRef'' nbRef''') in (nb, sz, nbRef, tdata) - | Com.ArrangeEvents (sort, filter, instrs) -> + | Com.ArrangeEvents (sort, filter, add, instrs) -> let n', (nb', sz', nbRef', tdata) = match sort with | Some (_, _, expr) -> (2, aux_expr tdata expr) @@ -2750,10 +2757,15 @@ let complete_vars_stack (prog : program) : program = | Some (_, expr) -> (1, aux_expr tdata expr) | None -> (0, (0, 0, 0, tdata)) in + let nb''', sz''', nbRef''', tdata = + match add with + | Some expr -> aux_expr tdata expr + | None -> (0, 0, 0, tdata) + in let nb, sz, nbRef, tdata = aux_instrs tdata instrs in - let nb = max n' n'' + (max nb @@ max nb' nb'') in - let sz = max n' n'' + (max sz @@ max sz' sz'') in - let nbRef = max nbRef @@ max nbRef' nbRef'' in + let nb = max n' n'' + (max nb @@ max nb' @@ max nb'' nb''') in + let sz = max n' n'' + (max sz @@ max sz' @@ max sz'' sz''') in + let nbRef = max nbRef @@ max nbRef' @@ max nbRef'' nbRef''' in (nb, sz, nbRef, tdata) | Com.RaiseError _ | Com.CleanErrors | Com.ExportErrors | Com.FinalizeErrors -> @@ -2849,6 +2861,11 @@ let proceed (p : Mast.program) (main_target : string) : program = (empty_program p main_target) p in + StrMap.iter + (fun name (ef : Com.event_field) -> + if ef.is_var && StrMap.cardinal prog.prog_vars = 0 then + Err.event_field_need_a_variable name (Pos.get_position ef.name)) + prog.prog_event_fields; prog |> complete_rdom_decls |> complete_vdom_decls |> convert_rules |> complete_rule_domains |> complete_chainings |> convert_verifs |> complete_verif_calls |> complete_vars |> complete_vars_stack diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index 88f2a84a6..e8bfc2559 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -762,7 +762,7 @@ let rec expand_instruction (const_map : const_context) let instrs' = expand_instructions const_map instrs in (Com.Restore (vars, var_params', evts', evtfs', instrs'), instr_pos) :: prev - | Com.ArrangeEvents (sort, filter, instrs) -> + | Com.ArrangeEvents (sort, filter, add, instrs) -> let sort' = match sort with | Some (var0, var1, expr) -> @@ -777,8 +777,15 @@ let rec expand_instruction (const_map : const_context) Some (var, expr') | None -> None in + let add' = + match add with + | Some expr -> + let expr' = expand_expression const_map ParamsMap.empty expr in + Some expr' + | None -> None + in let instrs' = expand_instructions const_map instrs in - (Com.ArrangeEvents (sort', filter', instrs'), instr_pos) :: prev + (Com.ArrangeEvents (sort', filter', add', instrs'), instr_pos) :: prev | Com.VerifBlock instrs -> let instrs' = expand_instructions const_map instrs in (Com.VerifBlock instrs', instr_pos) :: prev diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index f9634750d..6a235390f 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -402,7 +402,7 @@ let rec translate_prog (p : Check_validity.program) ((Com.Restore (vars', var_params', evts', evtfs', prog_rest), pos) :: res) il - | (Com.ArrangeEvents (sort, filter, instrs), pos) :: il -> + | (Com.ArrangeEvents (sort, filter, add, instrs), pos) :: il -> let sort', itval_depth' = match sort with | Some (var0, var1, expr) -> @@ -467,8 +467,9 @@ let rec translate_prog (p : Check_validity.program) (Some (m_var, expr'), max itval_depth' (itval_depth + 1)) | None -> (None, itval_depth') in + let add' = Option.map (translate_expression p var_data) add in let instrs' = translate_prog p var_data it_depth itval_depth' instrs in - aux ((Com.ArrangeEvents (sort', filter', instrs'), pos) :: res) il + aux ((Com.ArrangeEvents (sort', filter', add', instrs'), pos) :: res) il | (Com.RaiseError (err_name, var_opt), pos) :: il -> let err_decl = StrMap.find (Pos.unmark err_name) p.prog_errors in let m_err_decl = Pos.same_pos_as err_decl err_name in diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index 71a801792..4fb898efc 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -63,6 +63,7 @@ rule token = parse | "REEL" -> REAL | "afficher" -> PRINT | "afficher_erreur" -> PRINT_ERR + | "ajouter" -> ADD | "alias" -> ALIAS | "alors" -> THEN | "anomalie" -> ANOMALY diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 463d205d2..ec102592b 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -58,7 +58,7 @@ along with this program. If not, see . %token INFORMATIVE OUTPUT FONCTION VARIABLE VARIABLES ATTRIBUT %token BASE GIVEN_BACK COMPUTABLE BY_DEFAULT %token DOMAIN SPECIALIZE AUTHORIZE VERIFIABLE -%token EVENT EVENTS VALUE STEP EVENT_FIELD ARRANGE_EVENTS SORT FILTER +%token EVENT EVENTS VALUE STEP EVENT_FIELD ARRANGE_EVENTS SORT FILTER ADD %token EOF @@ -728,12 +728,14 @@ instruction: | ARRANGE_EVENTS COLON arr_params = nonempty_list(with_pos(arrange_events_param)) IN LPAREN instrs = instruction_list_rev RPAREN { - let sort, filter = - let fold (sort, sort_pos, filter, filter_pos) = function + let sort, filter, add = + let fold (sort, sort_pos, filter, filter_pos, add, add_pos) = function | (`ArrangeEventsSort (v0, v1, e), pos) when sort = None -> - (Some (v0, v1, e), pos, filter, filter_pos) + (Some (v0, v1, e), pos, filter, filter_pos, add, add_pos) | (`ArrangeEventsFilter (v, e), pos) when filter = None -> - (sort, sort_pos, Some (v, e), pos) + (sort, sort_pos, Some (v, e), pos, add, add_pos) + | (`ArrangeEventsAdd e, pos) when add = None -> + (sort, sort_pos, filter, filter_pos, Some e, pos) | (`ArrangeEventsSort _, pos) -> let msg = Format.asprintf @@ -748,17 +750,24 @@ instruction: Pos.format_position sort_pos in Errors.raise_spanned_error msg pos + | (`ArrangeEventsAdd _, pos) -> + let msg = + Format.asprintf + "event creation already specified at %a" + Pos.format_position add_pos + in + Errors.raise_spanned_error msg pos in - let sort, _, filter, _ = - List.fold_left fold (None, Pos.no_pos, None, Pos.no_pos) arr_params + let sort, _, filter, _, add, _ = + List.fold_left fold (None, Pos.no_pos, None, Pos.no_pos, None, Pos.no_pos) arr_params in - match sort, filter with - | None, None -> - let msg = "event organizer needs a sort or a filter specification" in + match sort, filter, add with + | None, None, None -> + let msg = "event organizer needs a sort, a filter or a creation specification" in Errors.raise_spanned_error msg (mk_position $sloc) - | _, _ -> sort, filter + | _, _, _ -> sort, filter, add in - Some (ArrangeEvents (sort, filter, List.rev instrs)) + Some (ArrangeEvents (sort, filter, add, List.rev instrs)) } | RAISE_ERROR e_name = symbol_with_pos var = with_pos(variable_name)? SEMICOLON { Some (RaiseError (e_name, var)) @@ -941,6 +950,9 @@ arrange_events_param: let var = Pos.same_pos_as (Normal (Pos.unmark v)) v in `ArrangeEventsFilter (var, expr) } +| ADD expr = with_pos(expression) COLON { + `ArrangeEventsAdd (expr) + } formula_kind: | f = formula { SingleFormula f } diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index c75a7a2fb..0e0ab707a 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -501,6 +501,7 @@ type ('v, 'e) instruction = | ArrangeEvents of ('v Pos.marked * 'v Pos.marked * 'v m_expression) option * ('v Pos.marked * 'v m_expression) option + * 'v m_expression option * ('v, 'e) m_instruction list | RaiseError of 'e Pos.marked * string Pos.marked option | CleanErrors @@ -853,7 +854,7 @@ let rec format_instruction form_var form_err = Format.fprintf fmt "restaure%a%a%a%a@;: apres (" format_vars vars format_var_params var_params format_evts evts format_evtfs evtfs; Format.fprintf fmt "@[ %a@]@;)@;" form_instrs rb - | ArrangeEvents (s, f, itb) -> + | ArrangeEvents (s, f, a, itb) -> Format.fprintf fmt "arrange_evenements@;:"; (match s with | Some (v0, v1, e) -> @@ -865,6 +866,9 @@ let rec format_instruction form_var form_err = Format.fprintf fmt "filter %a : avec %a@;" form_var (Pos.unmark v) form_expr (Pos.unmark e) | None -> ()); + (match a with + | Some e -> Format.fprintf fmt "ajouter %a@;" form_expr (Pos.unmark e) + | None -> ()); Format.fprintf fmt ": dans (@[ %a@]@\n)@\n" form_instrs itb | RaiseError (err, var_opt) -> Format.fprintf fmt "leve_erreur %a %s\n" form_err (Pos.unmark err) diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index bb0f3e8b1..abc9b282f 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -354,6 +354,7 @@ type ('v, 'e) instruction = | ArrangeEvents of ('v Pos.marked * 'v Pos.marked * 'v m_expression) option * ('v Pos.marked * 'v m_expression) option + * 'v m_expression option * ('v, 'e) m_instruction list | RaiseError of 'e Pos.marked * string Pos.marked option | CleanErrors diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 3ea672f6f..2c236af4a 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -298,7 +298,7 @@ let expand_functions (p : program) : program = in let instrs' = List.map map_instr instrs in (Restore (vars, var_params', evts', evtfs', instrs'), instr_pos) - | ArrangeEvents (sort, filter, instrs) -> + | ArrangeEvents (sort, filter, add, instrs) -> let sort' = match sort with | Some (var0, var1, expr) -> @@ -313,8 +313,9 @@ let expand_functions (p : program) : program = Some (var, expr') | None -> None in + let add' = Option.map expand_functions_expr add in let instrs' = List.map map_instr instrs in - (ArrangeEvents (sort', filter', instrs'), instr_pos) + (ArrangeEvents (sort', filter', add', instrs'), instr_pos) | RaiseError _ | CleanErrors | ExportErrors | FinalizeErrors -> m_instr | ComputeDomain _ | ComputeChaining _ | ComputeVerifs _ -> assert false in diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 6c3e1d422..5bc82e11e 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -47,8 +47,7 @@ module type S = sig mutable ctx_nb_bloquantes : int; mutable ctx_finalized_anos : (Com.Error.t * string option) list; mutable ctx_exported_anos : (Com.Error.t * string option) list; - mutable ctx_event_tab : (value, Com.Var.t) Com.event_value Array.t Array.t; - mutable ctx_events : int Array.t list; + mutable ctx_events : (value, Com.Var.t) Com.event_value Array.t Array.t list; } val empty_ctx : Mir.program -> ctx @@ -131,8 +130,7 @@ struct mutable ctx_nb_bloquantes : int; mutable ctx_finalized_anos : (Com.Error.t * string option) list; mutable ctx_exported_anos : (Com.Error.t * string option) list; - mutable ctx_event_tab : (value, Com.Var.t) Com.event_value Array.t Array.t; - mutable ctx_events : int Array.t list; + mutable ctx_events : (value, Com.Var.t) Com.event_value Array.t Array.t list; } let empty_ctx (p : Mir.program) : ctx = @@ -157,7 +155,6 @@ struct ctx_nb_bloquantes = 0; ctx_finalized_anos = []; ctx_exported_anos = []; - ctx_event_tab = [||]; ctx_events = []; } @@ -197,7 +194,7 @@ struct Errors.raise_error (Format.sprintf "Too much event fields: index %d for size %d" (nbEvtFields - 1) nbProgFields); - let map = Array.make nbEvtFields (Com.Numeric Undefined) in + let map = Array.make nbProgFields (Com.Numeric Undefined) in let iter id ev = match IntMap.find_opt id p.program_event_field_idxs with | Some fname -> ( @@ -243,8 +240,7 @@ struct Format.eprintf " %a%a@." pp_field s pp_ev map.(j) done done; - ctx.ctx_event_tab <- ctx_event_tab; - ctx.ctx_events <- [ Array.init nbEvt Fun.id ] + ctx.ctx_events <- [ ctx_event_tab ] type run_error = | NanOrInf of string * Mir.expression Pos.marked @@ -520,7 +516,7 @@ struct let i = Int64.to_int N.(to_int z) in let events = List.hd ctx.ctx_events in if 0 <= i && i < Array.length events then - match ctx.ctx_event_tab.(events.(i)).(j) with + match events.(i).(j) with | Com.Numeric v -> v | Com.RefVar var -> get_var_value ctx var 0 else Undefined @@ -623,13 +619,13 @@ struct let i = Int64.to_int N.(to_int z) in let events = List.hd ctx.ctx_events in if 0 <= i && i < Array.length events then - match ctx.ctx_event_tab.(events.(i)).(j) with + match events.(i).(j) with | Com.RefVar var -> let vari = get_var ctx var in set_var_value p ctx vari expr | Com.Numeric _ -> let value = evaluate_expr ctx p expr in - ctx.ctx_event_tab.(events.(i)).(j) <- Com.Numeric value) + events.(i).(j) <- Com.Numeric value) | _ -> ())) | Com.Affectation (Com.MultipleFormulaes _, _) -> assert false | Com.IfThenElse (b, t, f) -> ( @@ -708,7 +704,7 @@ struct let i = Int64.to_int (N.to_int x) in let events = List.hd ctx.ctx_events in if 0 <= i && i < Array.length events then - match ctx.ctx_event_tab.(events.(i)).(j) with + match events.(i).(j) with | Com.RefVar var -> pr_raw ctx_pr (Com.Var.name_str var) | _ -> ()) | Undefined -> ()) @@ -718,7 +714,7 @@ struct let i = Int64.to_int (N.to_int x) in let events = List.hd ctx.ctx_events in if 0 <= i && i < Array.length events then - match ctx.ctx_event_tab.(events.(i)).(j) with + match events.(i).(j) with | Com.RefVar var -> pr_raw ctx_pr (Com.Var.alias_str var) | _ -> ()) | Undefined -> ()) @@ -849,10 +845,10 @@ struct | Number z -> let i = z |> N.to_int |> Int64.to_int in let events0 = List.hd ctx.ctx_events in - if 0 <= i && i < Array.length events0 then - let j = events0.(i) in - let evt = Array.copy ctx.ctx_event_tab.(j) in - (j, evt) :: backup_evts + if 0 <= i && i < Array.length events0 then ( + let evt = events0.(i) in + events0.(i) <- Array.copy evt; + (i, evt) :: backup_evts) else backup_evts | _ -> backup_evts) [] evts @@ -871,9 +867,9 @@ struct ctx.ctx_tmps.(ctx.ctx_tmps_org + var_i) <- Number vi; match evaluate_expr ctx p expr with | Number z when N.(z =. one ()) -> - let j = events0.(i) in - let evt = Array.copy ctx.ctx_event_tab.(j) in - aux ((j, evt) :: backup_evts) (i + 1) + let evt = events0.(i) in + events0.(i) <- Array.copy evt; + aux ((i, evt) :: backup_evts) (i + 1) | _ -> aux backup_evts (i + 1)) else backup_evts in @@ -890,8 +886,41 @@ struct | Com.Var.Arg -> (List.hd ctx.ctx_args).(i) <- value | Com.Var.Res -> ctx.ctx_res <- value :: List.tl ctx.ctx_res) backup_vars; - List.iter (fun (j, evt) -> ctx.ctx_event_tab.(j) <- evt) backup_evts - | Com.ArrangeEvents (sort, filter, stmts) -> + let events0 = List.hd ctx.ctx_events in + List.iter (fun (i, evt) -> events0.(i) <- evt) backup_evts + | Com.ArrangeEvents (sort, filter, add, stmts) -> + let event_list, nbAdd = + match add with + | Some expr -> ( + match evaluate_expr ctx p expr with + | Number z when N.(z >. zero ()) -> + let nb = z |> N.to_int |> Int64.to_int in + if nb > 0 then + let nbProgFields = + IntMap.cardinal p.program_event_field_idxs + in + let defEvt = + Array.init nbProgFields (fun id -> + let fname = + IntMap.find id p.program_event_field_idxs + in + let ef = StrMap.find fname p.program_event_fields in + match ef.is_var with + | true -> + let _, defVar = + StrMap.min_binding p.program_vars + in + Com.RefVar defVar + | false -> Com.Numeric Undefined) + in + ( List.init nb (function + | 0 -> defEvt + | _ -> Array.copy defEvt), + nb ) + else ([], 0) + | _ -> ([], 0)) + | None -> ([], 0) + in let events = match filter with | Some (m_var, expr) -> @@ -912,9 +941,17 @@ struct in aux res' (i + 1) in - aux [] 0 - | None -> Array.copy (List.hd ctx.ctx_events) + aux event_list 0 + | None when event_list = [] -> Array.copy (List.hd ctx.ctx_events) + | None -> + let events0 = List.hd ctx.ctx_events in + let rec aux res i = + if i >= Array.length events0 then Array.of_list (List.rev res) + else aux (events0.(i) :: res) (i + 1) + in + aux event_list 0 in + ctx.ctx_events <- events :: ctx.ctx_events; (match sort with | Some (m_var0, m_var1, expr) -> let var0 = Pos.unmark m_var0 in @@ -925,7 +962,7 @@ struct let var1_i = match var1.loc with LocTmp (_, i) -> i | _ -> assert false in - let sort_fun i j = + let sort_fun i _ j _ = let vi = Number N.(of_int (Int64.of_int i)) in ctx.ctx_tmps.(ctx.ctx_tmps_org + var0_i) <- vi; let vj = Number N.(of_int (Int64.of_int j)) in @@ -935,9 +972,8 @@ struct | Number _ -> true | Undefined -> false in - Sorting.mergeSort sort_fun events + Sorting.mergeSort sort_fun nbAdd (Array.length events) events | None -> ()); - ctx.ctx_events <- events :: ctx.ctx_events; evaluate_stmts tn canBlock p ctx stmts; ctx.ctx_events <- List.tl ctx.ctx_events | Com.RaiseError (m_err, var_opt) -> diff --git a/src/mlang/m_ir/mir_interpreter.mli b/src/mlang/m_ir/mir_interpreter.mli index bdbfb6d86..6bed42e65 100644 --- a/src/mlang/m_ir/mir_interpreter.mli +++ b/src/mlang/m_ir/mir_interpreter.mli @@ -68,8 +68,7 @@ module type S = sig mutable ctx_nb_bloquantes : int; mutable ctx_finalized_anos : (Com.Error.t * string option) list; mutable ctx_exported_anos : (Com.Error.t * string option) list; - mutable ctx_event_tab : (value, Com.Var.t) Com.event_value Array.t Array.t; - mutable ctx_events : int Array.t list; + mutable ctx_events : (value, Com.Var.t) Com.event_value Array.t Array.t list; } (** Interpretation context *) diff --git a/src/mlang/utils/sorting.ml b/src/mlang/utils/sorting.ml index 80d0b12fd..dd703d0e4 100644 --- a/src/mlang/utils/sorting.ml +++ b/src/mlang/utils/sorting.ml @@ -1,8 +1,13 @@ -let mergeSort cmp a = - let merge cmp a iLeft iRight iEnd b = +let mergeSort cmp aBeg aEnd a = + let n = Array.length a in + let b = Array.copy a in + let aBeg = max 0 (min aBeg n) in + let aEnd = max 0 (min aEnd n) in + let aBeg, aEnd = (min aBeg aEnd, max aBeg aEnd) in + let merge a iLeft iRight iEnd b = let rec aux i j k = if k < iEnd then - if i < iRight && (j >= iEnd || cmp a.(i) a.(j)) then ( + if i < iRight && (j >= iEnd || cmp i a.(i) j a.(j)) then ( b.(k) <- a.(i); aux (i + 1) j (k + 1)) else ( @@ -11,17 +16,15 @@ let mergeSort cmp a = in aux iLeft iRight iLeft in - let b = Array.copy a in - let n = Array.length a in - let rec aux a b cp width = - if width < n then ( + let rec aux a b width = + if width < aEnd then ( let rec aux' i = - if i < n then ( - merge cmp a i (min (i + width) n) (min (i + (2 * width)) n) b; + if i < aEnd then ( + merge a i (min (i + width) aEnd) (min (i + (2 * width)) aEnd) b; aux' (i + (2 * width))) in - aux' 0; - aux b a (not cp) (2 * width)) - else if cp then Array.blit a 0 b 0 n + aux' aBeg; + Array.blit b aBeg a aBeg (aEnd - aBeg); + aux a b (2 * width)) in - aux a b false 1 + aux a b 1 diff --git a/src/mlang/utils/sorting.mli b/src/mlang/utils/sorting.mli index 314acce9f..b716d8a36 100644 --- a/src/mlang/utils/sorting.mli +++ b/src/mlang/utils/sorting.mli @@ -1 +1,2 @@ -val mergeSort : ('a -> 'a -> bool) -> 'a Array.t -> unit +val mergeSort : + (int -> 'a -> int -> 'a -> bool) -> int -> int -> 'a Array.t -> unit From 7fdd4580fe58c1ab428904428698f75d5be60142 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 30 Jan 2025 19:05:34 +0100 Subject: [PATCH 21/32] =?UTF-8?q?Ajouter=20des=20=C3=A9v=C3=A9nements.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2023/cibles.m | 2 + src/mlang/backend_compilers/bir_to_dgfip_c.ml | 48 +++++++++++++++++-- 2 files changed, 46 insertions(+), 4 deletions(-) diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index 4597ef445..582038ba4 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -889,6 +889,7 @@ et champ_evenement(I, montant) <= champ_evenement(J, montant) : dans ( calculer cible afficher_evenements; ) +#{ afficher_erreur "\n"; arranger_evenements : trier I, J : avec champ_evenement(I, rappel) <= champ_evenement(J, rappel) @@ -934,6 +935,7 @@ si inf(champ_evenement(I, rappel) % 2) = 0 alors finsi ) ) +}# cible enchainement_primitif: application: iliad; diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index 5098324e0..12f643aae 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -694,16 +694,55 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) let events_sav = fresh_c_local "events_sav" in let events_tmp = fresh_c_local "events_tmp" in let nb_events_sav = fresh_c_local "nb_events_sav" in + let nb_add = fresh_c_local "nb_add" in let cpt_i = fresh_c_local "i" in let cpt_j = fresh_c_local "j" in + let evt = fresh_c_local "evt" in pr "@;@[{"; pr "@;T_event **%s = irdata->events;" events_sav; pr "@;int %s = irdata->nb_events;" nb_events_sav; + pr "@;int %s = 0;" nb_add; pr "@;T_event **%s = NULL;" events_tmp; pr "@;int %s = 0;" cpt_i; pr "@;int %s = 0;" cpt_j; - pr "@;%s = (T_event **)malloc(%s * (sizeof (T_event *)));" events_tmp - nb_events_sav; + (match add with + | Some expr -> + pr "@;@[{"; + let cond = fresh_c_local "cond" in + let cond_def = cond ^ "_def" in + let cond_val = cond ^ "_val" in + pr "@;char %s;@;double %s;" cond_def cond_val; + generate_expr_with_res_in dgfip_flags oc cond_def cond_val expr; + pr "@;%s = (int)%s;" nb_add cond_val; + pr "@;if (%s < 0) %s = 0;" nb_add nb_add; + pr "@;@[if (%s && 0 < %s) {" cond_def nb_add; + let cpt_k = fresh_c_local "k" in + pr "@;int %s = 0;" cpt_k; + pr "@;%s = (T_event **)malloc((%s + %s) * (sizeof (T_event *)));" + events_tmp nb_events_sav nb_add; + pr "@;@[for (%s = 0; %s < %s; %s++) {" cpt_k cpt_k nb_add cpt_k; + pr "@;T_event *%s = (T_event *)malloc(sizeof (T_event));" evt; + StrMap.iter + (fun f (ef : Com.event_field) -> + if ef.is_var then + let _, var = StrMap.min_binding program.program_vars in + pr "@;%s->field_%s_var = %s;" evt f (VID.gen_info_ptr var) + else ( + pr "@;%s->field_%s_def = 0;" evt f; + pr "@;%s->field_%s_val = 0.0;" evt f)) + program.program_event_fields; + pr "@;%s[%s] = %s;" events_tmp cpt_k evt; + pr "@]@;}"; + pr "@]@;@[} else {"; + pr "@;%s = 0;" nb_add; + pr "@;%s = (T_event **)malloc(%s * (sizeof (T_event *)));" events_tmp + nb_events_sav; + pr "@]@;}"; + pr "@;%s = %s;" cpt_i nb_add; + pr "@]@;}" + | None -> + pr "@;%s = (T_event **)malloc(%s * (sizeof (T_event *)));" events_tmp + nb_events_sav); (match filter with | Some (m_var, expr) -> pr "@;@[while(%s < %s) {" cpt_j nb_events_sav; @@ -730,12 +769,13 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;%s[%s] = irdata->events[%s];" events_tmp cpt_j cpt_j; pr "@;%s++;" cpt_j; pr "@]@;}"; - pr "@;irdata->events = %s;" events_tmp); + pr "@;irdata->events = %s;" events_tmp; + pr "@;irdata->nb_events = %s;" cpt_i); (match sort with | Some (m_var0, m_var1, expr) -> pr "@;/* merge sort */"; pr "@;@[{"; - pr "@;int aBeg = 0;"; + pr "@;int aBeg = %s;" nb_add; pr "@;int aEnd = irdata->nb_events;"; pr "@;\ From 8ebd9443076affbb21f8d86ae19099f57755e19f Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Fri, 31 Jan 2025 18:15:13 +0100 Subject: [PATCH 22/32] =?UTF-8?q?Mise=20=C3=A0=20jour=20des=20r=C3=A9f?= =?UTF-8?q?=C3=A9rences=20de=20variables=20dans=20les=20=C3=A9v=C3=A9nemen?= =?UTF-8?q?ts.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2023/cibles.m | 30 ++++++++++++---- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 35 ++++++++++++++----- src/mlang/m_frontend/check_validity.ml | 33 +++++++++++++---- src/mlang/m_frontend/expand_macros.ml | 25 +++++++++++++ src/mlang/m_frontend/mast_to_mir.ml | 14 ++++++-- src/mlang/m_frontend/mlexer.mll | 1 + src/mlang/m_frontend/mparser.mly | 15 +++++--- src/mlang/m_ir/com.ml | 5 +++ src/mlang/m_ir/com.mli | 1 + src/mlang/m_ir/mir.ml | 4 +++ src/mlang/m_ir/mir_interpreter.ml | 12 +++++++ 11 files changed, 146 insertions(+), 29 deletions(-) diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index 582038ba4..2243c61bf 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -822,7 +822,7 @@ si nb_discordances() + nb_informatives() > 0 alors si (present(champ_evenement(I, numero))) alors afficher_erreur (champ_evenement(I, numero)); finsi afficher_erreur "/"; si (present(champ_evenement(I, rappel))) alors afficher_erreur (champ_evenement(I, rappel)); finsi -afficher_erreur "/" alias(I, code) "," nom(I, code) "/"; +afficher_erreur "/" alias(champ_evenement(I, code)) "," nom(champ_evenement(I, code)) "/"; si (present(champ_evenement(I, montant))) alors afficher_erreur (champ_evenement(I, montant)); finsi afficher_erreur "/"; si (present(champ_evenement(I, sens))) alors @@ -867,9 +867,9 @@ si nb_discordances() + nb_informatives() > 0 alors calculer cible afficher_evenements; afficher_erreur "\n"; si nb_evenements() > 0 alors - afficher_erreur "0: " nom(0, code) " = " (champ_evenement(0, code)) "\n"; + afficher_erreur "0: " nom(champ_evenement(0, code)) " = " (champ_evenement(0, code)) "\n"; champ_evenement(0, code) = 456; - afficher_erreur "1: " nom(0, code) " = " (champ_evenement(0, code)) "\n"; + afficher_erreur "1: " nom(champ_evenement(0, code)) " = " (champ_evenement(0, code)) "\n"; afficher_erreur "0: montant " (champ_evenement(0, montant)) "\n"; champ_evenement(0, montant) = 123.456; afficher_erreur "1: montant " (champ_evenement(0, montant)) "\n"; @@ -887,14 +887,17 @@ et champ_evenement(I, montant) <= champ_evenement(J, montant) : filtrer I : avec 32 <= champ_evenement(I, rappel) et champ_evenement(I, rappel) <= 55 : ajouter 3 : dans ( + champ_evenement(0, code) reference COD1AM; + champ_evenement(1, code) reference COD1AR; + champ_evenement(2, code) reference COD1AV; calculer cible afficher_evenements; ) -#{ afficher_erreur "\n"; arranger_evenements : trier I, J : avec champ_evenement(I, rappel) <= champ_evenement(J, rappel) : dans ( EVT = 25; + afficher_erreur "nb_evenements() = " (nb_evenements()) "\n"; afficher_erreur "0: "; calculer cible afficher_evenement : avec EVT; afficher_erreur "\n"; @@ -917,7 +920,7 @@ si inf(champ_evenement(I, rappel) % 2) = 0 alors iterer : variable I : 0 .. nb_evenements() increment 1 : dans ( si inf(champ_evenement(I, rappel) % 2) = 0 alors champ_evenement(I, montant) = 111111.111111; - afficher_erreur "2: "; + afficher_erreur "1: "; calculer cible afficher_evenement : avec I; afficher_erreur "\n"; finsi @@ -935,7 +938,22 @@ si inf(champ_evenement(I, rappel) % 2) = 0 alors finsi ) ) -}# +afficher_erreur "\n"; +EVT = 25; +afficher_erreur "0: "; +calculer cible afficher_evenement : avec EVT; +afficher_erreur "\n"; +restaurer +: evenements EVT +: apres ( + champ_evenement(EVT, code) reference COD1AV; + afficher_erreur "1: "; + calculer cible afficher_evenement : avec EVT; + afficher_erreur "\n"; +) +afficher_erreur "2: "; +calculer cible afficher_evenement : avec EVT; +afficher_erreur "\n"; cible enchainement_primitif: application: iliad; diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index 12f643aae..b6c421a42 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -488,18 +488,35 @@ let generate_event_field_def (dgfip_flags : Dgfip_options.flags) pr "@]@;}"; pr "@]@;}" +let generate_event_field_ref (dgfip_flags : Dgfip_options.flags) + (p : Mir.program) (idx_expr : Mir.expression Pos.marked) (field : string) + (m_var : Com.Var.t Pos.marked) (oc : Format.formatter) : unit = + if (StrMap.find field p.program_event_fields).is_var then ( + let pr form = Format.fprintf oc form in + let idx = fresh_c_local "idx" in + let idx_def = idx ^ "_def" in + let idx_val = idx ^ "_val" in + let var = Pos.unmark m_var in + let var_info_ptr = VID.gen_info_ptr var in + pr "@;@[{"; + pr "@;char %s;@;double %s;@;int %s;" idx_def idx_val idx; + generate_expr_with_res_in dgfip_flags oc idx_def idx_val idx_expr; + pr "@;%s = (int)%s;" idx idx_val; + pr "@;@[if (%s && 0 <= %s && %s < irdata->nb_events) {" idx_def idx idx; + pr "@;irdata->events[%s]->field_%s_var = %s;" idx field var_info_ptr; + pr "@]@;}"; + pr "@]@;}") + let rec generate_stmt (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (oc : Format.formatter) (stmt : Mir.m_instruction) = let pr fmt = Format.fprintf oc fmt in match Pos.unmark stmt with | Affectation (SingleFormula (VarDecl (m_var, vidx_opt, vexpr)), _) -> - pr "@;@[{"; - generate_var_def dgfip_flags (Pos.unmark m_var) vidx_opt vexpr oc; - pr "@]@;}" + generate_var_def dgfip_flags (Pos.unmark m_var) vidx_opt vexpr oc | Affectation (SingleFormula (EventFieldDecl (idx, f, _, expr)), _) -> - pr "@;@[{"; - generate_event_field_def dgfip_flags program idx (Pos.unmark f) expr oc; - pr "@]@;}" + generate_event_field_def dgfip_flags program idx (Pos.unmark f) expr oc + | Affectation (SingleFormula (EventFieldRef (idx, f, _, m_var)), _) -> + generate_event_field_ref dgfip_flags program idx (Pos.unmark f) m_var oc | Affectation (MultipleFormulaes _, _) -> assert false | IfThenElse (cond_expr, iftrue, iffalse) -> pr "@;@[{"; @@ -765,9 +782,9 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) pr "@;irdata->events = %s;" events_tmp; pr "@;irdata->nb_events = %s;" cpt_i | None -> - pr "@;@[while (%s < %s) {" cpt_j nb_events_sav; - pr "@;%s[%s] = irdata->events[%s];" events_tmp cpt_j cpt_j; - pr "@;%s++;" cpt_j; + pr "@;@[while (%s < %s) {" cpt_i nb_events_sav; + pr "@;%s[%s] = irdata->events[%s];" events_tmp cpt_i cpt_i; + pr "@;%s++;" cpt_i; pr "@]@;}"; pr "@;irdata->events = %s;" events_tmp; pr "@;irdata->nb_events = %s;" cpt_i); diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index 7183020c2..457b236ad 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -323,6 +323,12 @@ module Err = struct let event_field_need_a_variable name pos = let msg = Format.asprintf "event field \"%s\" require a variable" name in Errors.raise_spanned_error msg pos + + let event_field_is_not_a_reference name pos = + let msg = + Format.asprintf "event field \"%s\" is not a variable reference" name + in + Errors.raise_spanned_error msg pos end type syms = Com.DomainId.t Pos.marked Com.DomainIdMap.t @@ -1246,6 +1252,19 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) StrSet.union in_vars (StrSet.diff in_vars_aff out_vars) in aux (env, m_instr :: res, in_vars, out_vars) il + | Com.SingleFormula (EventFieldRef (idx, f, _, v)) -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + let f_name, f_pos = f in + (match StrMap.find_opt f_name env.prog.prog_event_fields with + | Some ef when ef.is_var -> () + | Some _ -> Err.event_field_is_not_a_reference f_name f_pos + | None -> Err.unknown_event_field f_name f_pos); + let in_vars_index = check_expression false idx env in + ignore (check_variable v (OneOf None) env); + let in_vars = + StrSet.union in_vars (StrSet.diff in_vars_index out_vars) + in + aux (env, m_instr :: res, in_vars, out_vars) il | Com.MultipleFormulaes _ -> assert false) | Com.IfThenElse (expr, i_then, i_else) -> (* if is_rule then Err.insruction_forbidden_in_rules instr_pos; *) @@ -1359,13 +1378,12 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) ignore (check_variable v Both env) | Com.PrintEventName (e, f, _) | Com.PrintEventAlias (e, f, _) -> ( - match - StrMap.find_opt (Pos.unmark f) env.prog.prog_event_fields - with - | Some _ -> ignore (check_expression false e env) - | None -> - Err.unknown_event_field (Pos.unmark f) - (Pos.get_position f)) + let f_name, f_pos = f in + match StrMap.find_opt f_name env.prog.prog_event_fields with + | Some ef when ef.is_var -> + ignore (check_expression false e env) + | Some _ -> Err.event_field_is_not_a_reference f_name f_pos + | None -> Err.unknown_event_field f_name f_pos) | Com.PrintIndent e -> ignore (check_expression false e env) | Com.PrintExpr (e, _min, _max) -> ignore (check_expression false e env)) @@ -2644,6 +2662,7 @@ let complete_vars_stack (prog : program) : program = let nbI, szI, nbRefI, tdata = aux_expr tdata mei in let nbV, szV, nbRefV, tdata = aux_expr tdata mev in (max nbI nbV, max szI szV, max nbRefI nbRefV, tdata) + | SingleFormula (EventFieldRef (mei, _, _, _)) -> aux_expr tdata mei | MultipleFormulaes _ -> assert false) | Com.ComputeTarget (tn, _args) -> aux_call tdata (Pos.unmark tn) | Com.IfThenElse (meI, ilT, ilE) -> diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index e8bfc2559..0835e0ae1 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -650,6 +650,16 @@ let expand_formula (const_map : const_context) let idx' = expand_expression const_map ParamsMap.empty idx in let e' = expand_expression const_map ParamsMap.empty e in (Com.SingleFormula (EventFieldDecl (idx', f, i, e')), form_pos) :: prev + | Com.SingleFormula (EventFieldRef (idx, f, i, v)) -> + let idx' = expand_expression const_map ParamsMap.empty idx in + let v' = + match expand_variable const_map ParamsMap.empty v with + | Com.Var v, v_pos -> (v, v_pos) + | Com.Literal (Com.Float _), v_pos -> + Err.constant_forbidden_as_lvalue v_pos + | _ -> assert false + in + (Com.SingleFormula (EventFieldRef (idx', f, i, v')), form_pos) :: prev | Com.MultipleFormulaes (lvs, VarDecl (v, idx, e)) -> let loop_context_provider = expand_loop_variables lvs const_map in let translator loop_map = @@ -675,6 +685,21 @@ let expand_formula (const_map : const_context) in let res = loop_context_provider translator in List.rev res @ prev + | Com.MultipleFormulaes (lvs, EventFieldRef (idx, f, i, v)) -> + let loop_context_provider = expand_loop_variables lvs const_map in + let translator loop_map = + let idx' = expand_expression const_map loop_map idx in + let v' = + match expand_variable const_map loop_map v with + | Com.Var v, v_pos -> (v, v_pos) + | Com.Literal (Com.Float _), v_pos -> + Err.constant_forbidden_as_lvalue v_pos + | _ -> assert false + in + (Com.SingleFormula (EventFieldRef (idx', f, i, v')), form_pos) + in + let res = loop_context_provider translator in + List.rev res @ prev let rec expand_instruction (const_map : const_context) (prev : Mast.instruction Pos.marked list) diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 6a235390f..f8959292f 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -183,7 +183,7 @@ let rec translate_prog (p : Check_validity.program) let decl' = match decl with | VarDecl (v, idx, e) -> - let var = + let v' = match Pos.unmark (translate_variable var_data v) with | Com.Var var -> Pos.same_pos_as var v | _ -> assert false @@ -191,12 +191,22 @@ let rec translate_prog (p : Check_validity.program) in let idx' = Option.map (translate_expression p var_data) idx in let e' = translate_expression p var_data e in - Com.VarDecl (var, idx', e') + Com.VarDecl (v', idx', e') | EventFieldDecl (idx, f, _, e) -> let idx' = translate_expression p var_data idx in let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in let e' = translate_expression p var_data e in Com.EventFieldDecl (idx', f, i, e') + | EventFieldRef (idx, f, _, v) -> + let idx' = translate_expression p var_data idx in + let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in + let v' = + match Pos.unmark (translate_variable var_data v) with + | Com.Var var -> Pos.same_pos_as var v + | _ -> assert false + (* should not happen *) + in + Com.EventFieldRef (idx', f, i, v') in let m_form = (Com.SingleFormula decl', pos) in aux ((Com.Affectation m_form, pos) :: res) il diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index 4fb898efc..99397d471 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -119,6 +119,7 @@ rule token = parse | "pour" -> FOR | "puis_quand" -> THEN_WHEN | "quand" -> WHEN + | "reference" -> REFERENCE | "regle" -> RULE | "restaurer" -> RESTORE | "restituee" -> GIVEN_BACK diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index ec102592b..4cfa86747 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -57,8 +57,8 @@ along with this program. If not, see . %token ERROR ANOMALY DISCORDANCE %token INFORMATIVE OUTPUT FONCTION VARIABLE VARIABLES ATTRIBUT %token BASE GIVEN_BACK COMPUTABLE BY_DEFAULT -%token DOMAIN SPECIALIZE AUTHORIZE VERIFIABLE -%token EVENT EVENTS VALUE STEP EVENT_FIELD ARRANGE_EVENTS SORT FILTER ADD +%token DOMAIN SPECIALIZE AUTHORIZE VERIFIABLE EVENT EVENTS VALUE STEP +%token EVENT_FIELD ARRANGE_EVENTS SORT FILTER ADD REFERENCE %token EOF @@ -813,8 +813,8 @@ print_argument: | "alias" -> Com.PrintAlias (parse_variable $sloc (fst v), snd v) | _ -> assert false } -| f = with_pos(print_function) LPAREN expr = with_pos(sum_expression) - COMMA field = symbol_with_pos RPAREN { +| f = with_pos(print_function) LPAREN EVENT_FIELD LPAREN + expr = with_pos(sum_expression) COMMA field = symbol_with_pos RPAREN RPAREN { match Pos.unmark f with | "nom" -> Com.PrintEventName (expr, field, -1) | "alias" -> Com.PrintEventAlias (expr, field, -1) @@ -969,9 +969,14 @@ lvalue: formula: | EVENT_FIELD LPAREN idx = with_pos(expression) - COMMA f = symbol_with_pos RPAREN EQUALS e = with_pos(expression) { + COMMA f = symbol_with_pos RPAREN EQUALS e = with_pos(expression) { EventFieldDecl (idx, f, -1, e) } +| EVENT_FIELD LPAREN idx = with_pos(expression) + COMMA f = symbol_with_pos RPAREN REFERENCE v = symbol_with_pos { + let var = Pos.same_pos_as (parse_variable $sloc (Pos.unmark v)) v in + EventFieldRef (idx, f, -1, var) + } | lvalue = lvalue EQUALS e = with_pos(expression) { let v, idx = lvalue in VarDecl (v, idx, e) diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 0e0ab707a..78d86563d 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -463,6 +463,7 @@ type 'v formula_decl = | VarDecl of 'v Pos.marked * 'v m_expression option * 'v m_expression | EventFieldDecl of 'v m_expression * string Pos.marked * int * 'v m_expression + | EventFieldRef of 'v m_expression * string Pos.marked * int * 'v Pos.marked type 'v formula = | SingleFormula of 'v formula_decl @@ -729,6 +730,10 @@ let format_formula_decl form_var fmt = function (Pos.unmark idx) (Pos.unmark f) (format_expression form_var) (Pos.unmark e) + | EventFieldRef (idx, f, _, v) -> + Format.fprintf fmt "champ_evenement(%a,%s) reference %a" + (format_expression form_var) + (Pos.unmark idx) (Pos.unmark f) form_var (Pos.unmark v) let format_formula form_var fmt f = match f with diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index abc9b282f..5a8c353ba 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -316,6 +316,7 @@ type 'v formula_decl = | VarDecl of 'v Pos.marked * 'v m_expression option * 'v m_expression | EventFieldDecl of 'v m_expression * string Pos.marked * int * 'v m_expression + | EventFieldRef of 'v m_expression * string Pos.marked * int * 'v Pos.marked type 'v formula = | SingleFormula of 'v formula_decl diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 2c236af4a..1b3162bb4 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -222,6 +222,10 @@ let expand_functions (p : program) : program = ( Affectation (SingleFormula (EventFieldDecl (m_idx, f, i, m_expr)), pos), instr_pos ) + | Affectation (SingleFormula (EventFieldRef (v_idx, f, i, v_id)), pos) -> + let m_idx = expand_functions_expr v_idx in + ( Affectation (SingleFormula (EventFieldRef (m_idx, f, i, v_id)), pos), + instr_pos ) | Affectation (MultipleFormulaes _, _) -> assert false | IfThenElse (i, t, e) -> let i' = expand_functions_expr i in diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 5bc82e11e..496b09f98 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -626,6 +626,18 @@ struct | Com.Numeric _ -> let value = evaluate_expr ctx p expr in events.(i).(j) <- Com.Numeric value) + | _ -> ()) + | EventFieldRef (idx, _, j, m_var) -> ( + let new_idx = evaluate_expr ctx p idx in + match new_idx with + | Number z when N.(z >=. zero ()) -> ( + let i = Int64.to_int N.(to_int z) in + let events = List.hd ctx.ctx_events in + if 0 <= i && i < Array.length events then + match events.(i).(j) with + | Com.RefVar _ -> + events.(i).(j) <- Com.RefVar (Pos.unmark m_var) + | Com.Numeric _ -> ()) | _ -> ())) | Com.Affectation (Com.MultipleFormulaes _, _) -> assert false | Com.IfThenElse (b, t, f) -> ( From 8fbab018db9736b4b2d49429ea4ef990beb75e13 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Mon, 3 Feb 2025 20:10:09 +0100 Subject: [PATCH 23/32] =?UTF-8?q?Extension=20des=20variables=20avec=20des?= =?UTF-8?q?=20r=C3=A9f=C3=A9rences=20(partiel)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2023/cibles.m | 2 +- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 30 ++++---- src/mlang/m_frontend/check_validity.ml | 29 +++---- src/mlang/m_frontend/expand_macros.ml | 61 +++++++-------- src/mlang/m_frontend/mast_to_mir.ml | 59 ++++----------- src/mlang/m_frontend/mparser.mly | 6 +- src/mlang/m_ir/com.ml | 59 ++++++++------- src/mlang/m_ir/com.mli | 75 ++++++++++--------- src/mlang/m_ir/mir_interpreter.ml | 30 ++++---- 9 files changed, 165 insertions(+), 186 deletions(-) diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index 2243c61bf..ac75f18f6 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -992,7 +992,7 @@ puis_quand nb_anomalies() = 0 faire finquand calculer cible trace_out; #afficher_erreur "]traite_double_liquidation2\n"; -calculer cible test; +#calculer cible test; # primitif iterpréteur diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index b6c421a42..8205c1a2e 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -138,7 +138,7 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : } in comparison (Com.Eq, Pos.no_pos) sle0 s_i - | Com.Interval (bn, en) -> + | Com.IntervalValue (bn, en) -> let s_bn = let bn' = float_of_int (Pos.unmark bn) in D.{ set_vars = []; def_test = dtrue; value_comp = lit bn' } @@ -280,7 +280,7 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : let value_comp = D.dfun "min" [ se1.value_comp; se2.value_comp ] in D.build_transitive_composition ~safe_def:true { set_vars; def_test; value_comp } - | FuncCall ((Multimax, _), [ e1; (Var v2, _) ]) -> + | FuncCall ((Multimax, _), [ e1; (Var (VarAccess v2), _) ]) -> let bound = generate_c_expr e1 in let set_vars = bound.D.set_vars in let def_test = @@ -332,24 +332,13 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : { set_vars = []; def_test = D.dtrue; value_comp = D.lit f } | Literal Undefined -> { set_vars = []; def_test = D.dfalse; value_comp = D.lit 0. } - | Var var -> + | Var (VarAccess var) -> { set_vars = []; def_test = D.m_var var None Def; value_comp = D.m_var var None Val; } - | Attribut (var, a) -> - let ptr = VID.gen_info_ptr (Pos.unmark var) in - let def_test = - D.dinstr - (Format.sprintf "attribut_%s_def((T_varinfo *)%s)" (Pos.unmark a) ptr) - in - let value_comp = - D.dinstr - (Format.sprintf "attribut_%s((T_varinfo *)%s)" (Pos.unmark a) ptr) - in - D.build_transitive_composition { set_vars = []; def_test; value_comp } - | EventField (me, f, _) -> + | Var (FieldAccess (me, f, _)) -> let fn = Format.sprintf "event_field_%s" (Pos.unmark f) in let res = fresh_c_local "result" in let def_res = Pp.spr "def_%s" res in @@ -376,6 +365,17 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : let def_test = D.dinstr def_res in let value_comp = D.dinstr val_res in D.build_transitive_composition { set_vars; def_test; value_comp } + | Attribut (var, a) -> + let ptr = VID.gen_info_ptr (Pos.unmark var) in + let def_test = + D.dinstr + (Format.sprintf "attribut_%s_def((T_varinfo *)%s)" (Pos.unmark a) ptr) + in + let value_comp = + D.dinstr + (Format.sprintf "attribut_%s((T_varinfo *)%s)" (Pos.unmark a) ptr) + in + D.build_transitive_composition { set_vars = []; def_test; value_comp } | Size var -> let ptr = VID.gen_info_ptr (Pos.unmark var) in let def_test = D.dinstr "1.0" in diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index 457b236ad..a964ec012 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -985,7 +985,7 @@ let rec fold_var_expr Err.forbidden_expresion_in_filter (Pos.get_position v); fold_var v (OneOf None) env res | Com.FloatValue _ -> res - | Com.Interval (bn, en) -> + | Com.IntervalValue (bn, en) -> if Pos.unmark bn > Pos.unmark en then Err.wrong_interval_bounds (Pos.get_position bn); res) @@ -1021,7 +1021,7 @@ let rec fold_var_expr match args with | [ expr; var_expr ] -> ( match var_expr with - | Var var, var_pos -> + | Var (VarAccess var), var_pos -> let acc = fold_var_expr fold_var is_filter acc expr env in fold_var (var, var_pos) Both env acc | _ -> Err.second_arg_of_multimax (Pos.get_position var_expr)) @@ -1053,9 +1053,14 @@ let rec fold_var_expr in check_func (List.length fd.target_args)) | Literal _ -> acc - | Var var -> + | Var (VarAccess var) -> if is_filter then Err.variable_forbidden_in_filter expr_pos; fold_var (var, expr_pos) (OneOf None) env acc + | Var (FieldAccess (e, f, _)) -> ( + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + match StrMap.find_opt (Pos.unmark f) env.prog.prog_event_fields with + | Some _ -> fold_var_expr fold_var is_filter acc e env + | None -> Err.unknown_event_field (Pos.unmark f) (Pos.get_position f)) | NbCategory cs -> if not is_filter then Err.expression_only_in_filter expr_pos; let cats = mast_to_catvars cs env.prog.prog_var_cats in @@ -1081,11 +1086,6 @@ let rec fold_var_expr | Some _ -> Err.tmp_vars_have_no_attrs var_pos | None -> ())); fold_var v Both env acc - | EventField (e, f, _) -> ( - if is_filter then Err.forbidden_expresion_in_filter expr_pos; - match StrMap.find_opt (Pos.unmark f) env.prog.prog_event_fields with - | Some _ -> fold_var_expr fold_var is_filter acc e env - | None -> Err.unknown_event_field (Pos.unmark f) (Pos.get_position f)) | Size v -> fold_var v Both env acc | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes -> if is_filter then Err.forbidden_expresion_in_filter expr_pos; @@ -2320,13 +2320,13 @@ let eval_expr_verif (prog : program) (verif : verif) match set_value with | Com.VarValue _ -> assert false | Com.FloatValue (f, _) -> res || f = v - | Com.Interval ((bn, _), (en, _)) -> + | Com.IntervalValue ((bn, _), (en, _)) -> res || (float bn <= v && v <= float en)) false values in Some (if res = positive then 1.0 else 0.0)) | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes | Index _ - | FuncCallLoop _ | Loop _ | EventField _ -> + | FuncCallLoop _ | Loop _ -> assert false in aux expr @@ -2796,7 +2796,7 @@ let complete_vars_stack (prog : program) : program = | Com.TestInSet (_, me, _) | Com.Unop (_, me) | Com.Index (_, me) - | Com.EventField (me, _, _) -> + | Com.Var (FieldAccess (me, _, _)) -> aux_expr tdata me | Com.Comparison (_, me0, me1) | Com.Binop (_, me0, me1) -> let nb0, sz0, nbRef0, tdata = aux_expr tdata me0 in @@ -2828,9 +2828,10 @@ let complete_vars_stack (prog : program) : program = | _ -> (0, 0, 0, tdata) in (max nb nb', max sz sz', max nbRef nbRef', tdata) - | Com.Literal _ | Com.Var _ | Com.NbCategory _ | Com.Attribut _ - | Com.Size _ | Com.NbAnomalies | Com.NbDiscordances | Com.NbInformatives - | Com.NbBloquantes -> + | Com.Literal _ + | Com.Var (VarAccess _) + | Com.NbCategory _ | Com.Attribut _ | Com.Size _ | Com.NbAnomalies + | Com.NbDiscordances | Com.NbInformatives | Com.NbBloquantes -> (0, 0, 0, tdata) | Com.FuncCallLoop _ | Com.Loop _ -> assert false in diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index 0835e0ae1..b041fc08c 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -310,13 +310,13 @@ let expand_table_size (const_map : const_context) table_size = | _ -> table_size let rec expand_variable (const_map : const_context) (loop_map : loop_context) - (m_var : Mast.variable Pos.marked) : Mast.expression Pos.marked = + (m_var : Mast.variable Pos.marked) : Mast.variable Com.atom Pos.marked = let var, var_pos = m_var in match var with | Mast.Normal name -> ( match ConstMap.find_opt name const_map with - | Some (f, _) -> (Com.Literal (Float f), var_pos) - | None -> (Com.Var var, var_pos)) + | Some (f, _) -> (Com.AtomLiteral (Float f), var_pos) + | None -> (Com.AtomVar var, var_pos)) | Mast.Generic gen_name -> if List.length gen_name.Mast.parameters == 0 then expand_variable const_map loop_map @@ -334,7 +334,7 @@ and check_var_name (var_name : string) (var_pos : Pos.t) : unit = done and instantiate_params (const_map : const_context) (loop_map : loop_context) - (var_name : string) (pos : Pos.t) : Mast.expression Pos.marked = + (var_name : string) (pos : Pos.t) : Mast.variable Com.atom Pos.marked = match ParamsMap.choose_opt loop_map with | None -> check_var_name var_name pos; @@ -545,10 +545,10 @@ let rec expand_expression (const_map : const_context) (loop_map : loop_context) match set_value with | VarValue set_var -> ( match expand_variable const_map loop_map set_var with - | Literal (Float f), var_pos -> FloatValue (f, var_pos) - | Var var, var_pos -> VarValue (var, var_pos) + | AtomLiteral (Float f), var_pos -> FloatValue (f, var_pos) + | AtomVar var, var_pos -> VarValue (var, var_pos) | _ -> assert false) - | FloatValue _ | Interval _ -> set_value) + | FloatValue _ | IntervalValue _ -> set_value) values in (TestInSet (positive, e', values'), expr_pos) @@ -566,8 +566,8 @@ let rec expand_expression (const_map : const_context) (loop_map : loop_context) | Index (t, i) -> let t' = match expand_variable const_map loop_map t with - | Var v, v_pos -> (v, v_pos) - | Literal (Float _), v_pos -> Err.constant_forbidden_as_table v_pos + | AtomVar v, v_pos -> (v, v_pos) + | AtomLiteral (Float _), v_pos -> Err.constant_forbidden_as_table v_pos | _ -> assert false in let i' = expand_expression const_map loop_map i in @@ -597,7 +597,13 @@ let rec expand_expression (const_map : const_context) (loop_map : loop_context) let args' = loop_context_provider translator in (FuncCall (f_name, args'), expr_pos) | Literal _ -> m_expr - | Var v -> expand_variable const_map loop_map (v, expr_pos) + | Var (VarAccess v) -> ( + match expand_variable const_map loop_map (v, expr_pos) with + | AtomLiteral l, pos -> (Literal l, pos) + | AtomVar v, pos -> (Var (VarAccess v), pos)) + | Var (FieldAccess (e, f, i)) -> + let e' = expand_expression const_map loop_map e in + (Var (FieldAccess (e', f, i)), expr_pos) | Loop (lvs, e) -> let loop_context_provider = expand_loop_variables lvs const_map in let translator lmap = @@ -614,16 +620,14 @@ let rec expand_expression (const_map : const_context) (loop_map : loop_context) loop_exprs | Attribut (var, a) -> ( match expand_variable const_map loop_map var with - | Var v, v_pos -> (Attribut ((v, v_pos), a), expr_pos) - | Literal (Float _), v_pos -> Err.constant_cannot_have_an_attribut v_pos + | AtomVar v, v_pos -> (Attribut ((v, v_pos), a), expr_pos) + | AtomLiteral (Float _), v_pos -> + Err.constant_cannot_have_an_attribut v_pos | _ -> assert false) - | EventField (e, f, i) -> - let e' = expand_expression const_map loop_map e in - (EventField (e', f, i), expr_pos) | Size var -> ( match expand_variable const_map loop_map var with - | Var v, v_pos -> (Size (v, v_pos), expr_pos) - | Literal (Float _), v_pos -> Err.constant_cannot_have_a_size v_pos + | AtomVar v, v_pos -> (Size (v, v_pos), expr_pos) + | AtomLiteral (Float _), v_pos -> Err.constant_cannot_have_a_size v_pos | _ -> assert false) | NbCategory _ | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes -> @@ -638,9 +642,8 @@ let expand_formula (const_map : const_context) | Com.SingleFormula (VarDecl (v, idx, e)) -> let v' = match expand_variable const_map ParamsMap.empty v with - | Com.Var v, v_pos -> (v, v_pos) - | Com.Literal (Com.Float _), v_pos -> - Err.constant_forbidden_as_lvalue v_pos + | AtomVar v, v_pos -> (v, v_pos) + | AtomLiteral (Float _), v_pos -> Err.constant_forbidden_as_lvalue v_pos | _ -> assert false in let idx' = Option.map (expand_expression const_map ParamsMap.empty) idx in @@ -654,9 +657,8 @@ let expand_formula (const_map : const_context) let idx' = expand_expression const_map ParamsMap.empty idx in let v' = match expand_variable const_map ParamsMap.empty v with - | Com.Var v, v_pos -> (v, v_pos) - | Com.Literal (Com.Float _), v_pos -> - Err.constant_forbidden_as_lvalue v_pos + | AtomVar v, v_pos -> (v, v_pos) + | AtomLiteral (Float _), v_pos -> Err.constant_forbidden_as_lvalue v_pos | _ -> assert false in (Com.SingleFormula (EventFieldRef (idx', f, i, v')), form_pos) :: prev @@ -665,8 +667,8 @@ let expand_formula (const_map : const_context) let translator loop_map = let v' = match expand_variable const_map loop_map v with - | Com.Var v, v_pos -> (v, v_pos) - | Com.Literal (Com.Float _), v_pos -> + | AtomVar v, v_pos -> (v, v_pos) + | AtomLiteral (Float _), v_pos -> Err.constant_forbidden_as_lvalue v_pos | _ -> assert false in @@ -691,8 +693,8 @@ let expand_formula (const_map : const_context) let idx' = expand_expression const_map loop_map idx in let v' = match expand_variable const_map loop_map v with - | Com.Var v, v_pos -> (v, v_pos) - | Com.Literal (Com.Float _), v_pos -> + | AtomVar v, v_pos -> (v, v_pos) + | AtomLiteral (Float _), v_pos -> Err.constant_forbidden_as_lvalue v_pos | _ -> assert false in @@ -817,9 +819,8 @@ let rec expand_instruction (const_map : const_context) | Com.ComputeTarget (tn, targs) -> let map var = match expand_variable const_map ParamsMap.empty var with - | Com.Var v, v_pos -> (v, v_pos) - | Com.Literal (Com.Float _), v_pos -> - Err.constant_forbidden_as_arg v_pos + | AtomVar v, v_pos -> (v, v_pos) + | AtomLiteral (Float _), v_pos -> Err.constant_forbidden_as_arg v_pos | _ -> assert false in let targs' = List.map map targs in diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index f8959292f..8a11d5245 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -32,27 +32,17 @@ let get_var_from_name (var_data : Com.Var.t StrMap.t) (**{1 Translation}*) -(**{2 Variables}*) - -(** Variables are tricky to translate; indeed, we have unrolled all the loops, - and generic variables depend on the loop parameters. We have to interrogate - the loop context for the current values of the loop parameter and then - replace *inside the string* the loop parameter by its value to produce the - new variable. *) - -let get_var (var_data : Com.Var.t StrMap.t) - (name : Mast.variable_name Pos.marked) : Mir.expression = - Com.Var (get_var_from_name var_data name) - (**{2 Preliminary passes}*) (**{2 SSA construction}*) let translate_variable (var_data : Com.Var.t StrMap.t) - (var : Mast.variable Pos.marked) : Mir.expression Pos.marked = + (var : Mast.variable Pos.marked) : Com.Var.t Pos.marked = match Pos.unmark var with | Mast.Normal name -> - Pos.same_pos_as (get_var var_data (Pos.same_pos_as name var)) var + Pos.same_pos_as + (get_var_from_name var_data (Pos.same_pos_as name var)) + var | Mast.Generic _ -> assert false (** {2 Translation of expressions}*) @@ -76,7 +66,7 @@ let rec translate_expression (p : Check_validity.program) | Mast.Generic _ -> assert false in VarValue (new_v, pos) - | Interval (bv, ev) -> Interval (bv, ev)) + | IntervalValue (bv, ev) -> IntervalValue (bv, ev)) values in TestInSet (positive, new_e, new_set_values) @@ -103,11 +93,7 @@ let rec translate_expression (p : Check_validity.program) | Index (t, i) -> let t_var = translate_variable var_data t in let new_i = translate_expression p var_data i in - Index - ( (match Pos.unmark t_var with - | Var v -> (v, Pos.get_position f) - | _ -> assert false (* should not happen *)), - new_i ) + Index (t_var, new_i) | Conditional (e1, e2, e3) -> let new_e1 = translate_expression p var_data e1 in let new_e2 = translate_expression p var_data e2 in @@ -119,9 +105,13 @@ let rec translate_expression (p : Check_validity.program) in FuncCall (f_name, new_args) | Literal l -> Literal l - | Var var -> + | Var (VarAccess var) -> let new_var = translate_variable var_data (Pos.same_pos_as var f) in - Pos.unmark new_var + Var (VarAccess (Pos.unmark new_var)) + | Var (FieldAccess (e, f, _)) -> + let new_e = translate_expression p var_data e in + let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in + Var (FieldAccess (new_e, f, i)) | NbCategory cs -> NbCategory (Check_validity.mast_to_catvars cs p.prog_var_cats) | Attribut (v, a) -> ( @@ -149,10 +139,6 @@ let rec translate_expression (p : Check_validity.program) | _ -> let msg = Format.sprintf "unknown variable %s" v_name in Errors.raise_spanned_error msg (Pos.get_position v)) - | EventField (e, f, _) -> - let new_e = translate_expression p var_data e in - let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in - EventField (new_e, f, i) | Size v -> ( let v_name = match Pos.unmark v with @@ -183,12 +169,7 @@ let rec translate_prog (p : Check_validity.program) let decl' = match decl with | VarDecl (v, idx, e) -> - let v' = - match Pos.unmark (translate_variable var_data v) with - | Com.Var var -> Pos.same_pos_as var v - | _ -> assert false - (* should not happen *) - in + let v' = translate_variable var_data v in let idx' = Option.map (translate_expression p var_data) idx in let e' = translate_expression p var_data e in Com.VarDecl (v', idx', e') @@ -200,12 +181,7 @@ let rec translate_prog (p : Check_validity.program) | EventFieldRef (idx, f, _, v) -> let idx' = translate_expression p var_data idx in let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in - let v' = - match Pos.unmark (translate_variable var_data v) with - | Com.Var var -> Pos.same_pos_as var v - | _ -> assert false - (* should not happen *) - in + let v' = translate_variable var_data v in Com.EventFieldRef (idx', f, i, v') in let m_form = (Com.SingleFormula decl', pos) in @@ -226,12 +202,7 @@ let rec translate_prog (p : Check_validity.program) let ed' = Pos.same_pos_as (aux [] (Pos.unmark ed)) ed in aux ((Com.WhenDoElse (wdl', ed'), pos) :: res) il | (Com.ComputeTarget (tn, targs), pos) :: il -> - let map v = - match Pos.unmark (translate_variable var_data v) with - | Com.Var var -> Pos.same_pos_as var v - | _ -> assert false - (* should not happen *) - in + let map v = translate_variable var_data v in let targs' = List.map map targs in aux ((Com.ComputeTarget (tn, targs'), pos) :: res) il | (Com.VerifBlock instrs, pos) :: il -> diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 4cfa86747..0d7b9c404 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -1159,7 +1159,7 @@ interval: let pos = mk_position $sloc in let ir1 = parse_int $sloc i1, pos in let ir2 = parse_int $sloc i2, pos in - Com.Interval (ir1, ir2) : set_value + Com.IntervalValue (ir1, ir2) : set_value } (* Some intervals are "03..06" so we must keep the prefix "0" *) @@ -1223,7 +1223,7 @@ factor: | s = with_pos(table_index_name) i = with_pos(brackets) { Com.Index (s, i) } | a = with_pos(factor_atom) { match Pos.unmark a with - | Com.AtomVar v -> Com.Var v + | Com.AtomVar v -> Com.Var (VarAccess v) | Com.AtomLiteral l -> Com.Literal l } | LPAREN e = expression RPAREN { e } @@ -1263,7 +1263,7 @@ function_call: Attribut ((parse_variable $sloc (fst var), snd var), attr) } | EVENT_FIELD LPAREN m_expr = with_pos(sum_expression) COMMA field = symbol_with_pos RPAREN { - EventField (m_expr, field, -1) + Var (FieldAccess (m_expr, field, -1)) } | SIZE LPAREN var = symbol_with_pos RPAREN { Size (parse_variable $sloc (fst var), snd var) diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 78d86563d..2adef34f9 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -345,19 +345,6 @@ module TargetMap = StrMap type literal = Float of float | Undefined -type 'v atom = AtomVar of 'v | AtomLiteral of literal - -type 'v set_value_loop = - | Single of 'v atom Pos.marked - | Range of 'v atom Pos.marked * 'v atom Pos.marked - | Interval of 'v atom Pos.marked * 'v atom Pos.marked - -type 'v loop_variable = char Pos.marked * 'v set_value_loop list - -type 'v loop_variables = - | ValueSets of 'v loop_variable list - | Ranges of 'v loop_variable list - (** Unary operators *) type unop = Not | Minus @@ -367,11 +354,6 @@ type binop = And | Or | Add | Sub | Mul | Div | Mod (** Comparison operators *) type comp_op = Gt | Gte | Lt | Lte | Eq | Neq -type 'v set_value = - | FloatValue of float Pos.marked - | VarValue of 'v Pos.marked - | Interval of int Pos.marked * int Pos.marked - type func = | SumFunc (** Sums the arguments *) | AbsFunc (** Absolute value *) @@ -390,7 +372,29 @@ type func = | NbEvents | Func of string -type 'v expression = +type 'v access = + | VarAccess of 'v + | FieldAccess of 'v m_expression * string Pos.marked * int + +and 'v atom = AtomVar of 'v | AtomLiteral of literal + +and 'v set_value_loop = + | Single of 'v atom Pos.marked + | Range of 'v atom Pos.marked * 'v atom Pos.marked + | Interval of 'v atom Pos.marked * 'v atom Pos.marked + +and 'v loop_variable = char Pos.marked * 'v set_value_loop list + +and 'v loop_variables = + | ValueSets of 'v loop_variable list + | Ranges of 'v loop_variable list + +and 'v set_value = + | FloatValue of float Pos.marked + | VarValue of 'v Pos.marked + | IntervalValue of int Pos.marked * int Pos.marked + +and 'v expression = | TestInSet of bool * 'v m_expression * 'v set_value list (** Test if an expression is in a set of value (or not in the set if the flag is set to [false]) *) @@ -403,7 +407,7 @@ type 'v expression = | FuncCallLoop of func Pos.marked * 'v loop_variables Pos.marked * 'v m_expression | Literal of literal - | Var of 'v + | Var of 'v access | Loop of 'v loop_variables Pos.marked * 'v m_expression (** The loop is prefixed with the loop variables declarations *) | NbCategory of Pos.t CatVar.Map.t @@ -413,7 +417,6 @@ type 'v expression = | NbDiscordances | NbInformatives | NbBloquantes - | EventField of 'v m_expression * string Pos.marked * int and 'v m_expression = 'v expression Pos.marked @@ -611,11 +614,11 @@ let format_comp_op fmt op = | Neq -> "!=") let format_set_value format_variable fmt sv = - let open Format in match sv with + | FloatValue i -> Pp.fpr fmt "%f" (Pos.unmark i) | VarValue v -> format_variable fmt (Pos.unmark v) - | Interval (i1, i2) -> fprintf fmt "%d..%d" (Pos.unmark i1) (Pos.unmark i2) - | FloatValue i -> fprintf fmt "%f" (Pos.unmark i) + | IntervalValue (i1, i2) -> + Pp.fpr fmt "%d..%d" (Pos.unmark i1) (Pos.unmark i2) let format_func fmt f = Format.pp_print_string fmt @@ -671,7 +674,10 @@ let rec format_expression form_var fmt = (format_loop_variables form_var) (Pos.unmark lvs) form_expr (Pos.unmark e) | Literal l -> format_literal fmt l - | Var v -> form_var fmt v + | Var (VarAccess v) -> form_var fmt v + | Var (FieldAccess (e, f, _)) -> + Format.fprintf fmt "champ_evenement(%a, %s)" form_expr (Pos.unmark e) + (Pos.unmark f) | Loop (lvs, e) -> Format.fprintf fmt "pour %a%a" (format_loop_variables form_var) @@ -681,9 +687,6 @@ let rec format_expression form_var fmt = | Attribut (v, a) -> Format.fprintf fmt "attribut(%a, %s)" form_var (Pos.unmark v) (Pos.unmark a) - | EventField (e, f, _) -> - Format.fprintf fmt "champ_evenement(%a, %s)" form_expr (Pos.unmark e) - (Pos.unmark f) | Size v -> Format.fprintf fmt "taille(%a)" form_var (Pos.unmark v) | NbAnomalies -> Format.fprintf fmt "nb_anomalies()" | NbDiscordances -> Format.fprintf fmt "nb_discordances()" diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 5a8c353ba..37a66f342 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -187,6 +187,33 @@ module TargetMap : StrMap.T type literal = Float of float | Undefined +(** Unary operators *) +type unop = Not | Minus + +(** Binary operators *) +type binop = And | Or | Add | Sub | Mul | Div | Mod + +(** Comparison operators *) +type comp_op = Gt | Gte | Lt | Lte | Eq | Neq + +type func = + | SumFunc (** Sums the arguments *) + | AbsFunc (** Absolute value *) + | MinFunc (** Minimum of a list of values *) + | MaxFunc (** Maximum of a list of values *) + | GtzFunc (** Greater than zero (strict) ? *) + | GtezFunc (** Greater or equal than zero ? *) + | NullFunc (** Equal to zero ? *) + | ArrFunc (** Round to nearest integer *) + | InfFunc (** Truncate to integer *) + | PresentFunc (** Different than zero ? *) + | Multimax (** ??? *) + | Supzero (** ??? *) + | VerifNumber + | ComplNumber + | NbEvents + | Func of string + (** The M language has an extremely odd way to specify looping. Rather than having first-class local mutable variables whose value change at each loop iteration, the M language prefers to use the changing loop parameter to @@ -198,57 +225,34 @@ type literal = Float of float | Undefined number or characters and there can be multiple of them. We have to store all this information. *) +type 'v access = + | VarAccess of 'v + | FieldAccess of 'v m_expression * string Pos.marked * int + (** Values that can be substituted for loop parameters *) -type 'v atom = AtomVar of 'v | AtomLiteral of literal +and 'v atom = AtomVar of 'v | AtomLiteral of literal -type 'v set_value_loop = +and 'v set_value_loop = | Single of 'v atom Pos.marked | Range of 'v atom Pos.marked * 'v atom Pos.marked | Interval of 'v atom Pos.marked * 'v atom Pos.marked -type 'v loop_variable = char Pos.marked * 'v set_value_loop list +and 'v loop_variable = char Pos.marked * 'v set_value_loop list (** A loop variable is the character that should be substituted in variable names inside the loop plus the set of value to substitute. *) (** There are two kind of loop variables declaration, but they are semantically the same though they have different concrete syntax. *) -type 'v loop_variables = +and 'v loop_variables = | ValueSets of 'v loop_variable list | Ranges of 'v loop_variable list -(** Unary operators *) -type unop = Not | Minus - -(** Binary operators *) -type binop = And | Or | Add | Sub | Mul | Div | Mod - -(** Comparison operators *) -type comp_op = Gt | Gte | Lt | Lte | Eq | Neq - -type 'v set_value = +and 'v set_value = | FloatValue of float Pos.marked | VarValue of 'v Pos.marked - | Interval of int Pos.marked * int Pos.marked - -type func = - | SumFunc (** Sums the arguments *) - | AbsFunc (** Absolute value *) - | MinFunc (** Minimum of a list of values *) - | MaxFunc (** Maximum of a list of values *) - | GtzFunc (** Greater than zero (strict) ? *) - | GtezFunc (** Greater or equal than zero ? *) - | NullFunc (** Equal to zero ? *) - | ArrFunc (** Round to nearest integer *) - | InfFunc (** Truncate to integer *) - | PresentFunc (** Different than zero ? *) - | Multimax (** ??? *) - | Supzero (** ??? *) - | VerifNumber - | ComplNumber - | NbEvents - | Func of string + | IntervalValue of int Pos.marked * int Pos.marked -type 'v expression = +and 'v expression = | TestInSet of bool * 'v m_expression * 'v set_value list (** Test if an expression is in a set of value (or not in the set if the flag is set to [false]) *) @@ -261,7 +265,7 @@ type 'v expression = | FuncCallLoop of func Pos.marked * 'v loop_variables Pos.marked * 'v m_expression | Literal of literal - | Var of 'v + | Var of 'v access | Loop of 'v loop_variables Pos.marked * 'v m_expression (** The loop is prefixed with the loop variables declarations *) | NbCategory of Pos.t CatVar.Map.t @@ -271,7 +275,6 @@ type 'v expression = | NbDiscordances | NbInformatives | NbBloquantes - | EventField of 'v m_expression * string Pos.marked * int and 'v m_expression = 'v expression Pos.marked diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 496b09f98..937725ee6 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -375,7 +375,7 @@ struct | Com.FloatValue i -> let val_i = Number (N.of_float (Pos.unmark i)) in comparison Com.Eq new_e0 val_i - | Com.Interval (bn, en) -> + | Com.IntervalValue (bn, en) -> let val_bn = Number (N.of_float (float_of_int (Pos.unmark bn))) in @@ -415,7 +415,19 @@ struct | Index (var, e1) -> let idx = evaluate_expr ctx p e1 in get_var_tab ctx var idx - | Var var -> get_var_value ctx var 0 + | Var (VarAccess var) -> get_var_value ctx var 0 + | Var (FieldAccess (e, _, j)) -> ( + let new_e = evaluate_expr ctx p e in + match new_e with + | Number z when N.(z >=. zero ()) -> + let i = Int64.to_int N.(to_int z) in + let events = List.hd ctx.ctx_events in + if 0 <= i && i < Array.length events then + match events.(i).(j) with + | Com.Numeric v -> v + | Com.RefVar var -> get_var_value ctx var 0 + else Undefined + | _ -> Undefined) | FuncCall ((ArrFunc, _), [ arg ]) -> ( let new_arg = evaluate_expr ctx p arg in match new_arg with @@ -460,7 +472,7 @@ struct let up = N.to_int (roundf f) in let var_arg2 = match Pos.unmark arg2 with - | Var v -> (v, Pos.get_position e) + | Var (VarAccess v) -> (v, Pos.get_position e) | _ -> assert false (* todo: rte *) in @@ -509,18 +521,6 @@ struct match StrMap.find_opt (Pos.unmark a) (Com.Var.attrs var) with | Some l -> Number (N.of_float (float (Pos.unmark l))) | None -> Undefined) - | EventField (e, _, j) -> ( - let new_e = evaluate_expr ctx p e in - match new_e with - | Number z when N.(z >=. zero ()) -> - let i = Int64.to_int N.(to_int z) in - let events = List.hd ctx.ctx_events in - if 0 <= i && i < Array.length events then - match events.(i).(j) with - | Com.Numeric v -> v - | Com.RefVar var -> get_var_value ctx var 0 - else Undefined - | _ -> Undefined) | Size var -> ( let var, _ = get_var ctx (Pos.unmark var) in match Com.Var.is_table var with From 044f7987fa4532d439a3fe086b679515d86f2956 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 4 Feb 2025 16:05:37 +0100 Subject: [PATCH 24/32] =?UTF-8?q?Acc=C3=A8s=20aux=20r=C3=A9f=C3=A9rences?= =?UTF-8?q?=20de=20variables=20dans=20les=20champs=20des=20=C3=A9v=C3=A9ne?= =?UTF-8?q?ments=20(partiel).?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2023/cibles.m | 19 ++- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 76 ++++++++--- .../backend_compilers/dgfip_gen_files.ml | 87 +++++++++---- src/mlang/driver.ml | 4 +- src/mlang/m_frontend/check_validity.ml | 88 +++++++------ src/mlang/m_frontend/expand_macros.ml | 80 ++++++------ src/mlang/m_frontend/mast_to_mir.ml | 21 +-- src/mlang/m_frontend/mparser.mly | 20 +-- src/mlang/m_ir/com.ml | 19 ++- src/mlang/m_ir/com.mli | 4 +- src/mlang/m_ir/mir.ml | 18 +-- src/mlang/m_ir/mir_interpreter.ml | 120 ++++++++++-------- 12 files changed, 350 insertions(+), 206 deletions(-) diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index ac75f18f6..49cbd9e91 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -954,6 +954,23 @@ si inf(champ_evenement(I, rappel) % 2) = 0 alors afficher_erreur "2: "; calculer cible afficher_evenement : avec EVT; afficher_erreur "\n"; +afficher_erreur "\n"; +champ_evenement(EVT, code) reference TNAPCR; +iterer : variable I : 0 .. taille(TNAPCR) - 1 increment 1 : dans ( + TNAPCR[I] = I; + afficher_erreur nom(TNAPCR) "[" (I) "] = " (TNAPCR[I]) "\n"; +) +afficher_erreur "\n"; +iterer : variable I : 0 .. taille(TNAPCR) increment 1 : dans ( + afficher_erreur "multimax(" (I) ", " nom(TNAPCR) ") = " (multimax(I, TNAPCR)) "\n"; +) +afficher_erreur "\n"; +iterer : variable I : 0 .. taille(TNAPCR) increment 1 : dans ( + afficher_erreur + "multimax(" (I) ", " nom(champ_evenement(EVT, code)) " (via evenements)) = " + (multimax(I, champ_evenement(EVT, code))) "\n"; +) +afficher_erreur "\n"; cible enchainement_primitif: application: iliad; @@ -992,7 +1009,7 @@ puis_quand nb_anomalies() = 0 faire finquand calculer cible trace_out; #afficher_erreur "]traite_double_liquidation2\n"; -#calculer cible test; +calculer cible test; # primitif iterpréteur diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index 8205c1a2e..c758998ff 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -280,16 +280,41 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : let value_comp = D.dfun "min" [ se1.value_comp; se2.value_comp ] in D.build_transitive_composition ~safe_def:true { set_vars; def_test; value_comp } - | FuncCall ((Multimax, _), [ e1; (Var (VarAccess v2), _) ]) -> - let bound = generate_c_expr e1 in - let set_vars = bound.D.set_vars in - let def_test = - D.dfun "multimax_def" [ bound.value_comp; D.m_var v2 PassPointer Def ] - in - let value_comp = - D.dfun "multimax" [ bound.value_comp; D.m_var v2 PassPointer Val ] - in - D.build_transitive_composition { set_vars; def_test; value_comp } + | FuncCall ((Multimax, _), [ e1; (Var m_acc, _) ]) -> ( + match m_acc with + | VarAccess v -> + let bound = generate_c_expr e1 in + let set_vars = bound.D.set_vars in + let size_comp = D.dinstr (Pp.spr "(%s->size)" (VID.gen_info_ptr v)) in + let def_test = + D.dfun "multimax_def" + [ bound.value_comp; D.m_var v PassPointer Def; size_comp ] + in + let value_comp = + D.dfun "multimax" + [ bound.value_comp; D.m_var v PassPointer Val; size_comp ] + in + D.build_transitive_composition { set_vars; def_test; value_comp } + | FieldAccess (i, (fn, _), _) -> + let f_def = Pp.spr "multimax_%s_def" fn in + let f_val = Pp.spr "multimax_%s_val" fn in + let bound = generate_c_expr e1 in + let set_vars = bound.D.set_vars in + let irdata_comp = D.dlow_level "irdata" in + let idx = generate_c_expr i in + let set_vars = set_vars @ idx.D.set_vars in + let args = + [ + irdata_comp; + bound.def_test; + bound.value_comp; + idx.def_test; + idx.value_comp; + ] + in + let def_test = D.dfun f_def args in + let value_comp = D.dfun f_val args in + D.build_transitive_composition { set_vars; def_test; value_comp }) | FuncCall ((NbEvents, _), _) -> let def_test = D.dinstr "1.0" in let value_comp = D.dinstr "nb_evenements(irdata)" in @@ -464,6 +489,7 @@ let generate_var_def (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t) let generate_event_field_def (dgfip_flags : Dgfip_options.flags) (p : Mir.program) (idx_expr : Mir.expression Pos.marked) (field : string) + (vidx_opt : Mir.expression Pos.marked option) (expr : Mir.expression Pos.marked) (oc : Format.formatter) : unit = let pr form = Format.fprintf oc form in pr "@;@[{"; @@ -479,9 +505,23 @@ let generate_event_field_def (dgfip_flags : Dgfip_options.flags) let res_val = res ^ "_val" in pr "@;char %s;@;double %s;" res_def res_val; generate_expr_with_res_in dgfip_flags oc res_def res_val expr; - if (StrMap.find field p.program_event_fields).is_var then - pr "@;ecris_varinfo(irdata, irdata->events[%s]->field_%s_var, %s, %s);" idx - field res_def res_val + if (StrMap.find field p.program_event_fields).is_var then ( + match vidx_opt with + | None -> + pr "@;ecris_varinfo(irdata, irdata->events[%s]->field_%s_var, %s, %s);" + idx field res_def res_val + | Some ei -> + let i = fresh_c_local "i" in + let i_def = i ^ "_def" in + let i_val = i ^ "_val" in + pr "@;char %s;@;double %s;@;int %s;" i_def i_val i; + generate_expr_with_res_in dgfip_flags oc i_def i_val ei; + pr "@;%s = (int)%s;" i i_val; + pr + "@;\ + ecris_varinfo_tab(irdata, irdata->events[%s]->field_%s_var, %s, %s, \ + %s);" + idx i field res_def res_val) else ( pr "@;irdata->events[%s]->field_%s_def = %s;" idx field res_def; pr "@;irdata->events[%s]->field_%s_val = %s;" idx field res_val); @@ -511,10 +551,12 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (oc : Format.formatter) (stmt : Mir.m_instruction) = let pr fmt = Format.fprintf oc fmt in match Pos.unmark stmt with - | Affectation (SingleFormula (VarDecl (m_var, vidx_opt, vexpr)), _) -> - generate_var_def dgfip_flags (Pos.unmark m_var) vidx_opt vexpr oc - | Affectation (SingleFormula (EventFieldDecl (idx, f, _, expr)), _) -> - generate_event_field_def dgfip_flags program idx (Pos.unmark f) expr oc + | Affectation (SingleFormula (VarDecl (m_acc, vidx_opt, vexpr)), _) -> ( + match Pos.unmark m_acc with + | VarAccess var -> generate_var_def dgfip_flags var vidx_opt vexpr oc + | FieldAccess (i, f, _) -> + let fn = Pos.unmark f in + generate_event_field_def dgfip_flags program i fn vidx_opt vexpr oc) | Affectation (SingleFormula (EventFieldRef (idx, f, _, m_var)), _) -> generate_event_field_ref dgfip_flags program idx (Pos.unmark f) m_var oc | Affectation (MultipleFormulaes _, _) -> assert false diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index 34edf101f..ad7499bff 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -459,8 +459,10 @@ extern void free_erreur(); extern double floor_g(double); extern double ceil_g(double); -extern int multimax_def(int, char *); -extern double multimax(double, double *); +extern int multimax_def(int, char *, int); +extern double multimax(int, double *, int); +extern int multimax_varinfo_def(T_irdata *irdata, T_varinfo *info, int nbopd); +extern double multimax_varinfo(T_irdata *irdata, T_varinfo *info, int nbopd); extern int modulo_def(int, int); extern double modulo(double, double); |} @@ -996,18 +998,18 @@ T_discord *no_error(T_irdata *irdata) { return NULL; } -int multimax_def(int nbopd, char *var) { +int multimax_def(int nbopd, char *var, int size) { int i = 0; - for (i = 0; i < nbopd; i++) { + for (i = 0; i < nbopd && i < size; i++) { if (var[i] == 1) return 1; } return 0; } -double multimax(double nbopd, double *var) { +double multimax(int nbopd, double *var, int size) { int i = 0; double s = 0.0; - for (i = 0; i < (int)nbopd; i++) { + for (i = 0; i < nbopd && i < size; i++) { if (var[i] >= s) s = var[i]; } return s; @@ -1659,27 +1661,68 @@ void pr_err_var(T_irdata *irdata, char *nom) { |}; StrMap.iter (fun f (ef : Com.event_field) -> - Format.fprintf fmt + let pr form = Pp.fpr fmt form in + pr "char event_field_%s(T_irdata *irdata, char *res_def, double *res_val, \ char idx_def, double idx_val) {\n" f; - if ef.is_var then Format.fprintf fmt " T_varinfo *info = NULL;\n"; - Format.fprintf fmt " int idx = (int)floor(idx_val);\n"; - Format.fprintf fmt - " if (idx_def != 1 || idx < 0 || irdata->nb_events <= idx) {\n"; - Format.fprintf fmt " *res_def = 0;\n"; - Format.fprintf fmt " *res_val = 0.0;\n"; - Format.fprintf fmt " return 0;\n"; - Format.fprintf fmt " }\n"; + if ef.is_var then pr " T_varinfo *info = NULL;\n"; + pr " int idx = (int)floor(idx_val);\n"; + pr " if (idx_def != 1 || idx < 0 || irdata->nb_events <= idx) {\n"; + pr " *res_def = 0;\n"; + pr " *res_val = 0.0;\n"; + pr " return 0;\n"; + pr " }\n"; if ef.is_var then ( - Format.fprintf fmt " info = irdata->events[idx]->field_%s_var;\n" f; - Format.fprintf fmt " *res_def = lis_varinfo_def(irdata, info);\n"; - Format.fprintf fmt " *res_val = lis_varinfo_val(irdata, info);\n") + pr " info = irdata->events[idx]->field_%s_var;\n" f; + pr " *res_def = lis_varinfo_def(irdata, info);\n"; + pr " *res_val = lis_varinfo_val(irdata, info);\n") else ( - Format.fprintf fmt " *res_def = irdata->events[idx]->field_%s_def;\n" f; - Format.fprintf fmt " *res_val = irdata->events[idx]->field_%s_val;\n" f); - Format.fprintf fmt " return *res_def;\n"; - Format.fprintf fmt "}\n\n") + pr " *res_def = irdata->events[idx]->field_%s_def;\n" f; + pr " *res_val = irdata->events[idx]->field_%s_val;\n" f); + pr " return *res_def;\n"; + pr "}\n\n"; + + if ef.is_var then ( + pr + "char multimax_%s_def(T_irdata *irdata, char nb_def, double nb_val, \ + char idx_def, double idx_val) {\n" + f; + pr " int nb;\n"; + pr " int idx;\n"; + pr " T_varinfo *info;\n"; + pr " int i;\n"; + pr " if (nb_def == 0 || idx_def == 0) return 0;\n"; + pr " idx = (int)floor(idx_val);\n"; + pr " if (idx < 0 || irdata->nb_events <= idx) return 0;\n"; + pr " info = irdata->events[idx]->field_%s_var;\n" f; + pr " nb = (int)floor(nb_val);\n"; + pr " for (i = 0; i < nb && i < info->size; i++) {\n"; + pr " if (lis_varinfo_tab_def(irdata, info, i) == 1) return 1;\n"; + pr " }\n"; + pr " return 0;\n"; + pr "}\n\n"; + + pr + "char multimax_%s_val(T_irdata *irdata, char nb_def, double nb_val, \ + char idx_def, double idx_val) {\n" + f; + pr " int nb;\n"; + pr " int idx;\n"; + pr " T_varinfo *info;\n"; + pr " int i;\n"; + pr " double s = 0.0;\n"; + pr " if (nb_def == 0 || idx_def == 0) return 0;\n"; + pr " idx = (int)floor(idx_val);\n"; + pr " if (idx < 0 || irdata->nb_events <= idx) return 0;\n"; + pr " info = irdata->events[idx]->field_%s_var;\n" f; + pr " nb = (int)floor(nb_val);\n"; + pr " for (i = 0; i < nb && i < info->size; i++) {\n"; + pr " double v = lis_varinfo_tab_val(irdata, info, i);\n"; + pr " if (v >= s) s = v;\n"; + pr " }\n"; + pr " return s;\n"; + pr "}\n\n")) cprog.program_event_fields let open_file filename = diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index c041e1c7d..ce1630936 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -57,9 +57,9 @@ let patch_rule_1 (backend : string option) (dgfip_flags : Dgfip_options.flags) let mk_assign name value l = if var_exists name then let no_pos x = (x, Pos.no_pos) in - let var = Normal name in + let m_access = no_pos (Com.VarAccess (Normal name)) in let litt = Com.Literal (Com.Float (if value then 1.0 else 0.0)) in - let cmd = Com.SingleFormula (VarDecl (no_pos var, None, no_pos litt)) in + let cmd = Com.SingleFormula (VarDecl (m_access, None, no_pos litt)) in no_pos cmd :: l else l in diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index a964ec012..fa1cde717 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -184,7 +184,7 @@ module Err = struct let second_arg_of_multimax pos = Errors.raise_spanned_error - "second argument of functionn multimax must be a variable name" pos + "second argument of function multimax must be a variable name" pos let loop_in_rules rdom_chain cycle = let rdom_chain_str = @@ -1020,10 +1020,17 @@ let rec fold_var_expr if is_filter then Err.forbidden_expresion_in_filter expr_pos; match args with | [ expr; var_expr ] -> ( + let acc = fold_var_expr fold_var is_filter acc expr env in match var_expr with | Var (VarAccess var), var_pos -> - let acc = fold_var_expr fold_var is_filter acc expr env in fold_var (var, var_pos) Both env acc + | Var (FieldAccess (i, f, _)), _access_pos -> + let f_name, f_pos = f in + (match StrMap.find_opt f_name env.prog.prog_event_fields with + | Some ef when ef.is_var -> () + | Some _ -> Err.event_field_is_not_a_reference f_name f_pos + | None -> Err.unknown_event_field f_name f_pos); + fold_var_expr fold_var is_filter acc i env | _ -> Err.second_arg_of_multimax (Pos.get_position var_expr)) | _ -> Err.multimax_require_two_args expr_pos) | Com.SumFunc -> check_func (-1) @@ -1220,49 +1227,53 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) match instr with | Com.Affectation (f, _) -> ( match f with - | Com.SingleFormula (VarDecl (v, idx, e)) -> - let out_var = - let idx_mem = OneOf (Option.map (fun _ -> ()) idx) in - check_variable v idx_mem env - in + | Com.SingleFormula (VarDecl (m_access, idx, e)) -> ( + let access, access_pos = m_access in let in_vars_index = match idx with | Some ei -> check_expression false ei env | None -> StrSet.empty in let in_vars_expr = check_expression false e env in - if is_rule then - let in_vars_aff = StrSet.union in_vars_index in_vars_expr in - let in_vars = - StrSet.union in_vars (StrSet.diff in_vars_aff out_vars) - in - let out_vars = StrSet.add out_var out_vars in - aux (env, m_instr :: res, in_vars, out_vars) il - else aux (env, m_instr :: res, in_vars, out_vars) il - | Com.SingleFormula (EventFieldDecl (idx, f, _, e)) -> - if is_rule then Err.insruction_forbidden_in_rules instr_pos; - let f_name, f_pos = f in - (match StrMap.find_opt f_name env.prog.prog_event_fields with - | Some _ -> () - | None -> Err.unknown_event_field f_name f_pos); - let in_vars_index = check_expression false idx env in - let in_vars_expr = check_expression false e env in let in_vars_aff = StrSet.union in_vars_index in_vars_expr in - let in_vars = - StrSet.union in_vars (StrSet.diff in_vars_aff out_vars) - in - aux (env, m_instr :: res, in_vars, out_vars) il - | Com.SingleFormula (EventFieldRef (idx, f, _, v)) -> + match access with + | VarAccess v -> + let out_var = + let idx_mem = OneOf (Option.map (fun _ -> ()) idx) in + check_variable (v, access_pos) idx_mem env + in + let in_vars = + StrSet.union in_vars (StrSet.diff in_vars_aff out_vars) + in + let out_vars = StrSet.add out_var out_vars in + aux (env, m_instr :: res, in_vars, out_vars) il + | FieldAccess (i, f, _) -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + let f_name, f_pos = f in + (match + StrMap.find_opt f_name env.prog.prog_event_fields + with + | Some ef when (not ef.is_var) && idx <> None -> + Err.event_field_is_not_a_reference f_name f_pos + | Some _ -> () + | None -> Err.unknown_event_field f_name f_pos); + let in_vars_i = check_expression false i env in + let in_vars_aff = StrSet.union in_vars_i in_vars_aff in + let in_vars = + StrSet.union in_vars (StrSet.diff in_vars_aff out_vars) + in + aux (env, m_instr :: res, in_vars, out_vars) il) + | Com.SingleFormula (EventFieldRef (i, f, _, v)) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let f_name, f_pos = f in (match StrMap.find_opt f_name env.prog.prog_event_fields with | Some ef when ef.is_var -> () | Some _ -> Err.event_field_is_not_a_reference f_name f_pos | None -> Err.unknown_event_field f_name f_pos); - let in_vars_index = check_expression false idx env in - ignore (check_variable v (OneOf None) env); + let in_vars_i = check_expression false i env in + ignore (check_variable v Both env); let in_vars = - StrSet.union in_vars (StrSet.diff in_vars_index out_vars) + StrSet.union in_vars (StrSet.diff in_vars_i out_vars) in aux (env, m_instr :: res, in_vars, out_vars) il | Com.MultipleFormulaes _ -> assert false) @@ -2650,18 +2661,21 @@ let complete_vars_stack (prog : program) : program = match instr with | Com.Affectation mf -> ( match Pos.unmark mf with - | SingleFormula (VarDecl (_, mei_opt, mev)) -> + | SingleFormula (VarDecl (m_access, mei_opt, mev)) -> ( let nbI, szI, nbRefI, tdata = match mei_opt with | None -> (0, 0, 0, tdata) | Some mei -> aux_expr tdata mei in let nbV, szV, nbRefV, tdata = aux_expr tdata mev in - (max nbI nbV, max szI szV, max nbRefI nbRefV, tdata) - | SingleFormula (EventFieldDecl (mei, _, _, mev)) -> - let nbI, szI, nbRefI, tdata = aux_expr tdata mei in - let nbV, szV, nbRefV, tdata = aux_expr tdata mev in - (max nbI nbV, max szI szV, max nbRefI nbRefV, tdata) + let nb, sz, nbRef = + (max nbI nbV, max szI szV, max nbRefI nbRefV) + in + match Pos.unmark m_access with + | VarAccess _ -> (nb, sz, nbRef, tdata) + | FieldAccess (mei, _, _) -> + let nbI, szI, nbRefI, tdata = aux_expr tdata mei in + (max nbI nb, max szI sz, max nbRefI nbRef, tdata)) | SingleFormula (EventFieldRef (mei, _, _, _)) -> aux_expr tdata mei | MultipleFormulaes _ -> assert false) | Com.ComputeTarget (tn, _args) -> aux_call tdata (Pos.unmark tn) diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index b041fc08c..db4605231 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -639,20 +639,23 @@ let expand_formula (const_map : const_context) Mast.variable Com.formula Pos.marked list = let form, form_pos = m_form in match form with - | Com.SingleFormula (VarDecl (v, idx, e)) -> - let v' = - match expand_variable const_map ParamsMap.empty v with - | AtomVar v, v_pos -> (v, v_pos) - | AtomLiteral (Float _), v_pos -> Err.constant_forbidden_as_lvalue v_pos - | _ -> assert false + | Com.SingleFormula (VarDecl (m_access, idx, e)) -> + let m_access' = + let access, access_pos = m_access in + match access with + | VarAccess v -> ( + match expand_variable const_map ParamsMap.empty (v, access_pos) with + | AtomVar v, v_pos -> (Com.VarAccess v, v_pos) + | AtomLiteral (Float _), v_pos -> + Err.constant_forbidden_as_lvalue v_pos + | _ -> assert false) + | FieldAccess (i, f, i_f) -> + let i' = expand_expression const_map ParamsMap.empty i in + (Com.FieldAccess (i', f, i_f), access_pos) in let idx' = Option.map (expand_expression const_map ParamsMap.empty) idx in let e' = expand_expression const_map ParamsMap.empty e in - (Com.SingleFormula (VarDecl (v', idx', e')), form_pos) :: prev - | Com.SingleFormula (EventFieldDecl (idx, f, i, e)) -> - let idx' = expand_expression const_map ParamsMap.empty idx in - let e' = expand_expression const_map ParamsMap.empty e in - (Com.SingleFormula (EventFieldDecl (idx', f, i, e')), form_pos) :: prev + (Com.SingleFormula (VarDecl (m_access', idx', e')), form_pos) :: prev | Com.SingleFormula (EventFieldRef (idx, f, i, v)) -> let idx' = expand_expression const_map ParamsMap.empty idx in let v' = @@ -662,31 +665,36 @@ let expand_formula (const_map : const_context) | _ -> assert false in (Com.SingleFormula (EventFieldRef (idx', f, i, v')), form_pos) :: prev - | Com.MultipleFormulaes (lvs, VarDecl (v, idx, e)) -> - let loop_context_provider = expand_loop_variables lvs const_map in - let translator loop_map = - let v' = - match expand_variable const_map loop_map v with - | AtomVar v, v_pos -> (v, v_pos) - | AtomLiteral (Float _), v_pos -> - Err.constant_forbidden_as_lvalue v_pos - | _ -> assert false - in - let idx' = Option.map (expand_expression const_map loop_map) idx in - let e' = expand_expression const_map loop_map e in - (Com.SingleFormula (VarDecl (v', idx', e')), form_pos) - in - let res = loop_context_provider translator in - List.rev res @ prev - | Com.MultipleFormulaes (lvs, EventFieldDecl (idx, f, i, e)) -> - let loop_context_provider = expand_loop_variables lvs const_map in - let translator loop_map = - let idx' = expand_expression const_map loop_map idx in - let e' = expand_expression const_map loop_map e in - (Com.SingleFormula (EventFieldDecl (idx', f, i, e')), form_pos) - in - let res = loop_context_provider translator in - List.rev res @ prev + | Com.MultipleFormulaes (lvs, VarDecl (m_access, idx, e)) -> ( + let access, access_pos = m_access in + match access with + | VarAccess v -> + let loop_context_provider = expand_loop_variables lvs const_map in + let translator loop_map = + let m_access' = + match expand_variable const_map loop_map (v, access_pos) with + | AtomVar v, v_pos -> (Com.VarAccess v, v_pos) + | AtomLiteral (Float _), v_pos -> + Err.constant_forbidden_as_lvalue v_pos + | _ -> assert false + in + let idx' = Option.map (expand_expression const_map loop_map) idx in + let e' = expand_expression const_map loop_map e in + (Com.SingleFormula (VarDecl (m_access', idx', e')), form_pos) + in + let res = loop_context_provider translator in + List.rev res @ prev + | FieldAccess (i, f, i_f) -> + let loop_context_provider = expand_loop_variables lvs const_map in + let translator loop_map = + let i' = expand_expression const_map loop_map i in + let m_access' = (Com.FieldAccess (i', f, i_f), access_pos) in + let idx' = Option.map (expand_expression const_map loop_map) idx in + let e' = expand_expression const_map loop_map e in + (Com.SingleFormula (VarDecl (m_access', idx', e')), form_pos) + in + let res = loop_context_provider translator in + List.rev res @ prev) | Com.MultipleFormulaes (lvs, EventFieldRef (idx, f, i, v)) -> let loop_context_provider = expand_loop_variables lvs const_map in let translator loop_map = diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 8a11d5245..3972353b1 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -168,16 +168,21 @@ let rec translate_prog (p : Check_validity.program) | (Com.Affectation (SingleFormula decl, _), pos) :: il -> let decl' = match decl with - | VarDecl (v, idx, e) -> - let v' = translate_variable var_data v in + | VarDecl (m_access, idx, e) -> + let m_access' = + let access, a_pos = m_access in + match access with + | VarAccess v -> + let v', v_pos' = translate_variable var_data (v, a_pos) in + (Com.VarAccess v', v_pos') + | FieldAccess (i, f, _) -> + let i' = translate_expression p var_data i in + let ef = StrMap.find (Pos.unmark f) p.prog_event_fields in + (Com.FieldAccess (i', f, ef.index), a_pos) + in let idx' = Option.map (translate_expression p var_data) idx in let e' = translate_expression p var_data e in - Com.VarDecl (v', idx', e') - | EventFieldDecl (idx, f, _, e) -> - let idx' = translate_expression p var_data idx in - let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in - let e' = translate_expression p var_data e in - Com.EventFieldDecl (idx', f, i, e') + Com.VarDecl (m_access', idx', e') | EventFieldRef (idx, f, _, v) -> let idx' = translate_expression p var_data idx in let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 0d7b9c404..c93a34582 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -965,22 +965,26 @@ lvalue_name: | s = SYMBOL { parse_variable $sloc s } lvalue: -| s = with_pos(lvalue_name) i = with_pos(brackets)? { (s, i) } +| s = with_pos(lvalue_name) i = with_pos(brackets)? { + let access = Pos.same_pos_as (Com.VarAccess (Pos.unmark s)) s in + (access, i) + } +| EVENT_FIELD LPAREN idx = with_pos(expression) + COMMA f = symbol_with_pos RPAREN i = with_pos(brackets)? { + let access = (Com.FieldAccess (idx, f, -1), mk_position $sloc) in + (access, i) + } formula: -| EVENT_FIELD LPAREN idx = with_pos(expression) - COMMA f = symbol_with_pos RPAREN EQUALS e = with_pos(expression) { - EventFieldDecl (idx, f, -1, e) +| lval = lvalue EQUALS e = with_pos(expression) { + let access, idx = lval in + VarDecl (access, idx, e) } | EVENT_FIELD LPAREN idx = with_pos(expression) COMMA f = symbol_with_pos RPAREN REFERENCE v = symbol_with_pos { let var = Pos.same_pos_as (parse_variable $sloc (Pos.unmark v)) v in EventFieldRef (idx, f, -1, var) } -| lvalue = lvalue EQUALS e = with_pos(expression) { - let v, idx = lvalue in - VarDecl (v, idx, e) - } verification_etc: | v = with_pos(verification) l = with_pos(symbol_colon_etc)* { v :: l } diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 2adef34f9..1f3a0fc50 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -463,9 +463,7 @@ type 'v print_arg = type 'v formula_loop = 'v loop_variables Pos.marked type 'v formula_decl = - | VarDecl of 'v Pos.marked * 'v m_expression option * 'v m_expression - | EventFieldDecl of - 'v m_expression * string Pos.marked * int * 'v m_expression + | VarDecl of 'v access Pos.marked * 'v m_expression option * 'v m_expression | EventFieldRef of 'v m_expression * string Pos.marked * int * 'v Pos.marked type 'v formula = @@ -720,19 +718,18 @@ let format_print_arg form_var fmt = e min max let format_formula_decl form_var fmt = function - | VarDecl (v, idx, e) -> - Format.fprintf fmt "%a" form_var (Pos.unmark v); + | VarDecl (access, idx, e) -> + (match Pos.unmark access with + | VarAccess v -> form_var fmt v + | FieldAccess (i, f, _) -> + Format.fprintf fmt "champ_evenement(%a,%s)" + (format_expression form_var) + (Pos.unmark i) (Pos.unmark f)); (match idx with | Some vi -> Format.fprintf fmt "[%a]" (format_expression form_var) (Pos.unmark vi) | None -> ()); Format.fprintf fmt " = %a" (format_expression form_var) (Pos.unmark e) - | EventFieldDecl (idx, f, _, e) -> - Format.fprintf fmt "champ_evenement(%a,%s) = %a" - (format_expression form_var) - (Pos.unmark idx) (Pos.unmark f) - (format_expression form_var) - (Pos.unmark e) | EventFieldRef (idx, f, _, v) -> Format.fprintf fmt "champ_evenement(%a,%s) reference %a" (format_expression form_var) diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 37a66f342..d780c93f3 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -316,9 +316,7 @@ type 'v print_arg = type 'v formula_loop = 'v loop_variables Pos.marked type 'v formula_decl = - | VarDecl of 'v Pos.marked * 'v m_expression option * 'v m_expression - | EventFieldDecl of - 'v m_expression * string Pos.marked * int * 'v m_expression + | VarDecl of 'v access Pos.marked * 'v m_expression option * 'v m_expression | EventFieldRef of 'v m_expression * string Pos.marked * int * 'v Pos.marked type 'v formula = diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 1b3162bb4..5f1c864f7 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -206,21 +206,21 @@ let expand_functions (p : program) : program = let rec map_instr m_instr = let instr, instr_pos = m_instr in match instr with - | Affectation (SingleFormula (VarDecl (v_id, v_idx_opt, v_expr)), pos) -> + | Affectation (SingleFormula (VarDecl (v_acc, v_idx_opt, v_expr)), pos) -> let m_idx_opt = match v_idx_opt with | Some v_idx -> Some (expand_functions_expr v_idx) | None -> None in let m_expr = expand_functions_expr v_expr in - ( Affectation (SingleFormula (VarDecl (v_id, m_idx_opt, m_expr)), pos), - instr_pos ) - | Affectation (SingleFormula (EventFieldDecl (v_idx, f, i, v_expr)), pos) - -> - let m_idx = expand_functions_expr v_idx in - let m_expr = expand_functions_expr v_expr in - ( Affectation - (SingleFormula (EventFieldDecl (m_idx, f, i, m_expr)), pos), + let m_acc = + match Pos.unmark v_acc with + | VarAccess _ -> v_acc + | FieldAccess (v_i, f, i_f) -> + let m_i = expand_functions_expr v_i in + Pos.same_pos_as (FieldAccess (m_i, f, i_f)) v_acc + in + ( Affectation (SingleFormula (VarDecl (m_acc, m_idx_opt, m_expr)), pos), instr_pos ) | Affectation (SingleFormula (EventFieldRef (v_idx, f, i, v_id)), pos) -> let m_idx = expand_functions_expr v_idx in diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 937725ee6..0e398439c 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -469,39 +469,54 @@ struct match evaluate_expr ctx p arg1 with | Undefined -> Undefined | Number f -> ( - let up = N.to_int (roundf f) in - let var_arg2 = + let up = Int64.sub (N.to_int (roundf f)) 1L in + let var_arg2_opt = match Pos.unmark arg2 with - | Var (VarAccess v) -> (v, Pos.get_position e) - | _ -> assert false - (* todo: rte *) + | Var (VarAccess v) -> Some (v, Pos.get_position e) + | Var (FieldAccess (ei, _, j)) -> ( + let new_ei = evaluate_expr ctx p ei in + match new_ei with + | Number z when N.(z >=. zero ()) -> + let i = Int64.to_int N.(to_int z) in + let events = List.hd ctx.ctx_events in + if 0 <= i && i < Array.length events then + match events.(i).(j) with + | Com.RefVar var -> Some (var, Pos.get_position e) + | Com.Numeric _ -> None + else None + | _ -> None) + | _ -> None in - let cast_to_int (v : value) : Int64.t option = - match v with - | Number f -> Some (N.to_int (roundf f)) - | Undefined -> None - in - let pos = Pos.get_position arg2 in - let access_index (i : int) : Int64.t option = - cast_to_int - @@ evaluate_expr ctx p - ( Index - (var_arg2, (Literal (Float (float_of_int i)), pos)), - pos ) - in - let maxi = ref (access_index 0) in - for i = 0 to Int64.to_int up do - match access_index i with - | None -> () - | Some n -> - maxi := - Option.fold ~none:(Some n) - ~some:(fun m -> Some (max n m)) - !maxi - done; - match !maxi with + match var_arg2_opt with | None -> Undefined - | Some f -> Number (N.of_int f))) + | Some var_arg2 -> ( + let cast_to_int (v : value) : Int64.t option = + match v with + | Number f -> Some (N.to_int (roundf f)) + | Undefined -> None + in + let pos = Pos.get_position arg2 in + let access_index (i : int) : Int64.t option = + cast_to_int + @@ evaluate_expr ctx p + ( Index + ( var_arg2, + (Literal (Float (float_of_int i)), pos) ), + pos ) + in + let maxi = ref None in + for i = 0 to Int64.to_int up do + match access_index i with + | None -> () + | Some n -> + maxi := + Option.fold ~none:(Some n) + ~some:(fun m -> Some (max n m)) + !maxi + done; + match !maxi with + | None -> Undefined + | Some f -> Number (N.of_int f)))) | FuncCall ((NbEvents, _), _) -> let card = Array.length (List.hd ctx.ctx_events) in Number (N.of_int @@ Int64.of_int @@ card) @@ -605,40 +620,41 @@ struct and evaluate_stmt (tn : string) (canBlock : bool) (p : Mir.program) (ctx : ctx) (stmt : Mir.m_instruction) : unit = match Pos.unmark stmt with - | Com.Affectation (Com.SingleFormula decl, _) -> ( - match decl with - | VarDecl (m_var, vidx_opt, vexpr) -> ( - let vari = get_var ctx (Pos.unmark m_var) in + | Com.Affectation (SingleFormula (VarDecl (m_acc, vidx_opt, vexpr)), _) -> ( + match Pos.unmark m_acc with + | Com.VarAccess var -> ( + let vari = get_var ctx var in match vidx_opt with | None -> set_var_value p ctx vari vexpr | Some ei -> set_var_value_tab p ctx vari ei vexpr) - | EventFieldDecl (idx, _, j, expr) -> ( - let new_idx = evaluate_expr ctx p idx in - match new_idx with + | Com.FieldAccess (i, _, j) -> ( + let new_i = evaluate_expr ctx p i in + match new_i with | Number z when N.(z >=. zero ()) -> ( let i = Int64.to_int N.(to_int z) in let events = List.hd ctx.ctx_events in if 0 <= i && i < Array.length events then match events.(i).(j) with - | Com.RefVar var -> + | Com.RefVar var -> ( let vari = get_var ctx var in - set_var_value p ctx vari expr + match vidx_opt with + | None -> set_var_value p ctx vari vexpr + | Some ei -> set_var_value_tab p ctx vari ei vexpr) | Com.Numeric _ -> - let value = evaluate_expr ctx p expr in + let value = evaluate_expr ctx p vexpr in events.(i).(j) <- Com.Numeric value) - | _ -> ()) - | EventFieldRef (idx, _, j, m_var) -> ( - let new_idx = evaluate_expr ctx p idx in - match new_idx with - | Number z when N.(z >=. zero ()) -> ( - let i = Int64.to_int N.(to_int z) in - let events = List.hd ctx.ctx_events in - if 0 <= i && i < Array.length events then - match events.(i).(j) with - | Com.RefVar _ -> - events.(i).(j) <- Com.RefVar (Pos.unmark m_var) - | Com.Numeric _ -> ()) | _ -> ())) + | Com.Affectation (SingleFormula (EventFieldRef (idx, _, j, m_var)), _) -> ( + let new_idx = evaluate_expr ctx p idx in + match new_idx with + | Number z when N.(z >=. zero ()) -> ( + let i = Int64.to_int N.(to_int z) in + let events = List.hd ctx.ctx_events in + if 0 <= i && i < Array.length events then + match events.(i).(j) with + | Com.RefVar _ -> events.(i).(j) <- Com.RefVar (Pos.unmark m_var) + | Com.Numeric _ -> ()) + | _ -> ()) | Com.Affectation (Com.MultipleFormulaes _, _) -> assert false | Com.IfThenElse (b, t, f) -> ( match evaluate_expr ctx p b with From eeb5e274bd915368fa28d327bcecec6501059e8d Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 6 Feb 2025 18:18:21 +0100 Subject: [PATCH 25/32] =?UTF-8?q?Gestion=20des=20=C3=A9v=C3=A9nements?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- m_ext/2023/cibles.m | 20 +- mlang-deps | 2 +- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 356 +++++++++++++----- src/mlang/backend_compilers/decoupledExpr.ml | 12 +- src/mlang/backend_compilers/decoupledExpr.mli | 2 +- .../backend_compilers/dgfip_gen_files.ml | 193 ++++++---- src/mlang/backend_compilers/dgfip_varid.ml | 16 +- src/mlang/m_frontend/check_validity.ml | 109 ++++-- src/mlang/m_frontend/expand_macros.ml | 45 ++- src/mlang/m_frontend/mast_to_mir.ml | 66 ++-- src/mlang/m_frontend/mparser.mly | 51 +-- src/mlang/m_ir/com.ml | 55 +-- src/mlang/m_ir/com.mli | 15 +- src/mlang/m_ir/mir.ml | 50 ++- src/mlang/m_ir/mir_interpreter.ml | 108 ++++-- 15 files changed, 744 insertions(+), 356 deletions(-) diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index 49cbd9e91..0faf0a84a 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -958,8 +958,11 @@ si inf(champ_evenement(I, rappel) % 2) = 0 alors champ_evenement(EVT, code) reference TNAPCR; iterer : variable I : 0 .. taille(TNAPCR) - 1 increment 1 : dans ( TNAPCR[I] = I; - afficher_erreur nom(TNAPCR) "[" (I) "] = " (TNAPCR[I]) "\n"; + afficher_erreur nom(TNAPCR) "[" (I) "] = " (TNAPCR[I]) " -- "; + afficher_erreur nom(champ_evenement(EVT, code)) "[" (I) "] = " (champ_evenement(EVT, code)[I]) "\n"; ) +afficher_erreur nom(TNAPCR) "[" (taille(TNAPCR)) "] = " (TNAPCR[taille(TNAPCR)]) " -- "; +afficher_erreur nom(champ_evenement(EVT, code)) "[" (taille(TNAPCR)) "] = " (champ_evenement(EVT, code)[taille(TNAPCR)]) "\n"; afficher_erreur "\n"; iterer : variable I : 0 .. taille(TNAPCR) increment 1 : dans ( afficher_erreur "multimax(" (I) ", " nom(TNAPCR) ") = " (multimax(I, TNAPCR)) "\n"; @@ -971,6 +974,19 @@ si inf(champ_evenement(I, rappel) % 2) = 0 alors (multimax(I, champ_evenement(EVT, code))) "\n"; ) afficher_erreur "\n"; +afficher_erreur "taille(" nom(TNAPCR) ") = " (taille(TNAPCR)) "\n"; +afficher_erreur "taille(" nom(champ_evenement(EVT, code)) ") = " (taille(champ_evenement(EVT, code))) "\n"; +afficher_erreur "taille(" nom(champ_evenement(1000, code)) ") = " (taille(champ_evenement(1000, code))) "\n"; +afficher_erreur "\n"; +champ_evenement(EVT, code) reference COD1AV; +afficher_erreur "attribut(" nom(COD1AV) ") = " (attribut(COD1AV, primrest)) "\n"; +afficher_erreur + "attribut(" nom(champ_evenement(EVT, code)) ", primrest) = " + (attribut(champ_evenement(EVT, code), primrest)) "\n"; +afficher_erreur + "attribut(" nom(champ_evenement(1000, code)) ", primrest) = " + (attribut(champ_evenement(1000, code), primrest)) "\n"; +afficher_erreur "\n"; cible enchainement_primitif: application: iliad; @@ -1009,7 +1025,7 @@ puis_quand nb_anomalies() = 0 faire finquand calculer cible trace_out; #afficher_erreur "]traite_double_liquidation2\n"; -calculer cible test; +#calculer cible test; # primitif iterpréteur diff --git a/mlang-deps b/mlang-deps index 34bd1f213..c57e11440 160000 --- a/mlang-deps +++ b/mlang-deps @@ -1 +1 @@ -Subproject commit 34bd1f21399788e696d06a5f6fe521dc9c8df766 +Subproject commit c57e114403643123e0f54c60f650fa39fd0f9ce2 diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index c758998ff..011ee81ef 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -121,14 +121,44 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : (fun or_chain set_value -> let equal_test = match set_value with - | Com.VarValue set_var -> - let s_set_var = - let v = Pos.unmark set_var in + | Com.VarValue (VarAccess v, _) -> + let s_v = let def_test = D.m_var v None Def in let value_comp = D.m_var v None Val in D.{ set_vars = []; def_test; value_comp } in - comparison (Com.Eq, Pos.no_pos) sle0 s_set_var + comparison (Com.Eq, Pos.no_pos) sle0 s_v + | Com.VarValue (FieldAccess (me, f, _), _) -> + let fn = Pp.spr "event_field_%s" (Pos.unmark f) in + let res = fresh_c_local "result" in + let res_def = Pp.spr "%s_def" res in + let res_val = Pp.spr "%s_val" res in + let res_def_ptr = Pp.spr "&%s" res_def in + let res_val_ptr = Pp.spr "&%s" res_val in + let set_vars, arg_exprs = + let e = generate_c_expr me in + (e.set_vars, [ e.def_test; e.value_comp ]) + in + let d_fun = + D.dfun fn + ([ + D.ddirect (D.dinstr "irdata"); + D.ddirect (D.dinstr res_def_ptr); + D.ddirect (D.dinstr res_val_ptr); + ] + @ arg_exprs) + in + let set_vars = + set_vars + @ [ + (D.Def, res_def, d_fun); + (D.Val, res_val, D.ddirect (D.dinstr res_val)); + ] + in + let def_test = D.dinstr res_def in + let value_comp = D.dinstr res_val in + let s_f = D.{ set_vars; def_test; value_comp } in + comparison (Com.Eq, Pos.no_pos) sle0 s_f | Com.FloatValue i -> let s_i = { @@ -172,31 +202,74 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : | Unop (op, e) -> let se = generate_c_expr e in unop op se - | Index (var, e) -> - let index = fresh_c_local "index" in - let def_index = Pp.spr "def_%s" index in - let val_index = Pp.spr "val_%s" index in - let idx = generate_c_expr e in - let size = VID.gen_size (Pos.unmark var) in - let set_vars = - idx.D.set_vars - @ [ - (D.Def, def_index, idx.def_test); (D.Val, val_index, idx.value_comp); - ] - in - let def_test = - D.dand - (D.dand (D.dinstr def_index) - (D.comp "<" (D.dinstr val_index) (D.dinstr size))) - (D.access (Pos.unmark var) Def (D.dinstr val_index)) - in - let value_comp = - D.ite - (D.comp "<" (D.dinstr val_index) (D.lit 0.)) - (D.lit 0.) - (D.access (Pos.unmark var) Val (D.dinstr val_index)) - in - D.build_transitive_composition { set_vars; def_test; value_comp } + | Index (m_acc, e) -> ( + match Pos.unmark m_acc with + | VarAccess v -> + let index = fresh_c_local "index" in + let index_def = Pp.spr "%s_def" index in + let index_val = Pp.spr "%s_val" index in + let idx = generate_c_expr e in + let size = VID.gen_size v in + let set_vars = + idx.D.set_vars + @ [ + (D.Def, index_def, idx.def_test); + (D.Val, index_val, idx.value_comp); + ] + in + let def_test = + D.dand + (D.dand (D.dinstr index_def) + (D.comp "<" (D.dinstr index_val) (D.dinstr size))) + (D.access v Def (D.dinstr index_val)) + in + let value_comp = + D.ite + (D.comp "<" (D.dinstr index_val) (D.lit 0.)) + (D.lit 0.) + (D.access v Val (D.dinstr index_val)) + in + D.build_transitive_composition { set_vars; def_test; value_comp } + | FieldAccess (ie, f, _) -> + let d_irdata = D.ddirect (D.dinstr "irdata") in + let set_vars, idx_def, idx_val = + let idx = generate_c_expr e in + (idx.set_vars, idx.def_test, idx.value_comp) + in + let set_vars, evt_d_fun = + let i = generate_c_expr ie in + let evt_fn = Pp.spr "event_field_%s_var" (Pos.unmark f) in + let evt_d_fun = + D.dfun evt_fn [ d_irdata; i.def_test; i.value_comp ] + in + (set_vars @ i.set_vars, evt_d_fun) + in + let res = fresh_c_local "res" in + let res_def = Pp.spr "%s_def" res in + let res_val = Pp.spr "%s_val" res in + let res_def_ptr = Pp.spr "&%s" res_def in + let res_val_ptr = Pp.spr "&%s" res_val in + let d_fun = + D.dfun "lis_varinfo_tab" + [ + d_irdata; + D.ddirect evt_d_fun; + idx_def; + idx_val; + D.ddirect (D.dinstr res_def_ptr); + D.ddirect (D.dinstr res_val_ptr); + ] + in + let set_vars = + set_vars + @ [ + (D.Def, res_def, d_fun); + (D.Val, res_val, D.ddirect (D.dinstr res_val)); + ] + in + let def_test = D.dinstr res_def in + let value_comp = D.dinstr res_val in + D.build_transitive_composition { set_vars; def_test; value_comp }) | Conditional (c, t, f_opt) -> let cond = generate_c_expr c in let thenval = generate_c_expr t in @@ -285,35 +358,73 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : | VarAccess v -> let bound = generate_c_expr e1 in let set_vars = bound.D.set_vars in + let res = fresh_c_local "res" in + let res_def = Pp.spr "%s_def" res in + let res_val = Pp.spr "%s_val" res in + let res_def_ptr = Pp.spr "&%s" res_def in + let res_val_ptr = Pp.spr "&%s" res_val in let size_comp = D.dinstr (Pp.spr "(%s->size)" (VID.gen_info_ptr v)) in - let def_test = - D.dfun "multimax_def" - [ bound.value_comp; D.m_var v PassPointer Def; size_comp ] - in - let value_comp = + let d_fun = D.dfun "multimax" - [ bound.value_comp; D.m_var v PassPointer Val; size_comp ] + [ + D.m_var v PassPointer Def; + D.m_var v PassPointer Val; + size_comp; + bound.def_test; + bound.value_comp; + D.ddirect (D.dinstr res_def_ptr); + D.ddirect (D.dinstr res_val_ptr); + ] + in + let set_vars = + set_vars + @ [ + (D.Def, res_def, d_fun); + (D.Val, res_val, D.ddirect (D.dinstr res_val)); + ] in + let def_test = D.dinstr res_def in + let value_comp = D.dinstr res_val in D.build_transitive_composition { set_vars; def_test; value_comp } - | FieldAccess (i, (fn, _), _) -> - let f_def = Pp.spr "multimax_%s_def" fn in - let f_val = Pp.spr "multimax_%s_val" fn in - let bound = generate_c_expr e1 in - let set_vars = bound.D.set_vars in - let irdata_comp = D.dlow_level "irdata" in - let idx = generate_c_expr i in - let set_vars = set_vars @ idx.D.set_vars in - let args = - [ - irdata_comp; - bound.def_test; - bound.value_comp; - idx.def_test; - idx.value_comp; - ] + | FieldAccess (ie, f, _) -> + let d_irdata = D.ddirect (D.dinstr "irdata") in + let set_vars, bound_def, bound_val = + let bound = generate_c_expr e1 in + (bound.set_vars, bound.def_test, bound.value_comp) + in + let set_vars, evt_d_fun = + let e = generate_c_expr ie in + let evt_fn = Pp.spr "event_field_%s_var" (Pos.unmark f) in + let evt_d_fun = + D.dfun evt_fn [ d_irdata; e.def_test; e.value_comp ] + in + (set_vars @ e.set_vars, evt_d_fun) in - let def_test = D.dfun f_def args in - let value_comp = D.dfun f_val args in + let res = fresh_c_local "res" in + let res_def = Pp.spr "%s_def" res in + let res_val = Pp.spr "%s_val" res in + let res_def_ptr = Pp.spr "&%s" res_def in + let res_val_ptr = Pp.spr "&%s" res_val in + let d_fun = + D.dfun "multimax_varinfo" + [ + d_irdata; + D.ddirect evt_d_fun; + bound_def; + bound_val; + D.ddirect (D.dinstr res_def_ptr); + D.ddirect (D.dinstr res_val_ptr); + ] + in + let set_vars = + set_vars + @ [ + (D.Def, res_def, d_fun); + (D.Val, res_val, D.ddirect (D.dinstr res_val)); + ] + in + let def_test = D.dinstr res_def in + let value_comp = D.dinstr res_val in D.build_transitive_composition { set_vars; def_test; value_comp }) | FuncCall ((NbEvents, _), _) -> let def_test = D.dinstr "1.0" in @@ -321,10 +432,10 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : D.build_transitive_composition { set_vars = []; def_test; value_comp } | FuncCall ((Func fn, _), args) -> let res = fresh_c_local "result" in - let def_res = Pp.spr "def_%s" res in - let val_res = Pp.spr "val_%s" res in - let def_res_ptr = Pp.spr "&%s" def_res in - let val_res_ptr = Pp.spr "&%s" val_res in + let res_def = Pp.spr "%s_def" res in + let res_val = Pp.spr "%s_val" res in + let res_def_ptr = Pp.spr "&%s" res_def in + let res_val_ptr = Pp.spr "&%s" res_val in let set_vars, arg_exprs = let rec aux (set_vars, arg_exprs) = function | [] -> (List.rev set_vars, List.rev arg_exprs) @@ -339,18 +450,21 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : let d_fun = D.dfun fn ([ - D.dlow_level "irdata"; - D.dlow_level def_res_ptr; - D.dlow_level val_res_ptr; + D.ddirect (D.dinstr "irdata"); + D.ddirect (D.dinstr res_def_ptr); + D.ddirect (D.dinstr res_val_ptr); ] @ arg_exprs) in let set_vars = set_vars - @ [ (D.Def, def_res, d_fun); (D.Val, val_res, D.dlow_level val_res) ] + @ [ + (D.Def, res_def, d_fun); + (D.Val, res_val, D.ddirect (D.dinstr res_val)); + ] in - let def_test = D.dinstr def_res in - let value_comp = D.dinstr val_res in + let def_test = D.dinstr res_def in + let value_comp = D.dinstr res_val in D.build_transitive_composition { set_vars; def_test; value_comp } | FuncCall _ -> assert false (* should not happen *) | Literal (Float f) -> @@ -358,18 +472,16 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : | Literal Undefined -> { set_vars = []; def_test = D.dfalse; value_comp = D.lit 0. } | Var (VarAccess var) -> - { - set_vars = []; - def_test = D.m_var var None Def; - value_comp = D.m_var var None Val; - } + let def_test = D.m_var var None Def in + let value_comp = D.m_var var None Val in + { set_vars = []; def_test; value_comp } | Var (FieldAccess (me, f, _)) -> - let fn = Format.sprintf "event_field_%s" (Pos.unmark f) in + let fn = Pp.spr "event_field_%s" (Pos.unmark f) in let res = fresh_c_local "result" in - let def_res = Pp.spr "def_%s" res in - let val_res = Pp.spr "val_%s" res in - let def_res_ptr = Pp.spr "&%s" def_res in - let val_res_ptr = Pp.spr "&%s" val_res in + let res_def = Pp.spr "%s_def" res in + let res_val = Pp.spr "%s_val" res in + let res_def_ptr = Pp.spr "&%s" res_def in + let res_val_ptr = Pp.spr "&%s" res_val in let set_vars, arg_exprs = let e = generate_c_expr me in (e.set_vars, [ e.def_test; e.value_comp ]) @@ -377,35 +489,85 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : let d_fun = D.dfun fn ([ - D.dlow_level "irdata"; - D.dlow_level def_res_ptr; - D.dlow_level val_res_ptr; + D.ddirect (D.dinstr "irdata"); + D.ddirect (D.dinstr res_def_ptr); + D.ddirect (D.dinstr res_val_ptr); ] @ arg_exprs) in let set_vars = set_vars - @ [ (D.Def, def_res, d_fun); (D.Val, val_res, D.dlow_level val_res) ] + @ [ + (D.Def, res_def, d_fun); + (D.Val, res_val, D.ddirect (D.dinstr res_val)); + ] in - let def_test = D.dinstr def_res in - let value_comp = D.dinstr val_res in + let def_test = D.dinstr res_def in + let value_comp = D.dinstr res_val in D.build_transitive_composition { set_vars; def_test; value_comp } - | Attribut (var, a) -> - let ptr = VID.gen_info_ptr (Pos.unmark var) in - let def_test = - D.dinstr - (Format.sprintf "attribut_%s_def((T_varinfo *)%s)" (Pos.unmark a) ptr) - in - let value_comp = - D.dinstr - (Format.sprintf "attribut_%s((T_varinfo *)%s)" (Pos.unmark a) ptr) - in - D.build_transitive_composition { set_vars = []; def_test; value_comp } - | Size var -> - let ptr = VID.gen_info_ptr (Pos.unmark var) in - let def_test = D.dinstr "1.0" in - let value_comp = D.dinstr (Format.sprintf "(%s->size)" ptr) in - D.build_transitive_composition { set_vars = []; def_test; value_comp } + | Attribut (m_acc, a) -> ( + let attr = Pos.unmark a in + match Pos.unmark m_acc with + | VarAccess v -> + let ptr = VID.gen_info_ptr v in + let def_test = + D.dinstr (Pp.spr "attribut_%s_def((T_varinfo *)%s)" attr ptr) + in + let value_comp = + D.dinstr (Pp.spr "attribut_%s((T_varinfo *)%s)" attr ptr) + in + D.build_transitive_composition { set_vars = []; def_test; value_comp } + | FieldAccess (ie, f, _) -> + let d_irdata = D.ddirect (D.dinstr "irdata") in + let set_vars, evt_d_fun = + let e = generate_c_expr ie in + let evt_fn = Pp.spr "event_field_%s_var" (Pos.unmark f) in + (e.set_vars, D.dfun evt_fn [ d_irdata; e.def_test; e.value_comp ]) + in + let def_test = + D.dfun (Pp.spr "attribut_%s_def" attr) [ D.ddirect evt_d_fun ] + in + let value_comp = + D.dfun (Pp.spr "attribut_%s" attr) [ D.ddirect evt_d_fun ] + in + D.build_transitive_composition { set_vars; def_test; value_comp }) + | Size m_acc -> ( + match Pos.unmark m_acc with + | VarAccess v -> + let ptr = VID.gen_info_ptr v in + let def_test = D.dinstr "1.0" in + let value_comp = D.dinstr (Format.sprintf "(%s->size)" ptr) in + D.build_transitive_composition { set_vars = []; def_test; value_comp } + | FieldAccess (ie, f, _) -> + let d_irdata = D.ddirect (D.dinstr "irdata") in + let set_vars, evt_d_fun = + let e = generate_c_expr ie in + let evt_fn = Pp.spr "event_field_%s_var" (Pos.unmark f) in + (e.set_vars, D.dfun evt_fn [ d_irdata; e.def_test; e.value_comp ]) + in + let res = fresh_c_local "res" in + let res_def = Pp.spr "%s_def" res in + let res_val = Pp.spr "%s_val" res in + let res_def_ptr = Pp.spr "&%s" res_def in + let res_val_ptr = Pp.spr "&%s" res_val in + let d_fun = + D.dfun "size_varinfo" + [ + D.ddirect evt_d_fun; + D.ddirect (D.dinstr res_def_ptr); + D.ddirect (D.dinstr res_val_ptr); + ] + in + let set_vars = + set_vars + @ [ + (D.Def, res_def, d_fun); + (D.Val, res_val, D.ddirect (D.dinstr res_val)); + ] + in + let def_test = D.dinstr res_def in + let value_comp = D.dinstr res_val in + D.build_transitive_composition { set_vars; def_test; value_comp }) | NbAnomalies -> let def_test = D.dinstr "1.0" in let value_comp = D.dinstr "nb_anomalies(irdata)" in @@ -1046,11 +1208,11 @@ let generate_function_prototype (add_semicolon : bool) (oc : Format.formatter) let fn = Pos.unmark fd.target_name in let pp_args fmt args = List.iteri - (fun i _ -> Pp.fpr fmt ", char def_arg%d, double val_arg%d" i i) + (fun i _ -> Pp.fpr fmt ", char arg_def%d, double arg_val%d" i i) args in Format.fprintf oc - "int %s(T_irdata* irdata, char *def_res, double *val_res%a)%s" fn pp_args + "int %s(T_irdata* irdata, char *res_def, double *res_val%a)%s" fn pp_args fd.Mir.target_args (if add_semicolon then ";" else "") diff --git a/src/mlang/backend_compilers/decoupledExpr.ml b/src/mlang/backend_compilers/decoupledExpr.ml index 3a68ae2d2..5b64bf307 100644 --- a/src/mlang/backend_compilers/decoupledExpr.ml +++ b/src/mlang/backend_compilers/decoupledExpr.ml @@ -71,7 +71,7 @@ and expr = | Daccess of Com.Var.t * dflag * expr | Dite of expr * expr * expr | Dinstr of string - | DlowLevel of string + | Ddirect of expr and expr_var = Local of stack_slot | M of Com.Var.t * offset * dflag @@ -136,7 +136,7 @@ let rec expr_position (expr : expr) (st : local_stacks) = (* Needed to bumb the stack to avoid erasing subexpressions *) | _, _ -> Not_to_stack (* Either already stored, or duplicatable *) end - | DlowLevel _ -> Not_to_stack + | Ddirect _ -> Not_to_stack | _ -> Must_be_pushed (* allocate to local variable if necessary *) @@ -370,8 +370,9 @@ let dfun (f : string) (args : constr list) (stacks : local_stacks) let dinstr (i : string) (_stacks : local_stacks) (_ctx : local_vars) : t = (Dinstr i, Val, []) -let dlow_level (i : string) (_stacks : local_stacks) (_ctx : local_vars) : t = - (DlowLevel i, Val, []) +let ddirect (c : constr) (stacks : local_stacks) (ctx : local_vars) : t = + let expr, flags, ctx = c stacks ctx in + (Ddirect expr, flags, ctx) let access (var : Com.Var.t) (df : dflag) (e : constr) (stacks : local_stacks) (ctx : local_vars) : t = @@ -520,7 +521,8 @@ let rec format_dexpr (dgfip_flags : Dgfip_options.flags) fmt (de : expr) = ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") format_dexpr) des - | Dinstr instr | DlowLevel instr -> Format.fprintf fmt "%s" instr + | Dinstr instr -> Format.fprintf fmt "%s" instr + | Ddirect expr -> format_dexpr fmt expr | Daccess (var, dflag, de) -> Format.fprintf fmt "(%s[(int)%a])" (generate_variable ~def_flag:(dflag = Def) diff --git a/src/mlang/backend_compilers/decoupledExpr.mli b/src/mlang/backend_compilers/decoupledExpr.mli index 037f389aa..ea1833ae4 100644 --- a/src/mlang/backend_compilers/decoupledExpr.mli +++ b/src/mlang/backend_compilers/decoupledExpr.mli @@ -113,7 +113,7 @@ val dfun : string -> constr list -> constr val dinstr : string -> constr (** Direct instruction *) -val dlow_level : string -> constr +val ddirect : constr -> constr (** Direct instruction, not pushed *) val access : Com.Var.t -> dflag -> constr -> constr diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index ad7499bff..f7ff6a3d7 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -73,28 +73,30 @@ let gen_table_varinfos fmt (cprog : Mir.program) = in StrSet.iter (fun attr -> - Format.fprintf fmt "char attribut_%s_def(T_varinfo *vi) {\n" attr; - Format.fprintf fmt " switch (vi->cat) {\n"; + Pp.fpr fmt "char attribut_%s_def(T_varinfo *vi) {\n" attr; + Pp.fpr fmt " if (vi == NULL) return 0;\n"; + Pp.fpr fmt " switch (vi->cat) {\n"; Com.CatVar.Map.iter (fun _ Com.CatVar.{ id_str; attributs; _ } -> if StrMap.mem attr attributs then - Format.fprintf fmt " case ID_%s: return 1;\n" id_str) + Pp.fpr fmt " case ID_%s: return 1;\n" id_str) cprog.program_var_categories; - Format.fprintf fmt " }\n"; - Format.fprintf fmt " return 0;\n"; - Format.fprintf fmt "}\n\n"; - Format.fprintf fmt "double attribut_%s(T_varinfo *vi) {\n" attr; - Format.fprintf fmt " switch (vi->cat) {\n"; + Pp.fpr fmt " }\n"; + Pp.fpr fmt " return 0;\n"; + Pp.fpr fmt "}\n\n"; + Pp.fpr fmt "double attribut_%s(T_varinfo *vi) {\n" attr; + Pp.fpr fmt " if (vi == NULL) return 0.0;\n"; + Pp.fpr fmt " switch (vi->cat) {\n"; Com.CatVar.Map.iter (fun _ Com.CatVar.{ id_str; attributs; _ } -> if StrMap.mem attr attributs then ( - Format.fprintf fmt " case ID_%s:\n" id_str; - Format.fprintf fmt " return ((T_varinfo_%s *)vi)->attr_%s;\n" - id_str attr)) + Pp.fpr fmt " case ID_%s:\n" id_str; + Pp.fpr fmt " return ((T_varinfo_%s *)vi)->attr_%s;\n" id_str + attr)) cprog.program_var_categories; - Format.fprintf fmt " }\n"; - Format.fprintf fmt " return 0.0;\n"; - Format.fprintf fmt "}\n\n") + Pp.fpr fmt " }\n"; + Pp.fpr fmt " return 0.0;\n"; + Pp.fpr fmt "}\n\n") attrs; let stats_varinfos, var_map = Com.CatVar.Map.fold @@ -102,9 +104,9 @@ let gen_table_varinfos fmt (cprog : Mir.program) = cprog.program_var_categories (Com.CatVar.Map.empty, StrMap.empty) in - Format.fprintf fmt "T_varinfo_map varinfo[NB_variable + NB_saisie + 1] = {\n"; + Pp.fpr fmt "T_varinfo_map varinfo[NB_variable + NB_saisie + 1] = {\n"; StrMap.iter (Format.fprintf fmt " { \"%s\", %s },\n") var_map; - Format.fprintf fmt " NULL\n};\n\n"; + Pp.fpr fmt " NULL\n};\n\n"; stats_varinfos let gen_decl_varinfos fmt (cprog : Mir.program) stats = @@ -396,8 +398,13 @@ typedef struct S_irdata T_irdata; |}; StrMap.iter - (fun f _ -> - Format.fprintf fmt + (fun f (ef : Com.event_field) -> + if ef.is_var then + Pp.fpr fmt + "extern T_varinfo *event_field_%s_var(T_irdata *irdata, char \ + idx_def, double idx_val);\n" + f; + Pp.fpr fmt "extern char event_field_%s(T_irdata *irdata, char *res_def, double \ *res_val, char idx_def, double idx_val);\n" f) @@ -423,6 +430,9 @@ typedef struct S_irdata T_irdata; #define R_(idx) (irdata->ref[irdata->ref_org + (idx)]) #define IR_(idx) (irdata->info_ref[irdata->ref_org + (idx)]) +extern T_event *event(T_irdata *irdata, char idx_def, double idx_val); +extern int size_varinfo(T_varinfo *info, char *res_def, double *res_val); + #define EST_SAISIE 0x00000 #define EST_CALCULEE 0x04000 #define EST_BASE 0x08000 @@ -459,10 +469,8 @@ extern void free_erreur(); extern double floor_g(double); extern double ceil_g(double); -extern int multimax_def(int, char *, int); -extern double multimax(int, double *, int); -extern int multimax_varinfo_def(T_irdata *irdata, T_varinfo *info, int nbopd); -extern double multimax_varinfo(T_irdata *irdata, T_varinfo *info, int nbopd); +extern int multimax(char *var_def, double *var_val, int size, char nb_def, double nb_val, char *res_def, double *res_val); +extern int multimax_varinfo(T_irdata *irdata, T_varinfo *info, char nb_def, double nb_val, char *res_def, double *res_val); extern int modulo_def(int, int); extern double modulo(double, double); |} @@ -610,6 +618,9 @@ extern char lis_varinfo_def(T_irdata *irdata, T_varinfo *info); extern double lis_varinfo_val(T_irdata *irdata, T_varinfo *info); extern char lis_varinfo_tab_def(T_irdata *irdata, T_varinfo *info, int idx); extern double lis_varinfo_tab_val(T_irdata *irdata, T_varinfo *info, int idx); +extern int lis_varinfo_tab(T_irdata *irdata, T_varinfo *info, char idx_def, double idx_val, char *res_def, double *res_val); +extern char *lis_varinfo_ptr_def(T_irdata *irdata, T_varinfo *info); +extern double *lis_varinfo_ptr_val(T_irdata *irdata, T_varinfo *info); extern void ecris_varinfo(T_irdata *irdata, T_varinfo *info, char def, double val); extern void ecris_varinfo_tab(T_irdata *irdata, T_varinfo *info, int idx, char def, double val); extern void pr_var(T_print_context *pr_ctx, T_irdata *irdata, char *nom); @@ -621,13 +632,13 @@ let gen_decl_functions fmt (cprog : Mir.program) = let functions = Com.TargetMap.bindings cprog.program_functions in let pp_args fmt args = List.iteri - (fun i _ -> Pp.fpr fmt ", char def_arg%d, double val_arg%d" i i) + (fun i _ -> Pp.fpr fmt ", char arg_def%d, double arg_val%d" i i) args in Format.fprintf fmt "@[%a@]@," (Format.pp_print_list (fun fmt (fn, fd) -> Format.fprintf fmt - "extern int %s(T_irdata* irdata, char *def_res, double *val_res%a);" + "extern int %s(T_irdata* irdata, char *res_def, double *res_val%a);" fn pp_args fd.Mir.target_args)) functions @@ -994,25 +1005,51 @@ void aff_val(const char *nom, const T_irdata *irdata, int indice, int niv, const #endif /* FLG_TRACE */ +T_event *event(T_irdata *irdata, char idx_def, double idx_val) { + int idx; + if (idx_def == 0) return NULL; + idx = (int)idx_val; + if (idx < 0 || irdata->nb_events <= idx) return NULL; + return irdata->events[idx]; +} + +int size_varinfo(T_varinfo *info, char *res_def, double *res_val) { + *res_def = 0; + *res_val = 0.0; + if (info == NULL) { + return *res_def; + } + *res_def = 1; + *res_val = (double)info->size; + return *res_def; +} + T_discord *no_error(T_irdata *irdata) { return NULL; } -int multimax_def(int nbopd, char *var, int size) { - int i = 0; - for (i = 0; i < nbopd && i < size; i++) { - if (var[i] == 1) return 1; +int multimax(char *var_def, double *var_val, int size, char nb_def, double nb_val, char *res_def, double *res_val) { + int i; + int nb; + *res_def = 0; + *res_val = 0.0; + if (var_def == NULL || var_val == NULL) return *res_def; + if (nb_def == 0) return *res_def; + nb = (int)nb_val; + for (i = 0; i < nb && i < size; i++) { + if (var_def[i] == 1) *res_def = 1; + if (var_val[i] >= *res_val) *res_val = var_val[i]; } - return 0; + return *res_def; } -double multimax(int nbopd, double *var, int size) { - int i = 0; - double s = 0.0; - for (i = 0; i < nbopd && i < size; i++) { - if (var[i] >= s) s = var[i]; - } - return s; +int multimax_varinfo(T_irdata *irdata, T_varinfo *info, char nb_def, double nb_val, char *res_def, double *res_val) { + char *var_def = lis_varinfo_ptr_def(irdata, info); + double *var_val = lis_varinfo_ptr_val(irdata, info); + *res_def = 0; + *res_val = 0.0; + if (irdata == NULL || info == NULL) return *res_def; + return multimax(var_def, var_val, info->size, nb_def, nb_val, res_def, res_val); } int modulo_def(int a, int b) { @@ -1305,6 +1342,8 @@ T_irdata *cree_irdata(void) { irdata->err_archive = NULL; irdata->nb_err_archive = 0; init_erreur(irdata); + irdata->events = NULL; + irdata->nb_events = 0; irdata->ctx_pr_out.std = stdout; irdata->ctx_pr_out.indent = 0; irdata->ctx_pr_out.is_newline = 1; @@ -1578,6 +1617,46 @@ double lis_varinfo_tab_val(T_irdata *irdata, T_varinfo *info, int idx) { } } +int lis_varinfo_tab(T_irdata *irdata, T_varinfo *info, char idx_def, double idx_val, char *res_def, double *res_val) { + int idx; + *res_def = 0; + *res_val = 0.0; + if (irdata == NULL || info == NULL || idx_def == 0) return *res_def; + idx = (int)idx_val; + *res_def = lis_varinfo_tab_def(irdata, info, idx); + *res_val = lis_varinfo_tab_val(irdata, info, idx); + return *res_def; +} + + +char *lis_varinfo_ptr_def(T_irdata *irdata, T_varinfo *info) { + if (irdata == NULL || info == NULL) return NULL; + switch (info->loc_cat) { + case EST_SAISIE: + return &(irdata->def_saisie[info->idx]); + case EST_CALCULEE: + return &(irdata->def_calculee[info->idx]); + case EST_BASE: + return &(irdata->def_base[info->idx]); + default: + return NULL; + } +} + +double *lis_varinfo_ptr_val(T_irdata *irdata, T_varinfo *info) { + if (irdata == NULL || info == NULL) return NULL; + switch (info->loc_cat) { + case EST_SAISIE: + return &(irdata->saisie[info->idx]); + case EST_CALCULEE: + return &(irdata->calculee[info->idx]); + case EST_BASE: + return &(irdata->base[info->idx]); + default: + return NULL; + } +} + void ecris_varinfo(T_irdata *irdata, T_varinfo *info, char def, double val) { if (irdata == NULL || info == NULL) return; if (def == 0) { @@ -1685,43 +1764,15 @@ void pr_err_var(T_irdata *irdata, char *nom) { if ef.is_var then ( pr - "char multimax_%s_def(T_irdata *irdata, char nb_def, double nb_val, \ - char idx_def, double idx_val) {\n" - f; - pr " int nb;\n"; - pr " int idx;\n"; - pr " T_varinfo *info;\n"; - pr " int i;\n"; - pr " if (nb_def == 0 || idx_def == 0) return 0;\n"; - pr " idx = (int)floor(idx_val);\n"; - pr " if (idx < 0 || irdata->nb_events <= idx) return 0;\n"; - pr " info = irdata->events[idx]->field_%s_var;\n" f; - pr " nb = (int)floor(nb_val);\n"; - pr " for (i = 0; i < nb && i < info->size; i++) {\n"; - pr " if (lis_varinfo_tab_def(irdata, info, i) == 1) return 1;\n"; - pr " }\n"; - pr " return 0;\n"; - pr "}\n\n"; - - pr - "char multimax_%s_val(T_irdata *irdata, char nb_def, double nb_val, \ - char idx_def, double idx_val) {\n" + "T_varinfo *event_field_%s_var(T_irdata *irdata, char idx_def, \ + double idx_val) {\n" f; - pr " int nb;\n"; - pr " int idx;\n"; - pr " T_varinfo *info;\n"; - pr " int i;\n"; - pr " double s = 0.0;\n"; - pr " if (nb_def == 0 || idx_def == 0) return 0;\n"; - pr " idx = (int)floor(idx_val);\n"; - pr " if (idx < 0 || irdata->nb_events <= idx) return 0;\n"; - pr " info = irdata->events[idx]->field_%s_var;\n" f; - pr " nb = (int)floor(nb_val);\n"; - pr " for (i = 0; i < nb && i < info->size; i++) {\n"; - pr " double v = lis_varinfo_tab_val(irdata, info, i);\n"; - pr " if (v >= s) s = v;\n"; + pr " T_varinfo *info = NULL;\n"; + pr " int idx = (int)floor(idx_val);\n"; + pr " if (idx_def != 1 || idx < 0 || irdata->nb_events <= idx) {\n"; + pr " return NULL;\n"; pr " }\n"; - pr " return s;\n"; + pr " return irdata->events[idx]->field_%s_var;\n" f; pr "}\n\n")) cprog.program_event_fields diff --git a/src/mlang/backend_compilers/dgfip_varid.ml b/src/mlang/backend_compilers/dgfip_varid.ml index aeda77f22..b27702d16 100644 --- a/src/mlang/backend_compilers/dgfip_varid.ml +++ b/src/mlang/backend_compilers/dgfip_varid.ml @@ -62,23 +62,23 @@ let gen_ref_val i vn off = Pp.spr "*(%s%s)" (gen_ref_val_ptr i vn) off (* arguments accessors *) -let gen_arg_def i = Pp.spr "def_arg%d" i +let gen_arg_def i = Pp.spr "arg_def%d" i -let gen_arg_val i = Pp.spr "val_arg%d" i +let gen_arg_val i = Pp.spr "arg_val%d" i -let gen_arg_def_ptr i = Pp.spr "(&def_arg%d)" i +let gen_arg_def_ptr i = Pp.spr "(&arg_def%d)" i -let gen_arg_val_ptr i = Pp.spr "(&val_arg%d)" i +let gen_arg_val_ptr i = Pp.spr "(&arg_val%d)" i (* result accessors *) -let gen_res_def () = Pp.spr "(*def_res)" +let gen_res_def () = Pp.spr "(*res_def)" -let gen_res_val () = Pp.spr "(*val_res)" +let gen_res_val () = Pp.spr "(*res_val)" -let gen_res_def_ptr () = Pp.spr "def_res" +let gen_res_def_ptr () = Pp.spr "res_def" -let gen_res_val_ptr () = Pp.spr "val_res" +let gen_res_val_ptr () = Pp.spr "res_val" (* generic accessors *) diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index fa1cde717..1bb930f7f 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -151,6 +151,10 @@ module Err = struct in Errors.raise_spanned_error msg pos + let unknown_attribut attr pos = + let msg = Format.sprintf "unknown attribute \"%s\"" attr in + Errors.raise_spanned_error msg pos + let tmp_vars_have_no_attrs pos = Errors.raise_spanned_error "temporary variables have no attributes" pos @@ -980,10 +984,17 @@ let rec fold_var_expr List.fold_left (fun res set_value -> match set_value with - | Com.VarValue v -> - if is_filter then - Err.forbidden_expresion_in_filter (Pos.get_position v); - fold_var v (OneOf None) env res + | Com.VarValue (a, a_pos) -> ( + if is_filter then Err.forbidden_expresion_in_filter a_pos; + match a with + | VarAccess v -> fold_var (v, a_pos) (OneOf None) env res + | FieldAccess (ie, f, _) -> + let f_name, f_pos = f in + (match StrMap.find_opt f_name env.prog.prog_event_fields with + | Some ef when ef.is_var -> () + | Some _ -> Err.event_field_is_not_a_reference f_name f_pos + | None -> Err.unknown_event_field f_name f_pos); + fold_var_expr fold_var is_filter acc ie env) | Com.FloatValue _ -> res | Com.IntervalValue (bn, en) -> if Pos.unmark bn > Pos.unmark en then @@ -997,10 +1008,19 @@ let rec fold_var_expr let acc = fold_var_expr fold_var is_filter acc e1 env in fold_var_expr fold_var is_filter acc e2 env | Unop (_op, e) -> fold_var_expr fold_var is_filter acc e env - | Index (t, e) -> + | Index ((VarAccess t, pos), e) -> if is_filter then Err.forbidden_expresion_in_filter expr_pos; let acc = fold_var_expr fold_var is_filter acc e env in - fold_var t (OneOf (Some ())) env acc + fold_var (t, pos) (OneOf (Some ())) env acc + | Index ((FieldAccess (ie, f, _), _), e) -> + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + let f_name, f_pos = f in + (match StrMap.find_opt f_name env.prog.prog_event_fields with + | Some ef when ef.is_var -> () + | Some _ -> Err.event_field_is_not_a_reference f_name f_pos + | None -> Err.unknown_event_field f_name f_pos); + let acc = fold_var_expr fold_var is_filter acc ie env in + fold_var_expr fold_var is_filter acc e env | Conditional (e1, e2, e3_opt) -> ( let acc = fold_var_expr fold_var is_filter acc e1 env in let acc = fold_var_expr fold_var is_filter acc e2 env in @@ -1024,13 +1044,13 @@ let rec fold_var_expr match var_expr with | Var (VarAccess var), var_pos -> fold_var (var, var_pos) Both env acc - | Var (FieldAccess (i, f, _)), _access_pos -> + | Var (FieldAccess (e, f, _)), _access_pos -> let f_name, f_pos = f in (match StrMap.find_opt f_name env.prog.prog_event_fields with | Some ef when ef.is_var -> () | Some _ -> Err.event_field_is_not_a_reference f_name f_pos | None -> Err.unknown_event_field f_name f_pos); - fold_var_expr fold_var is_filter acc i env + fold_var_expr fold_var is_filter acc e env | _ -> Err.second_arg_of_multimax (Pos.get_position var_expr)) | _ -> Err.multimax_require_two_args expr_pos) | Com.SumFunc -> check_func (-1) @@ -1077,11 +1097,11 @@ let rec fold_var_expr Err.unknown_domain Verif pos) cats; acc - | Attribut (v, a) -> + | Attribut ((VarAccess v, pos), a) -> let name, var_pos = match v with - | Mast.Normal name, var_pos -> (name, var_pos) - | Mast.Generic _, _ -> assert false + | Mast.Normal name -> (name, pos) + | Mast.Generic _ -> assert false in (match StrMap.find_opt name env.prog.prog_vars with | Some var -> @@ -1092,8 +1112,30 @@ let rec fold_var_expr match StrMap.find_opt name env.tmp_vars with | Some _ -> Err.tmp_vars_have_no_attrs var_pos | None -> ())); - fold_var v Both env acc - | Size v -> fold_var v Both env acc + fold_var (v, pos) Both env acc + | Attribut ((FieldAccess (e, f, _), _), a) -> + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + let f_name, f_pos = f in + (match StrMap.find_opt f_name env.prog.prog_event_fields with + | Some ef when ef.is_var -> + let attr = Pos.unmark a in + let fold _ (cvd : Com.CatVar.data) res = + res || StrMap.mem attr cvd.attributs + in + if not (Com.CatVar.Map.fold fold env.prog.prog_var_cats false) then + Err.unknown_attribut attr (Pos.get_position a) + | Some _ -> Err.event_field_is_not_a_reference f_name f_pos + | None -> Err.unknown_event_field f_name f_pos); + fold_var_expr fold_var is_filter acc e env + | Size (VarAccess v, pos) -> fold_var (v, pos) Both env acc + | Size (FieldAccess (e, f, _), _) -> + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + let f_name, f_pos = f in + (match StrMap.find_opt f_name env.prog.prog_event_fields with + | Some ef when ef.is_var -> () + | Some _ -> Err.event_field_is_not_a_reference f_name f_pos + | None -> Err.unknown_event_field f_name f_pos); + fold_var_expr fold_var is_filter acc e env | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes -> if is_filter then Err.forbidden_expresion_in_filter expr_pos; acc @@ -2193,21 +2235,13 @@ let eval_expr_verif (prog : program) (verif : verif) | Com.Literal (Com.Float f) -> Some f | Literal Com.Undefined -> None | Var _ -> Err.variable_forbidden_in_filter (Pos.get_position expr) - | Attribut (m_var, m_attr) -> - let var = - match Pos.unmark m_var with - | Mast.Normal var -> var - | _ -> assert false - in + | Attribut ((VarAccess v, _), m_attr) -> + let var = match v with Mast.Normal var -> var | _ -> assert false in let attrs = Com.Var.attrs (StrMap.find var prog.prog_vars) in let m_val = StrMap.find (Pos.unmark m_attr) attrs in Some (float (Pos.unmark m_val)) - | Size m_var -> ( - let var = - match Pos.unmark m_var with - | Mast.Normal var -> var - | _ -> assert false - in + | Size (VarAccess v, _) -> ( + let var = match v with Mast.Normal var -> var | _ -> assert false in match Com.Var.is_table (StrMap.find var prog.prog_vars) with | Some sz -> Some (float sz) | None -> Some 1.0) @@ -2337,7 +2371,7 @@ let eval_expr_verif (prog : program) (verif : verif) in Some (if res = positive then 1.0 else 0.0)) | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes | Index _ - | FuncCallLoop _ | Loop _ -> + | FuncCallLoop _ | Loop _ | Attribut _ | Size _ -> assert false in aux expr @@ -2807,12 +2841,27 @@ let complete_vars_stack (prog : program) : program = assert false and aux_expr tdata (expr, _pos) = match expr with - | Com.TestInSet (_, me, _) + | Com.TestInSet (_, me, values) -> + let fold (nb, sz, nbRef, tdata) = function + | Com.VarValue (FieldAccess (mei, _, _), _) -> + let nb', sz', nbRef', tdata = aux_expr tdata mei in + (max nb nb', max sz sz', max nbRef nbRef', tdata) + | _ -> (nb, sz, nbRef, tdata) + in + let nb', sz', nbRef', tdata = + List.fold_left fold (0, 0, 0, tdata) values + in + let nb'', sz'', nbRef'', tdata = aux_expr tdata me in + (max nb' nb'', max sz' sz'', max nbRef' nbRef'', tdata) | Com.Unop (_, me) - | Com.Index (_, me) - | Com.Var (FieldAccess (me, _, _)) -> + | Com.Index ((VarAccess _, _), me) + | Com.Var (FieldAccess (me, _, _)) + | Com.Size (FieldAccess (me, _, _), _) + | Com.Attribut ((FieldAccess (me, _, _), _), _) -> aux_expr tdata me - | Com.Comparison (_, me0, me1) | Com.Binop (_, me0, me1) -> + | Com.Index ((FieldAccess (me0, _, _), _), me1) + | Com.Comparison (_, me0, me1) + | Com.Binop (_, me0, me1) -> let nb0, sz0, nbRef0, tdata = aux_expr tdata me0 in let nb1, sz1, nbRef1, tdata = aux_expr tdata me1 in (max nb0 nb1, max sz0 sz1, max nbRef0 nbRef1, tdata) diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index db4605231..b2e3bf8b1 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -543,11 +543,16 @@ let rec expand_expression (const_map : const_context) (loop_map : loop_context) List.map (fun set_value -> match set_value with - | VarValue set_var -> ( - match expand_variable const_map loop_map set_var with - | AtomLiteral (Float f), var_pos -> FloatValue (f, var_pos) - | AtomVar var, var_pos -> VarValue (var, var_pos) - | _ -> assert false) + | VarValue (a, a_pos) -> ( + match a with + | VarAccess v -> ( + match expand_variable const_map loop_map (v, a_pos) with + | AtomLiteral (Float f), var_pos -> FloatValue (f, var_pos) + | AtomVar var, var_pos -> VarValue (VarAccess var, var_pos) + | _ -> assert false) + | FieldAccess (e, f, i_f) -> + let e' = expand_expression const_map loop_map e in + VarValue (FieldAccess (e', f, i_f), a_pos)) | FloatValue _ | IntervalValue _ -> set_value) values in @@ -563,15 +568,19 @@ let rec expand_expression (const_map : const_context) (loop_map : loop_context) | Unop (op, e) -> let e' = expand_expression const_map loop_map e in (Unop (op, e'), expr_pos) - | Index (t, i) -> - let t' = - match expand_variable const_map loop_map t with + | Index ((VarAccess t, t_pos), i) -> + let t', t_pos' = + match expand_variable const_map loop_map (t, t_pos) with | AtomVar v, v_pos -> (v, v_pos) | AtomLiteral (Float _), v_pos -> Err.constant_forbidden_as_table v_pos | _ -> assert false in let i' = expand_expression const_map loop_map i in - (Index (t', i'), expr_pos) + (Index ((VarAccess t', t_pos'), i'), expr_pos) + | Index ((FieldAccess (e, f, i_f), pos), i) -> + let e' = expand_expression const_map loop_map e in + let i' = expand_expression const_map loop_map i in + (Index ((FieldAccess (e', f, i_f), pos), i'), expr_pos) | Conditional (e1, e2, e3_opt) -> let e1' = expand_expression const_map loop_map e1 in let e2' = expand_expression const_map loop_map e2 in @@ -618,17 +627,23 @@ let rec expand_expression (const_map : const_context) (loop_map : loop_context) (Binop ((Or, expr_pos), res, loop_expr), expr_pos)) (Literal (Float 0.0), expr_pos) loop_exprs - | Attribut (var, a) -> ( - match expand_variable const_map loop_map var with - | AtomVar v, v_pos -> (Attribut ((v, v_pos), a), expr_pos) + | Attribut ((VarAccess v, pos), a) -> ( + match expand_variable const_map loop_map (v, pos) with + | AtomVar v, v_pos -> (Attribut ((VarAccess v, v_pos), a), expr_pos) | AtomLiteral (Float _), v_pos -> Err.constant_cannot_have_an_attribut v_pos | _ -> assert false) - | Size var -> ( - match expand_variable const_map loop_map var with - | AtomVar v, v_pos -> (Size (v, v_pos), expr_pos) + | Attribut ((FieldAccess (e, f, i), pos), a) -> + let e' = expand_expression const_map loop_map e in + (Attribut ((FieldAccess (e', f, i), pos), a), expr_pos) + | Size (VarAccess v, pos) -> ( + match expand_variable const_map loop_map (v, pos) with + | AtomVar v, v_pos -> (Size (VarAccess v, v_pos), expr_pos) | AtomLiteral (Float _), v_pos -> Err.constant_cannot_have_a_size v_pos | _ -> assert false) + | Size (FieldAccess (e, f, i), pos) -> + let e' = expand_expression const_map loop_map e in + (Size (FieldAccess (e', f, i), pos), expr_pos) | NbCategory _ | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes -> m_expr diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 3972353b1..77dd169ce 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -59,13 +59,17 @@ let rec translate_expression (p : Check_validity.program) List.map (function | FloatValue f -> FloatValue f - | VarValue (v, pos) -> + | VarValue (VarAccess v, pos) -> let new_v = match v with | Mast.Normal name -> StrMap.find name var_data | Mast.Generic _ -> assert false in - VarValue (new_v, pos) + VarValue (VarAccess new_v, pos) + | VarValue (FieldAccess (e, ((fn, _) as f), _), pos) -> + let new_e = translate_expression p var_data e in + let i_f = (StrMap.find fn p.prog_event_fields).index in + VarValue (FieldAccess (new_e, f, i_f), pos) | IntervalValue (bv, ev) -> IntervalValue (bv, ev)) values in @@ -90,10 +94,15 @@ let rec translate_expression (p : Check_validity.program) | Unop (op, e) -> let new_e = translate_expression p var_data e in Unop (op, new_e) - | Index (t, i) -> - let t_var = translate_variable var_data t in + | Index ((VarAccess t, pos), i) -> + let t_var, t_pos = translate_variable var_data (t, pos) in let new_i = translate_expression p var_data i in - Index (t_var, new_i) + Index ((VarAccess t_var, t_pos), new_i) + | Index ((FieldAccess (e, f, _), pos), i) -> + let new_e = translate_expression p var_data e in + let new_i = translate_expression p var_data i in + let i_f = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in + Index ((FieldAccess (new_e, f, i_f), pos), new_i) | Conditional (e1, e2, e3) -> let new_e1 = translate_expression p var_data e1 in let new_e2 = translate_expression p var_data e2 in @@ -114,43 +123,34 @@ let rec translate_expression (p : Check_validity.program) Var (FieldAccess (new_e, f, i)) | NbCategory cs -> NbCategory (Check_validity.mast_to_catvars cs p.prog_var_cats) - | Attribut (v, a) -> ( - if - CatVar.Map.fold - (fun _ CatVar.{ attributs; _ } res -> - res - && StrMap.fold - (fun attr _ res -> res && attr <> Pos.unmark a) - attributs true) - p.prog_var_cats true - then Errors.raise_spanned_error "unknown attribut" (Pos.get_position a); + | Attribut ((VarAccess v, v_pos), a) -> ( let v_name = - match Pos.unmark v with - | Mast.Normal v_name -> v_name - | _ -> assert false + match v with Mast.Normal v_name -> v_name | _ -> assert false in - match StrMap.find_opt v_name var_data with - | Some var -> ( - if Com.Var.is_ref var then Attribut (Pos.same_pos_as var v, a) - else - match StrMap.find_opt (Pos.unmark a) (Com.Var.attrs var) with - | Some l -> Literal (Float (float (Pos.unmark l))) - | None -> Literal Undefined) - | _ -> - let msg = Format.sprintf "unknown variable %s" v_name in - Errors.raise_spanned_error msg (Pos.get_position v)) - | Size v -> ( + let var = StrMap.find v_name var_data in + if Com.Var.is_ref var then Attribut ((VarAccess var, v_pos), a) + else + match StrMap.find_opt (Pos.unmark a) (Com.Var.attrs var) with + | Some l -> Literal (Float (float (Pos.unmark l))) + | None -> Literal Undefined) + | Attribut ((FieldAccess (e, f, _), pos), a) -> + let new_e = translate_expression p var_data e in + let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in + Attribut ((FieldAccess (new_e, f, i), pos), a) + | Size (VarAccess v, pos) -> ( let v_name = - match Pos.unmark v with - | Mast.Normal v_name -> v_name - | _ -> assert false + match v with Mast.Normal v_name -> v_name | _ -> assert false in let var = StrMap.find v_name var_data in - if Com.Var.is_ref var then Size (Pos.same_pos_as var v) + if Com.Var.is_ref var then Size (VarAccess var, pos) else match Com.Var.is_table var with | Some i -> Literal (Float (float_of_int i)) | None -> Literal (Float 1.0)) + | Size (FieldAccess (e, f, _), pos) -> + let new_e = translate_expression p var_data e in + let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in + Size (FieldAccess (new_e, f, i), pos) | NbAnomalies -> NbAnomalies | NbDiscordances -> NbDiscordances | NbInformatives -> NbInformatives diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index c93a34582..5fdb5c0f8 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -961,17 +961,18 @@ formula_kind: for_formula: | FOR lv = with_pos(loop_variables) COLON ft = formula { (lv, ft) } -lvalue_name: -| s = SYMBOL { parse_variable $sloc s } - -lvalue: -| s = with_pos(lvalue_name) i = with_pos(brackets)? { - let access = Pos.same_pos_as (Com.VarAccess (Pos.unmark s)) s in - (access, i) +var_access: +| s = symbol_with_pos { + let v = parse_variable $sloc (Pos.unmark s) in + Pos.same_pos_as (Com.VarAccess v) s } | EVENT_FIELD LPAREN idx = with_pos(expression) - COMMA f = symbol_with_pos RPAREN i = with_pos(brackets)? { - let access = (Com.FieldAccess (idx, f, -1), mk_position $sloc) in + COMMA f = symbol_with_pos RPAREN { + (Com.FieldAccess (idx, f, -1), mk_position $sloc) + } + +lvalue: +| access = var_access i = with_pos(brackets)? { (access, i) } @@ -1151,10 +1152,15 @@ enumeration: enumeration_item: | bounds = interval { bounds } +| EVENT_FIELD LPAREN idx = with_pos(expression) + COMMA field = symbol_with_pos RPAREN { + let pos = mk_position $sloc in + Com.VarValue (FieldAccess (idx, field, -1), pos) + } | s = SYMBOL { let pos = mk_position $sloc in match parse_variable_or_int $sloc s with - | ParseVar v -> Com.VarValue (v, pos) + | ParseVar v -> Com.VarValue (VarAccess v, pos) | ParseInt i -> Com.FloatValue (float_of_int i, pos) } @@ -1217,14 +1223,20 @@ product_expression: | DIV { Com.Div } | MOD { Com.Mod } -table_index_name: -s = SYMBOL { parse_variable $sloc s } - factor: | MINUS e = with_pos(factor) { Com.Unop (Minus, e) } | e = ternary_operator { e } | e = function_call { e } -| s = with_pos(table_index_name) i = with_pos(brackets) { Com.Index (s, i) } +| EVENT_FIELD LPAREN idx = with_pos(expression) + COMMA field = symbol_with_pos RPAREN i_opt = with_pos(brackets)? { + match i_opt with + | Some i -> Com.Index ((FieldAccess (idx, field, -1), mk_position $sloc), i) + | None -> Var (FieldAccess (idx, field, -1)) + } +| s = symbol_with_pos i = with_pos(brackets) { + let v = parse_variable $sloc (Pos.unmark s) in + Com.Index (Pos.same_pos_as (Com.VarAccess v) s, i) + } | a = with_pos(factor_atom) { match Pos.unmark a with | Com.AtomVar v -> Com.Var (VarAccess v) @@ -1263,15 +1275,10 @@ function_call: | NB_CATEGORY LPAREN cats = with_pos(var_category_id) RPAREN { NbCategory (Com.CatVar.Map.from_string_list cats) } -| ATTRIBUT LPAREN var = symbol_with_pos COMMA attr = symbol_with_pos RPAREN { - Attribut ((parse_variable $sloc (fst var), snd var), attr) - } -| EVENT_FIELD LPAREN m_expr = with_pos(sum_expression) COMMA field = symbol_with_pos RPAREN { - Var (FieldAccess (m_expr, field, -1)) - } -| SIZE LPAREN var = symbol_with_pos RPAREN { - Size (parse_variable $sloc (fst var), snd var) +| ATTRIBUT LPAREN access = var_access COMMA attr = symbol_with_pos RPAREN { + Attribut (access, attr) } +| SIZE LPAREN access = var_access RPAREN { Size access } | NB_ANOMALIES LPAREN RPAREN { NbAnomalies } | NB_DISCORDANCES LPAREN RPAREN { NbDiscordances } | NB_INFORMATIVES LPAREN RPAREN { NbInformatives } diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 1f3a0fc50..87f46c786 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -391,7 +391,7 @@ and 'v loop_variables = and 'v set_value = | FloatValue of float Pos.marked - | VarValue of 'v Pos.marked + | VarValue of 'v access Pos.marked | IntervalValue of int Pos.marked * int Pos.marked and 'v expression = @@ -401,7 +401,7 @@ and 'v expression = | Unop of unop * 'v m_expression | Comparison of comp_op Pos.marked * 'v m_expression * 'v m_expression | Binop of binop Pos.marked * 'v m_expression * 'v m_expression - | Index of 'v Pos.marked * 'v m_expression + | Index of 'v access Pos.marked * 'v m_expression | Conditional of 'v m_expression * 'v m_expression * 'v m_expression option | FuncCall of func Pos.marked * 'v m_expression list | FuncCallLoop of @@ -411,8 +411,8 @@ and 'v expression = | Loop of 'v loop_variables Pos.marked * 'v m_expression (** The loop is prefixed with the loop variables declarations *) | NbCategory of Pos.t CatVar.Map.t - | Attribut of 'v Pos.marked * string Pos.marked - | Size of 'v Pos.marked + | Attribut of 'v access Pos.marked * string Pos.marked + | Size of 'v access Pos.marked | NbAnomalies | NbDiscordances | NbInformatives @@ -611,10 +611,16 @@ let format_comp_op fmt op = | Eq -> "=" | Neq -> "!=") -let format_set_value format_variable fmt sv = +let format_access form_var form_expr fmt = function + | VarAccess v -> form_var fmt v + | FieldAccess (e, f, _) -> + Format.fprintf fmt "champ_evenement(%a, %s)" form_expr (Pos.unmark e) + (Pos.unmark f) + +let format_set_value form_var form_expr fmt sv = match sv with | FloatValue i -> Pp.fpr fmt "%f" (Pos.unmark i) - | VarValue v -> format_variable fmt (Pos.unmark v) + | VarValue m_acc -> format_access form_var form_expr fmt (Pos.unmark m_acc) | IntervalValue (i1, i2) -> Pp.fpr fmt "%d..%d" (Pos.unmark i1) (Pos.unmark i2) @@ -644,7 +650,7 @@ let rec format_expression form_var fmt = | TestInSet (belong, e, values) -> Format.fprintf fmt "(%a %sdans %a)" form_expr (Pos.unmark e) (if belong then "" else "non ") - (Pp.list_comma (format_set_value form_var)) + (Pp.list_comma (format_set_value form_var form_expr)) values | Comparison (op, e1, e2) -> Format.fprintf fmt "(%a %a %a)" form_expr (Pos.unmark e1) format_comp_op @@ -654,9 +660,10 @@ let rec format_expression form_var fmt = (Pos.unmark op) form_expr (Pos.unmark e2) | Unop (op, e) -> Format.fprintf fmt "%a %a" format_unop op form_expr (Pos.unmark e) - | Index (v, i) -> - Format.fprintf fmt "%a[%a]" form_var (Pos.unmark v) form_expr - (Pos.unmark i) + | Index (m_acc, i) -> + Format.fprintf fmt "%a[%a]" + (format_access form_var form_expr) + (Pos.unmark m_acc) form_expr (Pos.unmark i) | Conditional (e1, e2, e3) -> let pp_sinon fmt e = Format.fprintf fmt " sinon %a" form_expr e in Format.fprintf fmt "(si %a alors %a%a finsi)" form_expr (Pos.unmark e1) @@ -672,20 +679,21 @@ let rec format_expression form_var fmt = (format_loop_variables form_var) (Pos.unmark lvs) form_expr (Pos.unmark e) | Literal l -> format_literal fmt l - | Var (VarAccess v) -> form_var fmt v - | Var (FieldAccess (e, f, _)) -> - Format.fprintf fmt "champ_evenement(%a, %s)" form_expr (Pos.unmark e) - (Pos.unmark f) + | Var acc -> format_access form_var form_expr fmt acc | Loop (lvs, e) -> Format.fprintf fmt "pour %a%a" (format_loop_variables form_var) (Pos.unmark lvs) form_expr (Pos.unmark e) | NbCategory cs -> Format.fprintf fmt "nb_categorie(%a)" (CatVar.Map.pp_keys ()) cs - | Attribut (v, a) -> - Format.fprintf fmt "attribut(%a, %s)" form_var (Pos.unmark v) - (Pos.unmark a) - | Size v -> Format.fprintf fmt "taille(%a)" form_var (Pos.unmark v) + | Attribut (m_acc, a) -> + Format.fprintf fmt "attribut(%a, %s)" + (format_access form_var form_expr) + (Pos.unmark m_acc) (Pos.unmark a) + | Size m_acc -> + Format.fprintf fmt "taille(%a)" + (format_access form_var form_expr) + (Pos.unmark m_acc) | NbAnomalies -> Format.fprintf fmt "nb_anomalies()" | NbDiscordances -> Format.fprintf fmt "nb_discordances()" | NbInformatives -> Format.fprintf fmt "nb_informatives()" @@ -718,13 +726,10 @@ let format_print_arg form_var fmt = e min max let format_formula_decl form_var fmt = function - | VarDecl (access, idx, e) -> - (match Pos.unmark access with - | VarAccess v -> form_var fmt v - | FieldAccess (i, f, _) -> - Format.fprintf fmt "champ_evenement(%a,%s)" - (format_expression form_var) - (Pos.unmark i) (Pos.unmark f)); + | VarDecl (m_access, idx, e) -> + format_access form_var + (format_expression form_var) + fmt (Pos.unmark m_access); (match idx with | Some vi -> Format.fprintf fmt "[%a]" (format_expression form_var) (Pos.unmark vi) diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index d780c93f3..009f19d5e 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -249,7 +249,7 @@ and 'v loop_variables = and 'v set_value = | FloatValue of float Pos.marked - | VarValue of 'v Pos.marked + | VarValue of 'v access Pos.marked | IntervalValue of int Pos.marked * int Pos.marked and 'v expression = @@ -259,7 +259,7 @@ and 'v expression = | Unop of unop * 'v m_expression | Comparison of comp_op Pos.marked * 'v m_expression * 'v m_expression | Binop of binop Pos.marked * 'v m_expression * 'v m_expression - | Index of 'v Pos.marked * 'v m_expression + | Index of 'v access Pos.marked * 'v m_expression | Conditional of 'v m_expression * 'v m_expression * 'v m_expression option | FuncCall of func Pos.marked * 'v m_expression list | FuncCallLoop of @@ -269,8 +269,8 @@ and 'v expression = | Loop of 'v loop_variables Pos.marked * 'v m_expression (** The loop is prefixed with the loop variables declarations *) | NbCategory of Pos.t CatVar.Map.t - | Attribut of 'v Pos.marked * string Pos.marked - | Size of 'v Pos.marked + | Attribut of 'v access Pos.marked * string Pos.marked + | Size of 'v access Pos.marked | NbAnomalies | NbDiscordances | NbInformatives @@ -386,7 +386,12 @@ val format_binop : Pp.t -> binop -> unit val format_comp_op : Pp.t -> comp_op -> unit -val format_set_value : (Pp.t -> 'v -> unit) -> Pp.t -> 'v set_value -> unit +val format_set_value : + (Pp.t -> 'v -> unit) -> + (Pp.t -> 'v expression -> unit) -> + Pp.t -> + 'v set_value -> + unit val format_func : Pp.t -> func -> unit diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 5f1c864f7..7dc7ce50a 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -114,6 +114,18 @@ let rec expand_functions_expr (e : 'var Com.expression Pos.marked) : 'var Com.expression Pos.marked = let open Com in match Pos.unmark e with + | TestInSet (positive, e0, values) -> + let new_e0 = expand_functions_expr e0 in + let new_values = + let map = function + | Com.VarValue (FieldAccess (mei, f, i_f), pos) -> + let new_mei = expand_functions_expr mei in + Com.VarValue (FieldAccess (new_mei, f, i_f), pos) + | value -> value + in + List.map map values + in + Pos.same_pos_as (TestInSet (positive, new_e0, new_values)) e | Comparison (op, e1, e2) -> let new_e1 = expand_functions_expr e1 in let new_e2 = expand_functions_expr e2 in @@ -130,9 +142,13 @@ let rec expand_functions_expr (e : 'var Com.expression Pos.marked) : let new_e2 = expand_functions_expr e2 in let new_e3 = Option.map expand_functions_expr e3 in Pos.same_pos_as (Conditional (new_e1, new_e2, new_e3)) e - | Index (var, e1) -> + | Index ((VarAccess v, pos), e1) -> + let new_e1 = expand_functions_expr e1 in + Pos.same_pos_as (Index ((VarAccess v, pos), new_e1)) e + | Index ((FieldAccess (ie, f, i_f), pos), e1) -> + let new_ie = expand_functions_expr ie in let new_e1 = expand_functions_expr e1 in - Pos.same_pos_as (Index (var, new_e1)) e + Pos.same_pos_as (Index ((FieldAccess (new_ie, f, i_f), pos), new_e1)) e | Literal _ -> e | Var _ -> e | FuncCall ((SumFunc, _), args) -> @@ -182,23 +198,19 @@ let rec expand_functions_expr (e : 'var Com.expression Pos.marked) : expand_functions_expr arg, Pos.same_pos_as (Literal (Float 0.0)) e )) e - | FuncCall ((PresentFunc, pos), [ arg ]) -> - (* we do not expand this function as it deals specifically with undefined - variables *) - Pos.same_pos_as - (FuncCall ((PresentFunc, pos), [ expand_functions_expr arg ])) - e - | FuncCall ((ArrFunc, pos), [ arg ]) -> - (* we do not expand this function as it requires modulo or modf *) - Pos.same_pos_as - (FuncCall ((ArrFunc, pos), [ expand_functions_expr arg ])) - e - | FuncCall ((InfFunc, pos), [ arg ]) -> - (* we do not expand this function as it requires modulo or modf *) - Pos.same_pos_as - (FuncCall ((InfFunc, pos), [ expand_functions_expr arg ])) - e - | _ -> e + | FuncCall (fn, args) -> + Pos.same_pos_as (FuncCall (fn, List.map expand_functions_expr args)) e + | Attribut ((VarAccess _, _), _) -> e + | Attribut ((FieldAccess (ie, f, i_f), pos), a) -> + let new_ie = expand_functions_expr ie in + Pos.same_pos_as (Attribut ((FieldAccess (new_ie, f, i_f), pos), a)) e + | Size (VarAccess _, _) -> e + | Size (FieldAccess (ie, f, i_f), pos) -> + let new_ie = expand_functions_expr ie in + Pos.same_pos_as (Size (FieldAccess (new_ie, f, i_f), pos)) e + | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes + | FuncCallLoop _ | Loop _ | NbCategory _ -> + e let expand_functions (p : program) : program = let open Com in diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 0e398439c..843594da7 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -367,11 +367,23 @@ struct (fun or_chain set_value -> let equal_test = match set_value with - | Com.VarValue set_var -> - let new_set_var = - get_var_value ctx (Pos.unmark set_var) 0 - in - comparison Com.Eq new_e0 new_set_var + | Com.VarValue (VarAccess v, _) -> + let new_v = get_var_value ctx v 0 in + comparison Com.Eq new_e0 new_v + | Com.VarValue (FieldAccess (e, _, j), _) -> ( + let new_e = evaluate_expr ctx p e in + match new_e with + | Number z when N.(z >=. zero ()) -> + let i = Int64.to_int N.(to_int z) in + let events = List.hd ctx.ctx_events in + if 0 <= i && i < Array.length events then + match events.(i).(j) with + | Com.Numeric n -> n + | Com.RefVar v -> + let new_v = get_var_value ctx v 0 in + comparison Com.Eq new_e0 new_v + else Undefined + | _ -> Undefined) | Com.FloatValue i -> let val_i = Number (N.of_float (Pos.unmark i)) in comparison Com.Eq new_e0 val_i @@ -412,9 +424,25 @@ struct | Undefined -> Undefined) | Literal Undefined -> Undefined | Literal (Float f) -> Number (N.of_float f) - | Index (var, e1) -> - let idx = evaluate_expr ctx p e1 in - get_var_tab ctx var idx + | Index (m_acc, e1) -> ( + match Pos.unmark m_acc with + | VarAccess v -> + let idx = evaluate_expr ctx p e1 in + get_var_tab ctx (Pos.same_pos_as v m_acc) idx + | FieldAccess (e, _, j) -> ( + let new_e = evaluate_expr ctx p e in + match new_e with + | Number z when N.(z >=. zero ()) -> + let i = Int64.to_int N.(to_int z) in + let events = List.hd ctx.ctx_events in + if 0 <= i && i < Array.length events then + match events.(i).(j) with + | Com.RefVar v -> + let idx = evaluate_expr ctx p e1 in + get_var_tab ctx (Pos.same_pos_as v m_acc) idx + | Com.Numeric _ -> Undefined + else Undefined + | _ -> Undefined)) | Var (VarAccess var) -> get_var_value ctx var 0 | Var (FieldAccess (e, _, j)) -> ( let new_e = evaluate_expr ctx p e in @@ -472,7 +500,7 @@ struct let up = Int64.sub (N.to_int (roundf f)) 1L in let var_arg2_opt = match Pos.unmark arg2 with - | Var (VarAccess v) -> Some (v, Pos.get_position e) + | Var (VarAccess var) -> Some var | Var (FieldAccess (ei, _, j)) -> ( let new_ei = evaluate_expr ctx p ei in match new_ei with @@ -481,7 +509,7 @@ struct let events = List.hd ctx.ctx_events in if 0 <= i && i < Array.length events then match events.(i).(j) with - | Com.RefVar var -> Some (var, Pos.get_position e) + | Com.RefVar var -> Some var | Com.Numeric _ -> None else None | _ -> None) @@ -496,12 +524,12 @@ struct | Undefined -> None in let pos = Pos.get_position arg2 in + let access = (Com.VarAccess var_arg2, pos) in let access_index (i : int) : Int64.t option = cast_to_int @@ evaluate_expr ctx p ( Index - ( var_arg2, - (Literal (Float (float_of_int i)), pos) ), + (access, (Literal (Float (float_of_int i)), pos)), pos ) in let maxi = ref None in @@ -531,16 +559,52 @@ struct ctx.ctx_res <- List.tl ctx.ctx_res; res | FuncCall (_, _) -> assert false - | Attribut (var, a) -> ( - let var, _ = get_var ctx (Pos.unmark var) in - match StrMap.find_opt (Pos.unmark a) (Com.Var.attrs var) with - | Some l -> Number (N.of_float (float (Pos.unmark l))) - | None -> Undefined) - | Size var -> ( - let var, _ = get_var ctx (Pos.unmark var) in - match Com.Var.is_table var with - | Some i -> Number (N.of_float (float_of_int i)) - | None -> Number (N.of_float 1.0)) + | Attribut (m_acc, a) -> ( + match Pos.unmark m_acc with + | VarAccess v -> ( + let var, _ = get_var ctx v in + match StrMap.find_opt (Pos.unmark a) (Com.Var.attrs var) with + | Some l -> Number (N.of_float (float (Pos.unmark l))) + | None -> Undefined) + | FieldAccess (e, _, j) -> ( + let new_e = evaluate_expr ctx p e in + match new_e with + | Number z when N.(z >=. zero ()) -> + let i = Int64.to_int N.(to_int z) in + let events = List.hd ctx.ctx_events in + if 0 <= i && i < Array.length events then + match events.(i).(j) with + | Com.RefVar var -> ( + match + StrMap.find_opt (Pos.unmark a) (Com.Var.attrs var) + with + | Some l -> Number (N.of_float (float (Pos.unmark l))) + | None -> Undefined) + | Com.Numeric _ -> Undefined + else Undefined + | _ -> Undefined)) + | Size m_acc -> ( + match Pos.unmark m_acc with + | VarAccess v -> ( + let var, _ = get_var ctx v in + match Com.Var.is_table var with + | Some i -> Number (N.of_float (float_of_int i)) + | None -> Number (N.of_float 1.0)) + | FieldAccess (e, _, j) -> ( + let new_e = evaluate_expr ctx p e in + match new_e with + | Number z when N.(z >=. zero ()) -> + let i = Int64.to_int N.(to_int z) in + let events = List.hd ctx.ctx_events in + if 0 <= i && i < Array.length events then + match events.(i).(j) with + | Com.RefVar var -> ( + match Com.Var.is_table var with + | Some i -> Number (N.of_float (float_of_int i)) + | None -> Number (N.of_float 1.0)) + | Com.Numeric _ -> Undefined + else Undefined + | _ -> Undefined)) | NbAnomalies -> Number (N.of_float (float ctx.ctx_nb_anos)) | NbDiscordances -> Number (N.of_float (float ctx.ctx_nb_discos)) | NbInformatives -> Number (N.of_float (float ctx.ctx_nb_infos)) From 8eb7e7fd58a059235916f9be67d1dace60ffe80b Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 11 Feb 2025 16:24:48 +0100 Subject: [PATCH 26/32] Lecture des fichers de test correctifs --- .../dgfip_c/ml_primitif/ml_driver/common.ml | 11 + .../dgfip_c/ml_primitif/ml_driver/main.ml | 137 +++++--- .../ml_primitif/ml_driver/read_test.ml | 2 + m_ext/2023/cibles.m | 5 +- src/mlang/m_ir/com.ml | 37 ++- src/mlang/m_ir/com.mli | 8 + src/mlang/m_ir/mir_interpreter.ml | 115 ++++--- src/mlang/m_ir/mir_interpreter.mli | 6 +- src/mlang/test_framework/test_interpreter.ml | 164 ++++++---- tests/2023/corr/david2 | 293 ++++++++++++++++++ tests/2023/corr/vanpeperstraetestil31bis | 29 ++ 11 files changed, 636 insertions(+), 171 deletions(-) create mode 100644 tests/2023/corr/david2 create mode 100644 tests/2023/corr/vanpeperstraetestil31bis diff --git a/examples/dgfip_c/ml_primitif/ml_driver/common.ml b/examples/dgfip_c/ml_primitif/ml_driver/common.ml index 4283aaef0..201d1f01b 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/common.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/common.ml @@ -1,3 +1,14 @@ module StrSet = Set.Make(String) module StrMap = Map.Make(String) +type rappel = + float + * float + * string + * float + * float + * float option + * float option + * float + * float option + diff --git a/examples/dgfip_c/ml_primitif/ml_driver/main.ml b/examples/dgfip_c/ml_primitif/ml_driver/main.ml index 1f0bde022..6781e678d 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/main.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/main.ml @@ -1,32 +1,72 @@ open Common +type instance = { + nom : string; + label : string; + vars : float StrMap.t; + events : rappel list; + expectedVars : float StrMap.t; + expectedAnos : StrSet.t; +} + +let new_instance nom = { + nom; + label = ""; + vars = StrMap.empty; + events = []; + expectedVars = StrMap.empty; + expectedAnos = StrSet.empty; +} + let read_test filename = let test = Read_test.read_test filename in - let tgv = M.TGV.alloc_tgv () in - let evt_list, res_prim, ctl_prim = - let fold_prim (evt_list, res_prim, ctl_prim) s = - match s with - | `EntreesPrimitif pl -> - List.iter (fun (code, montant) -> M.TGV.set tgv code montant) pl; - evt_list, res_prim, ctl_prim - | `ResultatsPrimitif pl -> - let res_prim = - let fold res (code, montant) = StrMap.add code montant res in - List.fold_left fold res_prim pl - in - evt_list, res_prim, ctl_prim - | `ControlesPrimitif el -> - let ctl_prim = - let fold err e = StrSet.add e err in - List.fold_left fold ctl_prim el - in - evt_list, res_prim, ctl_prim - | `EntreesRappels evt_list -> evt_list, res_prim, ctl_prim - | _ -> evt_list, res_prim, ctl_prim - in - List.fold_left fold_prim ([], StrMap.empty, StrSet.empty) test + let fold_prim (nom, inst, insts) s = + match s with + | `Nom noms -> + let nom = String.concat " " noms in + let inst = {inst with nom} in + let insts = List.map (fun i -> {i with nom}) insts in + (nom, inst, insts) + | `EntreesPrimitif pl -> + let vars = + let fold res (code, montant) = StrMap.add code montant res in + List.fold_left fold StrMap.empty pl + in + (nom, {inst with vars}, insts) + | `ControlesPrimitif el -> + let expectedAnos = + let fold err e = StrSet.add e err in + List.fold_left fold StrSet.empty el + in + (nom, {inst with expectedAnos}, insts) + | `ResultatsPrimitif pl -> + let expectedVars = + let fold res (code, montant) = StrMap.add code montant res in + List.fold_left fold StrMap.empty pl + in + let inst = {inst with label = "primitif"; expectedVars} in + (nom, new_instance nom, inst :: insts) + | `EntreesCorrectif _ + | `ControlesCorrectif _ + | `ResultatsCorrectif _ -> (nom, inst, insts) + | `EntreesRappels events -> (nom, {inst with events}, insts) + | `ControlesRappels el -> + let expectedAnos = + let fold err e = StrSet.add e err in + List.fold_left fold StrSet.empty el + in + (nom, {inst with expectedAnos}, insts) + | `ResultatsRappels pl -> + let expectedVars = + let fold res (code, montant) = StrMap.add code montant res in + List.fold_left fold StrMap.empty pl + in + let inst = {inst with label = "correctif"; expectedVars} in + (nom, new_instance nom, inst :: insts) + | `Skip -> (nom, inst, insts) in - tgv, evt_list, res_prim, ctl_prim + let _, _, insts = List.fold_left fold_prim ("", new_instance "", []) test in + insts let check_result tgv err expected_tgv expected_err = let result = ref true in @@ -131,25 +171,36 @@ let compare_dump out outexp = let run_test test_file annee_exec = Printf.printf "Testing %s...\n%!" test_file; let annee_calc = M.annee_calc () in - let tgv, evt_list, res_prim, ctl_prim = read_test test_file in - M.set_evt_list tgv evt_list; - let annee_revenu = M.TGV.get_int_def tgv "ANREV" annee_calc in - if annee_revenu <> annee_calc then ( - Printf.eprintf - "Attention, année calculette (%d) <> année revenu (%d)\n%!" - annee_calc - annee_revenu - ); - M.TGV.set_int tgv "IND_TRAIT" 4 (* = primitif *); - M.TGV.set_int tgv "ANCSDED" annee_exec; - M.init_errs tgv; - let _err = M.enchainement_primitif tgv in - M.export_errs tgv; - let err_set = - let add res e = StrSet.add e res in - List.fold_left add StrSet.empty (M.get_err_list tgv) + let insts = read_test test_file in + let rec run_insts res = function + | [] -> res + | inst :: insts -> + Printf.printf " Running %s:%s...\n%!" inst.nom inst.label; + let tgv = M.TGV.alloc_tgv () in + StrMap.iter (M.TGV.set tgv) inst.vars; + M.set_evt_list tgv inst.events; + let annee_revenu = M.TGV.get_int_def tgv "ANREV" annee_calc in + if annee_revenu <> annee_calc then ( + Printf.eprintf + "Attention, année calculette (%d) <> année revenu (%d)\n%!" + annee_calc + annee_revenu + ); + (match inst.label with + | "primitif" -> M.TGV.set_int tgv "IND_TRAIT" 4 + | "correctif" -> M.TGV.set_int tgv "IND_TRAIT" 5 + | _ -> M.TGV.set_int tgv "IND_TRAIT" 0); + M.TGV.set_int tgv "ANCSDED" annee_exec; + M.init_errs tgv; + let _err = M.enchainement_primitif tgv in + M.export_errs tgv; + let err_set = + let add res e = StrSet.add e res in + List.fold_left add StrSet.empty (M.get_err_list tgv) + in + res && check_result tgv err_set inst.expectedVars inst.expectedAnos in - check_result tgv err_set res_prim ctl_prim + run_insts true insts let main () = if Array.length Sys.argv < 2 then ( @@ -177,7 +228,7 @@ let main () = let rec loop = function | [] -> true | test_file :: files -> - run_test test_file annee_exec && ((* Gc.minor ();*) loop files) + run_test test_file annee_exec && (Gc.minor (); loop files) in match loop test_files with | true -> exit 0 diff --git a/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml b/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml index ea326eed5..0fba85140 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml @@ -1,3 +1,5 @@ +open Common + type file = { c: in_channel; mutable lines: string list; diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index 0faf0a84a..5ec1a1576 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -1031,6 +1031,7 @@ puis_quand nb_anomalies() = 0 faire cible enchainement_primitif_interpreteur: application: iliad; -V_IND_TRAIT = 4; # primitif -calculer cible enchainement_primitif; +si V_IND_TRAIT = 4 alors # primitif + calculer cible enchainement_primitif; +finsi diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 87f46c786..04baa959e 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -442,11 +442,44 @@ module Error = struct } let pp_descr fmt err = - Format.fprintf fmt "%s:%s:%s:%s:%s" (Pos.unmark err.famille) + Pp.fpr fmt "%s:%s:%s:%s:%s" (Pos.unmark err.famille) (Pos.unmark err.code_bo) (Pos.unmark err.sous_code) (Pos.unmark err.libelle) (Pos.unmark err.is_isf) - let compare (var1 : t) (var2 : t) = compare var1.name var2.name + let pp fmt err = Pp.fpr fmt "%s:%a" (Pos.unmark err.name) pp_descr err + + let compare (err1 : t) (err2 : t) = compare err1.name err2.name + + type error_t = t + + let error_pp = pp + + let error_compare = compare + + module Set = struct + include SetExt.Make (struct + type t = error_t + + let compare = error_compare + end) + + let pp ?(sep = ", ") ?(pp_elt = error_pp) (_ : unit) + (fmt : Format.formatter) (set : t) : unit = + pp ~sep ~pp_elt () fmt set + end + + module Map = struct + include MapExt.Make (struct + type t = error_t + + let compare = error_compare + end) + + let pp ?(sep = "; ") ?(pp_key = error_pp) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map + end end type print_std = StdOut | StdErr diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 009f19d5e..d29a58501 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -295,7 +295,15 @@ module Error : sig val pp_descr : Pp.t -> t -> unit + val pp : Pp.t -> t -> unit + val compare : t -> t -> int + + module Set : SetExt.T with type elt = t + + module Map : sig + include MapExt.T with type key = t + end end type print_std = StdOut | StdErr diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 843594da7..6e186b111 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -61,7 +61,7 @@ module type S = sig val update_ctx_with_events : ctx -> Mir.program -> - (Com.literal, Com.Var.t) Com.event_value IntMap.t list -> + (Com.literal, Com.Var.t) Com.event_value StrMap.t list -> unit type run_error = @@ -184,62 +184,57 @@ struct value_inputs let update_ctx_with_events (ctx : ctx) (p : Mir.program) - (events : (Com.literal, Com.Var.t) Com.event_value IntMap.t list) : unit = + (events : (Com.literal, Com.Var.t) Com.event_value StrMap.t list) : unit = let nbEvt = List.length events in let ctx_event_tab = Array.make nbEvt [||] in - let fold idx (evt : (Com.literal, Com.Var.t) Com.event_value IntMap.t) = - let nbEvtFields = IntMap.cardinal evt in - let nbProgFields = IntMap.cardinal p.program_event_field_idxs in - if nbEvtFields > nbProgFields then - Errors.raise_error - (Format.sprintf "Too much event fields: index %d for size %d" - (nbEvtFields - 1) nbProgFields); + let fold idx (evt : (Com.literal, Com.Var.t) Com.event_value StrMap.t) = + let nbProgFields = StrMap.cardinal p.program_event_fields in let map = Array.make nbProgFields (Com.Numeric Undefined) in - let iter id ev = - match IntMap.find_opt id p.program_event_field_idxs with - | Some fname -> ( - match StrMap.find_opt fname p.program_event_fields with - | Some ef -> ( - match (ev, ef.is_var) with - | Com.Numeric Com.Undefined, false -> - map.(id) <- Com.Numeric Undefined - | Com.Numeric (Com.Float f), false -> - map.(id) <- Com.Numeric (Number (N.of_float f)) - | Com.RefVar v, true -> map.(id) <- Com.RefVar v - | _ -> Errors.raise_error "Wrong event field type") - | None -> Errors.raise_error "Wrong event field") - | None -> - Errors.raise_error - (Format.sprintf "Too much event fields: index %d for size %d" id - nbProgFields) + for id = 0 to nbProgFields - 1 do + let fname = IntMap.find id p.program_event_field_idxs in + let ef = StrMap.find fname p.program_event_fields in + if ef.is_var then + map.(id) <- Com.RefVar (snd (StrMap.min_binding p.program_vars)) + done; + let iter' fname ev = + match StrMap.find_opt fname p.program_event_fields with + | Some ef -> ( + match (ev, ef.is_var) with + | Com.Numeric Com.Undefined, false -> + map.(ef.index) <- Com.Numeric Undefined + | Com.Numeric (Com.Float f), false -> + map.(ef.index) <- Com.Numeric (Number (N.of_float f)) + | Com.RefVar v, true -> map.(ef.index) <- Com.RefVar v + | _ -> Errors.raise_error "wrong event field type") + | None -> Errors.raise_error "unknown event field" in - IntMap.iter iter evt; + StrMap.iter iter' evt; ctx_event_tab.(idx) <- map; idx + 1 in ignore (List.fold_left fold 0 events); - let max_field_length = - StrMap.fold - (fun s _ r -> max r (String.length s)) - p.program_event_fields 0 - in - let pp_field fmt s = - let l = String.length s in - Format.fprintf fmt "%s%s" s (String.make (max_field_length - l + 1) ' ') - in - let pp_ev fmt = function - | Com.Numeric Undefined -> Pp.string fmt "indefini" - | Com.Numeric (Number v) -> N.format_t fmt v - | Com.RefVar v -> Pp.string fmt (Com.Var.name_str v) - in - for i = 0 to Array.length ctx_event_tab - 1 do - Format.eprintf "%d@." i; - let map = ctx_event_tab.(i) in - for j = 0 to Array.length map - 1 do - let s = IntMap.find j p.program_event_field_idxs in - Format.eprintf " %a%a@." pp_field s pp_ev map.(j) - done - done; + (* let max_field_length = + StrMap.fold + (fun s _ r -> max r (String.length s)) + p.program_event_fields 0 + in + let pp_field fmt s = + let l = String.length s in + Format.fprintf fmt "%s%s" s (String.make (max_field_length - l + 1) ' ') + in + let pp_ev fmt = function + | Com.Numeric Undefined -> Pp.string fmt "indefini" + | Com.Numeric (Number v) -> N.format_t fmt v + | Com.RefVar v -> Pp.string fmt (Com.Var.name_str v) + in + for i = 0 to Array.length ctx_event_tab - 1 do + Format.eprintf "%d@." i; + let map = ctx_event_tab.(i) in + for j = 0 to Array.length map - 1 do + let s = IntMap.find j p.program_event_field_idxs in + Format.eprintf " %a%a@." pp_field s pp_ev map.(j) + done + done;*) ctx.ctx_events <- [ ctx_event_tab ] type run_error = @@ -1240,9 +1235,9 @@ let prepare_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : unit = | _ -> () let evaluate_program (p : Mir.program) (inputs : Com.literal Com.Var.Map.t) - (events : (Com.literal, Com.Var.t) Com.event_value IntMap.t list) + (events : (Com.literal, Com.Var.t) Com.event_value StrMap.t list) (sort : Cli.value_sort) (roundops : Cli.round_ops) : - float option StrMap.t * StrSet.t = + Com.literal Com.Var.Map.t * Com.Error.Set.t = prepare_interp sort roundops; let module Interp = (val get_interp sort roundops : S) in let ctx = Interp.empty_ctx p in @@ -1250,22 +1245,18 @@ let evaluate_program (p : Mir.program) (inputs : Com.literal Com.Var.Map.t) Interp.update_ctx_with_events ctx p events; Interp.evaluate_program p ctx; let varMap = - let fold name (var : Com.Var.t) res = + let fold _ (var : Com.Var.t) res = if Com.Var.is_given_back var then - let fVal = - let litt = ctx.ctx_tgv.(Com.Var.loc_int var) in - match Interp.value_to_literal litt with - | Com.Float f -> Some f - | Com.Undefined -> None - in - StrMap.add name fVal res + let litt = ctx.ctx_tgv.(Com.Var.loc_int var) in + let fVal = Interp.value_to_literal litt in + Com.Var.Map.add var fVal res else res in - StrMap.fold fold p.program_vars StrMap.empty + StrMap.fold fold p.program_vars Com.Var.Map.empty in let anoSet = - let fold res (e, _) = StrSet.add (Pos.unmark e.Com.Error.name) res in - List.fold_left fold StrSet.empty ctx.ctx_exported_anos + let fold res (e, _) = Com.Error.Set.add e res in + List.fold_left fold Com.Error.Set.empty ctx.ctx_exported_anos in (varMap, anoSet) diff --git a/src/mlang/m_ir/mir_interpreter.mli b/src/mlang/m_ir/mir_interpreter.mli index 6bed42e65..c309d2abc 100644 --- a/src/mlang/m_ir/mir_interpreter.mli +++ b/src/mlang/m_ir/mir_interpreter.mli @@ -83,7 +83,7 @@ module type S = sig val update_ctx_with_events : ctx -> Mir.program -> - (Com.literal, Com.Var.t) Com.event_value IntMap.t list -> + (Com.literal, Com.Var.t) Com.event_value StrMap.t list -> unit (** Interpreter runtime errors *) @@ -163,10 +163,10 @@ val get_interp : Cli.value_sort -> Cli.round_ops -> (module S) val evaluate_program : Mir.program -> Com.literal Com.Var.Map.t -> - (Com.literal, Com.Var.t) Com.event_value IntMap.t list -> + (Com.literal, Com.Var.t) Com.event_value StrMap.t list -> Cli.value_sort -> Cli.round_ops -> - float option StrMap.t * StrSet.t + Com.literal Com.Var.Map.t * Com.Error.Set.t (** Main interpreter function *) val evaluate_expr : diff --git a/src/mlang/test_framework/test_interpreter.ml b/src/mlang/test_framework/test_interpreter.ml index 6c3de33b1..b96a48bd2 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -15,17 +15,24 @@ let find_var_of_name (p : Mir.program) (name : string Pos.marked) : Com.Var.t = try StrMap.find (Pos.unmark name) p.program_vars - with Not_found -> + with Not_found -> ( let name = Mir.find_var_name_by_alias p name in - StrMap.find name p.program_vars + try StrMap.find name p.program_vars + with Not_found -> + Cli.error_print "Variable inconnue: %s" name; + raise (Errors.StructuredError ("Fichier de test incorrect", [], None))) + +type instance = { + label : string; + vars : Com.literal Com.Var.Map.t; + events : (Com.literal, Com.Var.t) Com.event_value StrMap.t list; + expectedVars : float StrMap.t; + expectedAnos : StrSet.t; +} let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : - (Com.literal Com.Var.Map.t * float StrMap.t * StrSet.t) - * ((Com.literal, Com.Var.t) Com.event_value IntMap.t list - * float StrMap.t - * StrSet.t) - option = - let inputVars = + instance list = + let vars = let ancsded = find_var_of_name program ("V_ANCSDED", Pos.no_pos) in let ancsded_val = Com.Float (float_of_int (!Cli.income_year + 1)) in List.fold_left @@ -69,88 +76,125 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : | None -> Com.Numeric Com.Undefined in let toEvent (rappel : Irj_ast.rappel) = - IntMap.empty - |> IntMap.add 0 (toNum rappel.event_nb) - |> IntMap.add 1 (toNum rappel.rappel_nb) - |> IntMap.add 2 (from_var rappel.variable_code) - |> IntMap.add 3 (toNum rappel.change_value) - |> IntMap.add 4 (fromDirection rappel.direction) - |> IntMap.add 5 (optToNum rappel.penalty_code) - |> IntMap.add 6 (optToNum rappel.base_tolerance_legale) - |> IntMap.add 7 (toNum rappel.month_year) - |> IntMap.add 8 (optToNum rappel.decl_2042_rect) + StrMap.empty + |> StrMap.add "numero" (toNum rappel.event_nb) + |> StrMap.add "rappel" (toNum rappel.rappel_nb) + |> StrMap.add "code" (from_var rappel.variable_code) + |> StrMap.add "montant" (toNum rappel.change_value) + |> StrMap.add "sens" (fromDirection rappel.direction) + |> StrMap.add "penalite" (optToNum rappel.penalty_code) + |> StrMap.add "base_tl" (optToNum rappel.base_tolerance_legale) + |> StrMap.add "date" (toNum rappel.month_year) + |> StrMap.add "2042_rect" (optToNum rappel.decl_2042_rect) in List.map toEvent rappels in - let expectedVars vars_init = + let expVars vars_init = let fold res ((var, _), (value, _)) = let fVal = match value with Irj_ast.I i -> float i | Irj_ast.F f -> f in StrMap.add var fVal res in List.fold_left fold StrMap.empty vars_init in - let expectedAnos anos_init = + let expAnos anos_init = let fold res ano = StrSet.add ano res in List.fold_left fold StrSet.empty (List.map fst anos_init) in - let prim = - ( inputVars, - expectedVars t.prim.resultats_attendus, - expectedAnos t.prim.controles_attendus ) - in - let corr = - match t.rapp with - | None -> None - | Some rapp -> - Some - ( eventsList rapp.entrees_rappels, - expectedVars rapp.resultats_attendus, - expectedAnos rapp.controles_attendus ) - in - (prim, corr) + let ind_trait = find_var_of_name program ("V_IND_TRAIT", Pos.no_pos) in + match t.rapp with + | None -> + let vars = Com.Var.Map.add ind_trait (Com.Float 4.0) vars in + let expectedVars = expVars t.prim.resultats_attendus in + let expectedAnos = expAnos t.prim.controles_attendus in + [ { label = "primitif"; vars; events = []; expectedVars; expectedAnos } ] + | Some rapp -> + let corr = + let vars = Com.Var.Map.add ind_trait (Com.Float 5.0) vars in + let events = eventsList rapp.entrees_rappels in + let expectedVars = expVars rapp.resultats_attendus in + let expectedAnos = expAnos rapp.controles_attendus in + { label = "correctif"; vars; events; expectedVars; expectedAnos } + in + let expectedVars = expVars t.prim.resultats_attendus in + let expectedAnos = expAnos t.prim.controles_attendus in + if not (StrMap.is_empty expectedVars && StrSet.is_empty expectedAnos) then + let vars = Com.Var.Map.add ind_trait (Com.Float 4.0) vars in + let prim = + { label = "primitif"; vars; events = []; expectedVars; expectedAnos } + in + [ prim; corr ] + else [ corr ] exception InterpError of int let check_test (program : Mir.program) (test_name : string) (value_sort : Cli.value_sort) (round_ops : Cli.round_ops) : unit = - Cli.debug_print "Parsing %s..." test_name; - let t = Irj_file.parse_file test_name in - Cli.debug_print "Running test %s..." t.nom; - let (inputVars, expVars, expAnos), evtDatas = - to_MIR_function_and_inputs program t - in - let events = - match evtDatas with None -> [] | Some (events, _, _) -> events - in - Cli.debug_print "Executing program"; - (* Cli.debug_print "Combined Program (w/o verif conds):@.%a@." - Format_bir.format_program program; *) - let varMap, anoSet = - Mir_interpreter.evaluate_program program inputVars events value_sort - round_ops - in let check_vars exp vars = let test_error_margin = 0.01 in - let fold var f nb = + let fold vname f nb = let f' = - match StrMap.find_opt var vars with Some (Some f') -> f' | _ -> 0.0 + let var = + match StrMap.find_opt vname program.program_vars with + | Some var -> var + | None -> + Cli.error_print "Variable inconnue: %s" vname; + raise + (Errors.StructuredError ("Fichier de test incorrect", [], None)) + in + match Com.Var.Map.find_opt var vars with + | Some (Com.Float f') -> f' + | _ -> 0.0 in if abs_float (f -. f') > test_error_margin then ( - Cli.error_print "KO | %s expected: %f - evaluated: %f" var f f'; + Cli.error_print "KO | %s expected: %f - evaluated: %f" vname f f'; nb + 1) else nb in StrMap.fold fold exp 0 in - let check_anos exp rais = + let check_anos exp errSet = + let rais = + let fold e res = StrSet.add (Pos.unmark e.Com.Error.name) res in + Com.Error.Set.fold fold errSet StrSet.empty + in let missAnos = StrSet.diff exp rais in let unexAnos = StrSet.diff rais exp in StrSet.iter (Cli.error_print "KO | missing error: %s") missAnos; StrSet.iter (Cli.error_print "KO | unexpected error: %s") unexAnos; StrSet.cardinal missAnos + StrSet.cardinal unexAnos in - let nbErrs = check_vars expVars varMap + check_anos expAnos anoSet in - if nbErrs > 0 then raise (InterpError nbErrs) + let dbg_warning = !Cli.warning_flag in + let dbg_time = !Cli.display_time in + Cli.warning_flag := false; + Cli.display_time := false; + Cli.debug_print "Parsing %s..." test_name; + let t = Irj_file.parse_file test_name in + Cli.debug_print "Running test %s..." t.nom; + let insts = to_MIR_function_and_inputs program t in + let rec check = function + | [] -> () + | inst :: insts -> + Cli.debug_print "Executing program %s" inst.label; + (* Cli.debug_print "Combined Program (w/o verif conds):@.%a@." + Format_bir.format_program program; *) + let varMap, anoSet = + Mir_interpreter.evaluate_program program inst.vars inst.events + value_sort round_ops + in + let nbErrs = + check_vars inst.expectedVars varMap + + check_anos inst.expectedAnos anoSet + in + if nbErrs <= 0 then ( + Cli.debug_print "OK!"; + check insts) + else ( + Cli.debug_print "KO!"; + raise (InterpError nbErrs)) + in + check insts; + Cli.warning_flag := dbg_warning; + Cli.display_time := dbg_time type process_acc = string list * int StrMap.t @@ -168,6 +212,8 @@ let check_all_tests (p : Mir.program) (test_dir : string) Mir_interpreter.exit_on_rte := false; (* sort by increasing size, hoping that small files = simple tests *) Array.sort compare arr; + let dbg_warning = !Cli.warning_flag in + let dbg_time = !Cli.display_time in Cli.warning_flag := false; Cli.display_time := false; (* let _, finish = Cli.create_progress_bar "Testing files" in*) @@ -210,8 +256,8 @@ let check_all_tests (p : Mir.program) (test_dir : string) (new_s @ old_s, StrMap.union (fun _ x1 x2 -> Some (x1 + x2)) old_f new_f)) in (* finish "done!"; *) - Cli.warning_flag := true; - Cli.display_time := true; + Cli.warning_flag := dbg_warning; + Cli.display_time := dbg_time; Cli.result_print "Test results: %d successes" (List.length s); if StrMap.cardinal f = 0 then Cli.result_print "No failures!" diff --git a/tests/2023/corr/david2 b/tests/2023/corr/david2 new file mode 100644 index 000000000..5a6bf8476 --- /dev/null +++ b/tests/2023/corr/david2 @@ -0,0 +1,293 @@ +#NOM +David2 +#ENTREES-PRIMITIF +NOTRAIT/26 +ANREV/2023 +REGCO/1 +ANTIR/0.00 +ANTREIR/0.00 +TAXANT/0.00 +PCAPANT/0.00 +CHRANT/0.00 +TOTIRANT/0.00 +CSANT/0.00 +PRELCSANT/0.00 +PSOLANT/0.00 +PRELPSOLANT/0.00 +CVNANT/0.00 +CDISANT/0.00 +GLOANT/0.00 +RSE1ANT/0.00 +RSE5ANT/0.00 +RSE2ANT/0.00 +RSE3ANT/0.00 +RSE4ANT/0.00 +RSE6ANT/0.00 +CSG820ANT/0.00 +RSE8ANT/0.00 +RDANT/0.00 +ANTCR/0.00 +IRPSANT/0.00 +ANTRE/0.00 +NONMERANT/0.00 +NONRESTANT/0.00 +IDANT/0.00 +IDGLOANT/0.00 +IDRSEANT/0.00 +ACPASTOTPANT/0.00 +#CONTROLES-PRIMITIF +#RESULTATS-PRIMITIF +NBPT/1 +#ENTREES-RAPPELS +20241015/2/0AM/1/R/17//102024/ +20241015/3/0DA/1980/R/17//102024/ +20241015/7/1AJ/1000000/R/17//102024/ +20241115/8/1AJ/80000/R/03//112024/ +#CONTROLES-RAPPELS +#RESULTATS-RAPPELS +TL_IR/1 +NBMOIS2/4 +ILIIRNET/8172 +STRATIR17_2/8172 +RETX/0.80 +RETIR/65 +NATMAJ/1 +MAJTX1/0 +NMAJ1/0 +MAJTX3/20 +NMAJ3/1634 +MAJTX4/0 +NMAJ4/0 +IRCUM/9871 +IRNET/9871 +IRESTITIR/0 +ILITAXANET/0 +STRATTAXA17_2/0 +RETTAXA/0 +MAJTX1/0 +NMAJTAXA1/0 +MAJTXTAXA3/0 +NMAJTAXA3/0 +MAJTXTAXA4/0 +NMAJTAXA4/0 +TAXACUM/0 +TAXANET/0 +ILICAPNET/0 +STRATCAP17_2/0 +RETPCAP/0 +MAJTXPCAP1/0 +NMAJPCAP1/0 +MAJTXPCAP3/0 +NMAJPCAP3/0 +MAJTXPCAP4/0 +NMAJPCAP4/0 +PCAPCUM/0 +PCAPNET/0 +ILICHRNET/0 +STRATHR17_2/0 +RETHAUTREV/0 +MAJTXCHR1/0 +NMAJCHR1/0 +MAJTXCHR3/0 +NMAJCHR3/0 +MAJTXCHR4/0 +NMAJCHR4/0 +HAUTREVCUM/0 +HAUTREVNET/0 +ILITOTIRNET/8172 +INCTOTIR/65 +MAJOTOT28IR/0 +MAJO1758ATOT/1634 +MAJO4IRTOT/0 +TOTIRCUM/9871 +CSGC/0 +STRATCS17/0 +NATMAJC/0 +RETCS/0 +MAJTXC1/0 +NMAJC1/0 +MAJTXC4/0 +NMAJC4/0 +NAPCS/0 +CSNET/0 +MPSOL/0 +STRATPSOL17/0 +NATMAJP/0 +RETPSOL/0 +MAJTXP1/0 +NMAJPSOL1/0 +MAJTXP4/0 +NMAJPSOL4/0 +NAPPSOL/0 +PSOLNET/0 +CVNSALC/0 +STRATCVN17/0 +NATMAJCVN/0 +RETCVN/0 +MAJTXCVN1/0 +NMAJCVN1/0 +MAJTXCVN4/0 +NMAJCVN4/0 +NAPCVN/0 +CVNNET/0 +CDIS/0 +STRATCDIS17/0 +NATMAJCDIS/0 +RETCDIS/0 +MAJTXCDIS1/0 +NMAJCDIS1/0 +MAJTXCDIS4/0 +NMAJCDIS4/0 +NAPCDIS/0 +CDISNET/0 +CGLOA/0 +STRATGLO17/0 +NATMAJGLOA/0 +RETGLOA/0 +MAJTXGLO1/0 +NMAJGLO1/0 +MAJTXGLO4/0 +NMAJGLO4/0 +NAPGLOA/0 +CGLOANET/0 +RSE1/0 +STRATRSE117/0 +NATMAJRSE1/0 +RETRSE1/0 +MAJTXRSE11/0 +NMAJRSE11/0 +MAJTXRSE14/0 +NMAJRSE14/0 +NAPRSE1/0 +RSE1NET/0 +RSE5/0 +STRATRSE517/0 +NATMAJRSE5/0 +RETRSE5/0 +MAJTXRSE51/0 +NMAJRSE51/0 +MAJTXRSE54/0 +NMAJRSE54/0 +NAPRSE5/0 +RSE5NET/0 +RSE2/0 +STRATRSE217/0 +NATMAJRSE2/0 +RETRSE2/0 +MAJTXRSE21/0 +NMAJRSE21/0 +MAJTXRSE24/0 +NMAJRSE24/0 +NAPRSE2/0 +RSE2NET/0 +RSE3/0 +STRATRSE317/0 +NATMAJRSE3/0 +RETRSE3/0 +MAJTXRSE31/0 +NMAJRSE31/0 +MAJTXRSE34/0 +NMAJRSE34/0 +NAPRSE3/0 +RSE3NET/0 +RSE4/0 +STRATRSE417/0 +NATMAJRSE4/0 +RETRSE4/0 +MAJTXRSE41/0 +NMAJRSE41/0 +MAJTXRSE44/0 +NMAJRSE44/0 +NAPRSE4/0 +RSE4NET/0 +RSE6/0 +STRATRSE617/0 +NATMAJRSE6/0 +RETRSE6/0 +MAJTXRSE61/0 +NMAJRSE61/0 +MAJTXRSE64/0 +NMAJRSE64/0 +NAPRSE6/0 +RSE6NET/0 +MCSG820/0 +STRATC82017/0 +NATMAJC820/0 +RETCSG820/0 +MAJTXC8201/0 +NMAJC8201/0 +MAJTXC8204/0 +NMAJC8204/0 +NAPCSG820/0 +CSG820NET/0 +RSE8/0 +STRATRSE817/0 +NATMAJRSE8/0 +RETRSE8/0 +MAJTXRSE81/0 +NMAJRSE81/0 +MAJTXRSE84/0 +NMAJRSE84/0 +NAPRSE8/0 +RSE8NET/0 +RDSC/0 +STRATRD17/0 +NATMAJR/0 +RETRD/0 +MAJTXR1/0 +NMAJR1/0 +MAJTXR4/0 +NMAJR4/0 +NAPRD/0 +RDNET/0 +ILITOTPSNET/0 +INCTOTCS/0 +MAJOTOT28PS/0 +MAJO4PSTOT/0 +TOTPENCS/0 +NAPCR61/0 +RETIRCSTOT/65 +MAJO1728TOT/0 +MAJO4TOT/0 +IRPSCUM/9871 +RECUM/0 +TOTIRPS/9871 +NONMER/0 +NONREST/0 +NAPTEMP/9871 +NAPTEMPCX/9871 +IINETCALC/9871 +IINET/9871 +NAPT/9871 +IDEGR/0 +IREST/0 +ILI_SYNT_IR/8172 +ILI_SYNT_TAXA/0 +ILI_SYNT_CAP/0 +ILI_SYNT_CHR/0 +ILI_SYNT_TOTIR/8172 +NAPCOROLIR/9871 +VARPS/0 +NATIMP/1 +NAPCOROLCS/0 +IMPNET/9871 +IMPNETIR/9871 +IMPNETCS/0 +IMPNETPSOL/0 +IMPNETCSAL/0 +IMPNETCDIS/0 +IMPNETGLO/0 +IMPNETRSE/0 +IMPNETRSE6/0 +IMPNETC820/0 +IMPNETRD/0 +IMPNETPS/0 +DCSGD/0 +DGLOD/0 +DRSED/0 +IDCSG/0 +IDGLO/0 +IDRSE/0 +INDESSOC/0 +## + diff --git a/tests/2023/corr/vanpeperstraetestil31bis b/tests/2023/corr/vanpeperstraetestil31bis new file mode 100644 index 000000000..fd32fe08b --- /dev/null +++ b/tests/2023/corr/vanpeperstraetestil31bis @@ -0,0 +1,29 @@ +#NOM +David1 +#ENTREES-PRIMITIF +ANREV/2023 +REGCO/6 +0AC/1 +0DA/1994 +1AJ/50645 +7DB/1593 +7HB/797 +8HV/636 +BDF/1593 +SDP/100 +NIMPA/71 +NOTRAIT/23 +IRPSANT/1594 +TOTIRANT/1594 +ACPASTOTNANT/1594 +ACPASIRNANT/1594 +#CONTROLES-PRIMITIF +#RESULTATS-PRIMITIF +NBPT/1 +#ENTREES-RAPPELS +20241017/2/1AJ/50645/R/03//102024/ +20241117/3/7DB/1593/R/02//112024/ +#CONTROLES-RAPPELS +#RESULTATS-RAPPELS +## + From 21b45ca2dbcf43a9724165337b282133c4409409 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Thu, 13 Feb 2025 17:04:07 +0100 Subject: [PATCH 27/32] =?UTF-8?q?Pseudo-rebase=20=C3=A0=20la=20main?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .github/workflows/binary-releases.yml | 6 +- .github/workflows/check_correctness.yml | 6 +- .github/workflows/publish_doc.yml | 6 +- Makefile | 2 +- dune-project | 2 +- makefiles/mlang.mk | 15 +- src/dune | 10 +- src/main.ml | 10 +- .../backend_compilers/dgfip_compir_files.ml | 42 ++- .../backend_compilers/dgfip_gen_files.ml | 70 ++--- src/mlang/driver.ml | 16 +- src/mlang/m_frontend/check_validity.ml | 249 +++++++++++++----- src/mlang/m_frontend/check_validity.mli | 2 +- src/mlang/utils/errors.ml | 4 + src/mlang/utils/errors.mli | 2 + src/mlang/utils/strMap.ml | 2 + src/mlang/utils/strMap.mli | 2 + src/mlang/utils/strings.ml | 22 +- src/mlang/utils/strings.mli | 4 +- 19 files changed, 309 insertions(+), 163 deletions(-) diff --git a/.github/workflows/binary-releases.yml b/.github/workflows/binary-releases.yml index 09ce898d6..773935862 100644 --- a/.github/workflows/binary-releases.yml +++ b/.github/workflows/binary-releases.yml @@ -22,16 +22,16 @@ jobs: linux-build: # The type of runner that the job will run on - runs-on: ubuntu-latest + runs-on: ubuntu-22.04 needs: create-release # Steps represent a sequence of tasks that will be executed as part of the job steps: # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it - - uses: actions/checkout@v2 + - uses: actions/checkout@v4 - name: Opam modules cache - uses: actions/cache@v1 + uses: actions/cache@v4 env: cache-name: cache-opam-modules with: diff --git a/.github/workflows/check_correctness.yml b/.github/workflows/check_correctness.yml index 3b3608aaf..93e88e1d2 100644 --- a/.github/workflows/check_correctness.yml +++ b/.github/workflows/check_correctness.yml @@ -16,15 +16,15 @@ jobs: # This workflow contains a single job called "build" build: # The type of runner that the job will run on - runs-on: ubuntu-latest + runs-on: ubuntu-22.04 # Steps represent a sequence of tasks that will be executed as part of the job steps: # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it - - uses: actions/checkout@v2 + - uses: actions/checkout@v4 - name: Opam modules cache - uses: actions/cache@v1 + uses: actions/cache@v4 env: cache-name: cache-opam-modules with: diff --git a/.github/workflows/publish_doc.yml b/.github/workflows/publish_doc.yml index a2095e250..1d56144c0 100644 --- a/.github/workflows/publish_doc.yml +++ b/.github/workflows/publish_doc.yml @@ -7,12 +7,12 @@ on: jobs: deploy: - runs-on: ubuntu-latest + runs-on: ubuntu-22.04 steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v4 - name: Opam modules cache - uses: actions/cache@v1 + uses: actions/cache@v4 env: cache-name: cache-opam-modules with: diff --git a/Makefile b/Makefile index ccd177289..755ed41af 100644 --- a/Makefile +++ b/Makefile @@ -34,7 +34,7 @@ default: FORCE build all: FORCE quick_test tests test_dgfip_c_backend -clean: FORCE +clean: FORCE remise_a_zero_versionnage $(call make_in,$(DGFIP_DIR),clean_backend_all) rm -f doc/doc.html dune clean diff --git a/dune-project b/dune-project index 0034e6bc1..5e5a380f5 100644 --- a/dune-project +++ b/dune-project @@ -2,7 +2,7 @@ (name mlang) -(version 1.1.0) +(version %%VERSION%%) (generate_opam_files true) diff --git a/makefiles/mlang.mk b/makefiles/mlang.mk index a8de54286..7231a5b89 100644 --- a/makefiles/mlang.mk +++ b/makefiles/mlang.mk @@ -34,6 +34,10 @@ else git submodule update ir-calcul endif +remise_a_zero_versionnage: FORCE + sed -i 's/(version .*)/(version %%VERSION%%)/' dune-project + git checkout -- *.opam + ################################################## # Building the compiler ################################################## @@ -49,13 +53,22 @@ dune: FORCE ifeq ($(call is_in,),) $(call make_in,,$@) else + echo $(shell pwd) + sed -i 's/(version %%VERSION%%)/(version ${shell git describe --always --dirty --tag})/' dune-project LINKING_MODE=$(LINKING_MODE) dune build $(DUNE_OPTIONS) + $(call make_in_raw,,remise_a_zero_versionnage) endif build: FORCE | format dune +build-ci: DUNE_OPTIONS=--profile ci +build-ci: FORCE | dune + +build-release: DUNE_OPTIONS=--profile release +build-release: FORCE | dune + build-static: LINKING_MODE=static -build-static: FORCE build +build-static: FORCE build-release ################################################## # Testing the compiler diff --git a/src/dune b/src/dune index 0dc5ca563..0a773a7a3 100644 --- a/src/dune +++ b/src/dune @@ -1,7 +1,15 @@ (env (dev (flags - (:standard -warn-error -A)))) + (:standard -warn-error -a))) + ;; fail on warnings in CI mode + (ci + (flags + (:standard -w +a-4-40..42-44-45-70 -warn-error +a))) + ;; show warnings but still allow release in release mode + (release + (flags + (:standard -w +a-4-40..42-44-45-70 -warn-error -a)))) (rule (with-stdout-to diff --git a/src/main.ml b/src/main.ml index 3af45af72..78a3ed5ac 100644 --- a/src/main.ml +++ b/src/main.ml @@ -14,12 +14,4 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -open Mlang - -let () = - Printexc.record_backtrace true; - try ignore (Driver.main ()) with - | Exit -> () - | e -> - Format.eprintf "Uncaught exception: %s@." (Printexc.to_string e); - Format.eprintf "%s@." (Printexc.get_backtrace ()) +let () = Mlang.Driver.main () diff --git a/src/mlang/backend_compilers/dgfip_compir_files.ml b/src/mlang/backend_compilers/dgfip_compir_files.ml index c6ab0e6ad..fbc1f56a2 100644 --- a/src/mlang/backend_compilers/dgfip_compir_files.ml +++ b/src/mlang/backend_compilers/dgfip_compir_files.ml @@ -14,6 +14,12 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) +let open_file filename = + let folder = Filename.dirname !Cli.output_file in + let oc = open_out (Filename.concat folder filename) in + let fmt = Format.formatter_of_out_channel oc in + (oc, fmt) + (* Various flags used to control wicch data to put in each variable array *) type gen_opt = { with_verif : bool; @@ -210,7 +216,7 @@ let get_vars (cprog : Mir.program) is_ebcdic = idxo_opt, name, Option.map Pos.unmark tgv.alias, - Strings.sanitize_str tgv.descr, + Pos.unmark tgv.descr, tgv.typ, tgv.attrs, size ) @@ -1021,43 +1027,36 @@ extern struct S_erreur *tabErreurs[]; |}; Format.fprintf fmt "#endif /* _COMPIR_H_ */\n" -let open_file filename = - let oc = open_out filename in - let fmt = Format.formatter_of_out_channel oc in - (oc, fmt) - (* Generate the auxiliary files AND return the map of variables names to TGV ids *) let generate_compir_files flags (cprog : Mir.program) : unit = - let folder = Filename.dirname !Cli.output_file in - let vars = get_vars cprog Dgfip_options.(flags.flg_tri_ebcdic) in - let oc, fmt = open_file (Filename.concat folder "compir_restitue.c") in + let oc, fmt = open_file "compir_restitue.c" in gen_table_output fmt flags vars; close_out oc; - let oc, fmt = open_file (Filename.concat folder "compir_contexte.c") in + let oc, fmt = open_file "compir_contexte.c" in gen_table_context fmt flags vars; close_out oc; - let oc, fmt = open_file (Filename.concat folder "compir_famille.c") in + let oc, fmt = open_file "compir_famille.c" in gen_table_family fmt flags vars; close_out oc; - let oc, fmt = open_file (Filename.concat folder "compir_revenu.c") in + let oc, fmt = open_file "compir_revenu.c" in gen_table_income fmt flags vars; close_out oc; - let oc, fmt = open_file (Filename.concat folder "compir_revcor.c") in + let oc, fmt = open_file "compir_revcor.c" in gen_table_corrincome fmt flags vars; close_out oc; - let oc, fmt = open_file (Filename.concat folder "compir_variatio.c") in + let oc, fmt = open_file "compir_variatio.c" in gen_table_variation fmt flags vars; close_out oc; - let oc, fmt = open_file (Filename.concat folder "compir_penalite.c") in + let oc, fmt = open_file "compir_penalite.c" in gen_table_penality fmt flags vars; close_out oc; @@ -1067,8 +1066,7 @@ let generate_compir_files flags (cprog : Mir.program) : unit = if flags.nb_debug_c > 0 then List.fold_left (fun i vars -> - let file = Printf.sprintf "compir_tableg%02d.c" i in - let oc, fmt = open_file (Filename.concat folder file) in + let oc, fmt = open_file (Printf.sprintf "compir_tableg%02d.c" i) in if flags.flg_debug then gen_table_debug fmt flags vars i else Format.fprintf fmt @@ -1079,22 +1077,22 @@ let generate_compir_files flags (cprog : Mir.program) : unit = else 0 in - let oc, fmt = open_file (Filename.concat folder "compir_desc.h") in + let oc, fmt = open_file "compir_desc.h" in gen_desc fmt Dgfip_options.(flags.flg_tri_ebcdic) vars ~alias_only:true; close_out oc; - let oc, fmt = open_file (Filename.concat folder "compir_desc_inv.h") in + let oc, fmt = open_file "compir_desc_inv.h" in gen_desc fmt Dgfip_options.(flags.flg_tri_ebcdic) vars ~alias_only:false; close_out oc; - let oc, fmt = open_file (Filename.concat folder "compir_tableg.c") in + let oc, fmt = open_file "compir_tableg.c" in gen_table_call fmt flags vars_debug cprog; close_out oc; - let oc, fmt = open_file (Filename.concat folder "compir_tablev.c") in + let oc, fmt = open_file "compir_tablev.c" in gen_table_verif fmt flags cprog; close_out oc; - let oc, fmt = open_file (Filename.concat folder "compir.h") in + let oc, fmt = open_file "compir.h" in gen_compir_h fmt flags vars vars_debug_split; close_out oc diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index f7ff6a3d7..2b1067e91 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -14,8 +14,20 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -let gen_table_varinfo fmt vars cat Com.CatVar.{ id_int; id_str; attributs; _ } +let open_file filename = + let folder = Filename.dirname !Cli.output_file in + let oc = open_out (Filename.concat folder filename) in + let fmt = Format.formatter_of_out_channel oc in + (oc, fmt) + +let gen_table_varinfo vars cat Com.CatVar.{ id_int; id_str; attributs; _ } (stats, var_map) = + let oc, fmt = open_file (Pp.spr "varinfo_%s.c" id_str) in + Format.fprintf fmt {|/****** LICENCE CECIL *****/ + +#include "mlang.h" + +|}; Format.fprintf fmt "T_varinfo_%s varinfo_%s[NB_%s + 1] = {\n" id_str id_str id_str; let nb, var_map = @@ -54,12 +66,20 @@ let gen_table_varinfo fmt vars cat Com.CatVar.{ id_int; id_str; attributs; _ } vars (0, var_map) in Format.fprintf fmt " NULL\n};\n\n"; + close_out oc; let attr_set = StrMap.fold (fun an _ res -> StrSet.add an res) attributs StrSet.empty in (Com.CatVar.Map.add cat (id_str, id_int, nb, attr_set) stats, var_map) -let gen_table_varinfos fmt (cprog : Mir.program) = +let gen_table_varinfos (cprog : Mir.program) flags = + let stats_varinfos, var_map = + Com.CatVar.Map.fold + (gen_table_varinfo cprog.program_vars) + cprog.program_var_categories + (Com.CatVar.Map.empty, StrMap.empty) + in + let oc, fmt = open_file "varinfos.c" in Format.fprintf fmt {|/****** LICENCE CECIL *****/ #include "mlang.h" @@ -98,15 +118,14 @@ let gen_table_varinfos fmt (cprog : Mir.program) = Pp.fpr fmt " return 0.0;\n"; Pp.fpr fmt "}\n\n") attrs; - let stats_varinfos, var_map = - Com.CatVar.Map.fold - (gen_table_varinfo fmt cprog.program_vars) - cprog.program_var_categories - (Com.CatVar.Map.empty, StrMap.empty) - in - Pp.fpr fmt "T_varinfo_map varinfo[NB_variable + NB_saisie + 1] = {\n"; - StrMap.iter (Format.fprintf fmt " { \"%s\", %s },\n") var_map; - Pp.fpr fmt " NULL\n};\n\n"; + if flags.Dgfip_options.flg_gcos then + Format.fprintf fmt "T_varinfo_map varinfo[1] = {NULL};\n\n" + else ( + Format.fprintf fmt + "T_varinfo_map varinfo[NB_variable + NB_saisie + 1] = {\n"; + StrMap.iter (Format.fprintf fmt " { \"%s\", %s },\n") var_map; + Format.fprintf fmt " NULL\n};\n\n"); + close_out oc; stats_varinfos let gen_decl_varinfos fmt (cprog : Mir.program) stats = @@ -208,10 +227,8 @@ let gen_erreurs_c fmt flags (cprog : Mir.program) = "T_erreur erreur_%s = { \"%s%s%s / %s\", \"%s\", \"%s\", \"%s\", \ \"%s\", %d };\n" (Pos.unmark e.name) (Pos.unmark e.famille) (Pos.unmark e.code_bo) - sous_code_suffix - (Strings.sanitize_str e.libelle) - (Pos.unmark e.code_bo) (Pos.unmark e.sous_code) (Pos.unmark e.is_isf) - (Pos.unmark e.name) terr) + sous_code_suffix (Pos.unmark e.libelle) (Pos.unmark e.code_bo) + (Pos.unmark e.sous_code) (Pos.unmark e.is_isf) (Pos.unmark e.name) terr) cprog.program_errors; if flags.Dgfip_options.flg_pro || flags.flg_iliad then begin @@ -239,7 +256,9 @@ let gen_conf_h fmt (cprog : Mir.program) flags = if flags.flg_iliad then Format.fprintf fmt "#define FLG_ILIAD\n"; if flags.flg_pro then Format.fprintf fmt "#define FLG_PRO\n"; if flags.flg_cfir then Format.fprintf fmt "#define FLG_CFIR\n"; - if flags.flg_gcos then Format.fprintf fmt "#define FLG_GCOS\n"; + if flags.flg_gcos then ( + Format.fprintf fmt "#define FLG_GCOS\n"; + Format.fprintf fmt "#define BATCH\n"); if flags.flg_tri_ebcdic then Format.fprintf fmt "#define FLG_TRI_EBCDIC\n"; (* flag is not used *) if flags.flg_short then @@ -1776,32 +1795,23 @@ void pr_err_var(T_irdata *irdata, char *nom) { pr "}\n\n")) cprog.program_event_fields -let open_file filename = - let oc = open_out filename in - let fmt = Format.formatter_of_out_channel oc in - (oc, fmt) - let generate_auxiliary_files flags (cprog : Mir.program) : unit = - let folder = Filename.dirname !Cli.output_file in - Dgfip_compir_files.generate_compir_files flags cprog; - let oc, fmt = open_file (Filename.concat folder "varinfos.c") in - let stats_varinfos = gen_table_varinfos fmt cprog in - close_out oc; + let stats_varinfos = gen_table_varinfos cprog flags in - let oc, fmt = open_file (Filename.concat folder "erreurs.c") in + let oc, fmt = open_file "erreurs.c" in gen_erreurs_c fmt flags cprog; close_out oc; - let oc, fmt = open_file (Filename.concat folder "conf.h") in + let oc, fmt = open_file "conf.h" in gen_conf_h fmt cprog flags; close_out oc; - let oc, fmt = open_file (Filename.concat folder "mlang.h") in + let oc, fmt = open_file "mlang.h" in gen_mlang_h fmt cprog flags stats_varinfos; close_out oc; - let oc, fmt = open_file (Filename.concat folder "mlang.c") in + let oc, fmt = open_file "mlang.c" in gen_mlang_c fmt cprog flags; close_out oc diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index ce1630936..90a7ba4cf 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -239,16 +239,10 @@ let driver (files : string list) (application_names : string list) Errors.raise_error (Format.asprintf "Unknown backend: %s" backend) | None -> Errors.raise_error "No backend specified!" end - with Errors.StructuredError (msg, pos_list, kont) -> - let pp_pos fmt (s_opt, p) = - match s_opt with - | Some s -> Format.fprintf fmt "(%s, %a)" s Pos.format_position_gnu p - | None -> Pos.format_position_gnu fmt p - in - Cli.error_print "Uncaught exception: Errors.StructuredError(\"%s\")@." - (String.escaped msg); - Cli.error_print "%a@." (Pp.list_endline pp_pos) pos_list; + with Errors.StructuredError (msg, pos_list, kont) as e -> + Cli.error_print "%a" Errors.format_structured_error (msg, pos_list); (match kont with None -> () | Some kont -> kont ()); - Format.eprintf "%s@." (Printexc.get_backtrace ()) + raise e -let main () = Cmdliner.Cmd.eval @@ Cmdliner.Cmd.v Cli.info (Cli.mlang_t driver) +let main () = + exit @@ Cmdliner.Cmd.eval @@ Cmdliner.Cmd.v Cli.info (Cli.mlang_t driver) diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index 1bb930f7f..a0445e075 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -354,7 +354,7 @@ type rule = { (string Pos.marked * Mast.table_size Pos.marked option) StrMap.t; rule_instrs : Mast.instruction Pos.marked list; rule_in_vars : StrSet.t; - rule_out_vars : StrSet.t; + rule_out_vars : Pos.t StrMap.t; rule_seq : int; } @@ -399,6 +399,9 @@ type program = { prog_stats : Mir.stats; } +let is_vartmp (var : string) = + String.length var >= 6 && String.sub var 0 6 = "VARTMP" + let get_target_file (pos : Pos.t) : string = let file = Pos.get_file pos |> Filename.basename in let file = @@ -1241,7 +1244,13 @@ let cats_variable_from_decl_list (l : Mast.var_category_id list) let rec check_instructions (instrs : Mast.instruction Pos.marked list) (is_rule : bool) (env : var_env) : - program * Mast.instruction Pos.marked list * StrSet.t * StrSet.t = + program + * Mast.instruction Pos.marked list + * StrSet.t + * Pos.t StrMap.t + * Pos.t list StrMap.t = + (* the use of def_vars is to track variables definitions within a rule and warn if one is defined twice + we use a `Pos.t StrMap` instead of marked variable names because it is enough information in our case *) let check_it_var env var = let var_pos = Pos.get_position var in let var_name = Mast.get_normal_var (Pos.unmark var) in @@ -1262,8 +1271,44 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) | Some _ | None -> ()); (var_name, var_pos) in - let rec aux (env, res, in_vars, out_vars) = function - | [] -> (env, List.rev res, in_vars, out_vars) + let union_map map0 map1 = + let merge _vn po0 po1 = + match (po0, po1) with + | None, None -> None + | None, Some p | Some p, None -> Some p + | Some p0, Some _p1 -> Some p0 + in + StrMap.merge merge map0 map1 + in + let diff_set_map s m = + let filter vn = not (StrMap.mem vn m) in + StrSet.filter filter s + in + let diff_map_set m s = + let filter vn _ = not (StrSet.mem vn s) in + StrMap.filter filter m + in + let merge_seq_defs map0 map1 = + let merge _vn lo0 lo1 = + match (lo0, lo1) with + | None, None -> None + | None, Some l | Some l, None -> Some l + | Some l0, Some l1 -> Some (l1 @ l0) + in + StrMap.merge merge map0 map1 + in + let merge_par_defs map0 map1 = + let merge _vn lo0 lo1 = + match (lo0, lo1) with + | None, None -> None + | None, Some l | Some l, None -> Some l + | Some l0, Some _l1 -> Some l0 + in + StrMap.merge merge map0 map1 + in + let rec aux (env, res, in_vars, (out_vars : Pos.t StrMap.t), def_vars) = + function + | [] -> (env, List.rev res, in_vars, out_vars, def_vars) | m_instr :: il -> ( let instr, instr_pos = m_instr in match instr with @@ -1285,10 +1330,19 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) check_variable (v, access_pos) idx_mem env in let in_vars = - StrSet.union in_vars (StrSet.diff in_vars_aff out_vars) + StrSet.union in_vars (diff_set_map in_vars_aff out_vars) + in + let out_vars = StrMap.add out_var access_pos out_vars in + let def_vars = + let vn = Mast.get_normal_var v in + let def_list = + match StrMap.find_opt vn def_vars with + | None -> [ access_pos ] + | Some l -> access_pos :: l + in + StrMap.add vn def_list def_vars in - let out_vars = StrSet.add out_var out_vars in - aux (env, m_instr :: res, in_vars, out_vars) il + aux (env, m_instr :: res, in_vars, out_vars, def_vars) il | FieldAccess (i, f, _) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let f_name, f_pos = f in @@ -1302,9 +1356,9 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) let in_vars_i = check_expression false i env in let in_vars_aff = StrSet.union in_vars_i in_vars_aff in let in_vars = - StrSet.union in_vars (StrSet.diff in_vars_aff out_vars) + StrSet.union in_vars (diff_set_map in_vars_aff out_vars) in - aux (env, m_instr :: res, in_vars, out_vars) il) + aux (env, m_instr :: res, in_vars, out_vars, def_vars) il) | Com.SingleFormula (EventFieldRef (i, f, _, v)) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let f_name, f_pos = f in @@ -1315,18 +1369,17 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) let in_vars_i = check_expression false i env in ignore (check_variable v Both env); let in_vars = - StrSet.union in_vars (StrSet.diff in_vars_i out_vars) + StrSet.union in_vars (diff_set_map in_vars_i out_vars) in - aux (env, m_instr :: res, in_vars, out_vars) il + aux (env, m_instr :: res, in_vars, out_vars, def_vars) il | Com.MultipleFormulaes _ -> assert false) | Com.IfThenElse (expr, i_then, i_else) -> - (* if is_rule then Err.insruction_forbidden_in_rules instr_pos; *) let in_expr = check_expression false expr env in - let prog, res_then, in_then, out_then = + let prog, res_then, in_then, out_then, def_then = check_instructions i_then is_rule env in let env = { env with prog } in - let prog, res_else, in_else, out_else = + let prog, res_else, in_else, out_else, def_else = check_instructions i_else is_rule env in let env = { env with prog } in @@ -1336,36 +1389,48 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) |> StrSet.union in_else in let out_vars = - out_vars |> StrSet.union out_then |> StrSet.union out_else + out_vars |> union_map out_then |> union_map out_else + in + let def_vars = + merge_seq_defs def_vars (merge_par_defs def_then def_else) in - aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il + aux + (env, (res_instr, instr_pos) :: res, in_vars, out_vars, def_vars) + il | Com.WhenDoElse (wdl, ed) -> - let rec wde (env, res, in_vars, out_vars) = function + let rec wde (env, res, in_vars, out_vars, def_vars) = function | (expr, dl, pos) :: l -> let in_expr = check_expression false expr env in - let prog, res_do, in_do, out_do = + let prog, res_do, in_do, out_do, def_do = check_instructions dl is_rule env in let env = { env with prog } in + let res = (expr, res_do, pos) :: res in let in_vars = in_vars |> StrSet.union in_expr |> StrSet.union in_do in - let out_vars = out_vars |> StrSet.union out_do in - wde (env, (expr, res_do, pos) :: res, in_vars, out_vars) l + let out_vars = out_vars |> union_map out_do in + let def_vars = merge_par_defs def_vars def_do in + wde (env, res, in_vars, out_vars, def_vars) l | [] -> - let prog, res_ed, in_ed, out_ed = + let prog, res_ed, in_ed, out_ed, def_ed = check_instructions (Pos.unmark ed) is_rule env in let env = { env with prog } in let ed' = Pos.same_pos_as res_ed ed in + let res = Com.WhenDoElse (List.rev res, ed') in let in_vars = in_vars |> StrSet.union in_ed in - let out_vars = out_vars |> StrSet.union out_ed in - (env, Com.WhenDoElse (List.rev res, ed'), in_vars, out_vars) + let out_vars = out_vars |> union_map out_ed in + let def_vars = merge_par_defs def_vars def_ed in + (env, res, in_vars, out_vars, def_vars) in - let env, wde_res, in_vars, out_vars = - wde (env, [], in_vars, out_vars) wdl + let env, wde_res, in_vars, out_vars, def_vars_wde = + wde (env, [], in_vars, out_vars, StrMap.empty) wdl in - aux (env, (wde_res, instr_pos) :: res, in_vars, out_vars) il + let def_vars = merge_seq_defs def_vars def_vars_wde in + aux + (env, (wde_res, instr_pos) :: res, in_vars, out_vars, def_vars) + il | Com.ComputeDomain (rdom_list, rdom_pos) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let tname = get_compute_id_str instr env.prog in @@ -1381,12 +1446,16 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) let prog = { prog with prog_rdom_calls } in let env = { env with prog } in let res_instr = Com.ComputeTarget ((tname, Pos.no_pos), []) in - aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il + aux + (env, (res_instr, instr_pos) :: res, in_vars, out_vars, def_vars) + il | Com.ComputeChaining _ -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let tname = get_compute_id_str instr env.prog in let res_instr = Com.ComputeTarget ((tname, Pos.no_pos), []) in - aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il + aux + (env, (res_instr, instr_pos) :: res, in_vars, out_vars, def_vars) + il | Com.ComputeVerifs ((vdom_list, vdom_pos), expr) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let tname = get_compute_id_str instr env.prog in @@ -1403,15 +1472,19 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) let prog = { prog with prog_vdom_calls } in let env = { env with prog } in let res_instr = Com.ComputeTarget ((tname, Pos.no_pos), []) in - aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il + aux + (env, (res_instr, instr_pos) :: res, in_vars, out_vars, def_vars) + il | Com.VerifBlock instrs -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; - let prog, res_instrs, _, _ = + let prog, res_instrs, _, _, _ = check_instructions instrs is_rule env in let env = { env with prog } in let res_instr = Com.VerifBlock res_instrs in - aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il + aux + (env, (res_instr, instr_pos) :: res, in_vars, out_vars, def_vars) + il | Com.ComputeTarget ((tn, tpos), targs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; (match StrMap.find_opt tn env.prog.prog_targets with @@ -1421,7 +1494,7 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) if List.length targs <> nb_args then Err.wrong_number_of_args nb_args tpos); List.iter (fun var -> ignore (check_variable var Both env)) targs; - aux (env, m_instr :: res, in_vars, out_vars) il + aux (env, m_instr :: res, in_vars, out_vars, def_vars) il | Com.Print (_std, args) -> List.iter (fun arg -> @@ -1441,7 +1514,7 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) | Com.PrintExpr (e, _min, _max) -> ignore (check_expression false e env)) args; - aux (env, m_instr :: res, in_vars, out_vars) il + aux (env, m_instr :: res, in_vars, out_vars, def_vars) il | Com.Iterate (var, vars, var_params, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let var_name, var_pos = check_it_var env var in @@ -1464,12 +1537,14 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) ignore (mast_to_catvars vcats env.prog.prog_var_cats); ignore (check_expression false expr env')) var_params; - let prog, res_instrs, _, _ = + let prog, res_instrs, _, _, _ = check_instructions instrs is_rule env' in let env = { env with prog } in let res_instr = Com.Iterate (var, vars, var_params, res_instrs) in - aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il + aux + (env, (res_instr, instr_pos) :: res, in_vars, out_vars, def_vars) + il | Com.Iterate_values (var, var_intervals, instrs) -> let var_name, var_pos = check_it_var env var in let env' = @@ -1487,7 +1562,7 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) |> StrSet.union (check_expression false step env)) StrSet.empty var_intervals in - let prog, res_instrs, in_instrs, out_instrs = + let prog, res_instrs, in_instrs, out_instrs, def_instrs = check_instructions instrs is_rule env' in let env = { env with prog } in @@ -1500,9 +1575,12 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) (in_exprs |> StrSet.union in_instrs |> StrSet.remove var_name) in let out_vars = - out_vars |> StrSet.union (out_instrs |> StrSet.remove var_name) + out_vars |> union_map (out_instrs |> StrMap.remove var_name) in - aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il + let def_vars = merge_seq_defs def_vars def_instrs in + aux + (env, (res_instr, instr_pos) :: res, in_vars, out_vars, def_vars) + il | Com.Restore (vars, var_params, evts, evtfs, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; ignore @@ -1542,14 +1620,16 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) in ignore (check_expression false expr env)) evtfs; - let prog, res_instrs, _, _ = + let prog, res_instrs, _, _, _ = check_instructions instrs is_rule env in let env = { env with prog } in let res_instr = Com.Restore (vars, var_params, evts, evtfs, res_instrs) in - aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il + aux + (env, (res_instr, instr_pos) :: res, in_vars, out_vars, def_vars) + il | Com.ArrangeEvents (sort, filter, add, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; (match sort with @@ -1581,12 +1661,14 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) (match add with | Some expr -> ignore (check_expression false expr env) | None -> ()); - let prog, res_instrs, _in_instrs, _out_instrs = + let prog, res_instrs, _in_instrs, _out_instrs, _ = check_instructions instrs is_rule env in let env = { env with prog } in let res_instr = Com.ArrangeEvents (sort, filter, add, res_instrs) in - aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il + aux + (env, (res_instr, instr_pos) :: res, in_vars, out_vars, def_vars) + il | Com.RaiseError (m_err, m_var_opt) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let err_name, err_pos = m_err in @@ -1603,20 +1685,29 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) | None -> Err.unknown_variable var_pos | Some _ -> ()) | None -> ()); - aux (env, m_instr :: res, in_vars, out_vars) il + aux (env, m_instr :: res, in_vars, out_vars, def_vars) il | Com.CleanErrors | Com.ExportErrors | Com.FinalizeErrors -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; - aux (env, m_instr :: res, in_vars, out_vars) il) + aux (env, m_instr :: res, in_vars, out_vars, def_vars) il) in - let env, res, in_vars, out_vars = - aux (env, [], StrSet.empty, StrSet.empty) instrs - in - let tmp_vars = - StrMap.fold (fun vn _ s -> StrSet.add vn s) env.tmp_vars StrSet.empty + let env, res, in_vars, out_vars, def_vars = + aux (env, [], StrSet.empty, StrMap.empty, StrMap.empty) instrs in + if is_rule then + StrMap.iter + (fun vn l -> + if List.length l > 1 && not (is_vartmp vn) then + Errors.print_multispanned_warning + (Format.asprintf + "Variable %s is defined more than once in the same rule" vn) + (List.map (fun pos -> (None, pos)) (List.rev l))) + (* List.rev for purely cosmetic reasons *) + def_vars; + let tmp_vars = StrMap.keySet env.tmp_vars in let in_vars = StrSet.diff in_vars tmp_vars in - let out_vars = StrSet.diff out_vars tmp_vars in - (env.prog, res, in_vars, out_vars) + let out_vars = diff_map_set out_vars tmp_vars in + let def_vars = diff_map_set def_vars tmp_vars in + (env.prog, res, in_vars, out_vars, def_vars) let check_target (is_function : bool) (t : Mast.target) (prog : program) : program = @@ -1694,7 +1785,7 @@ let check_target (is_function : bool) (t : Mast.target) (prog : program) : let res_var = target_result in let prog, target_prog = let env = { prog; tmp_vars; ref_vars; res_var } in - let prog, target_prog, in_vars, out_vars = + let prog, target_prog, in_vars, out_vars, _ = check_instructions t.target_prog is_function env in if is_function then ( @@ -1705,12 +1796,12 @@ let check_target (is_function : bool) (t : Mast.target) (prog : program) : in_vars target_args |> StrSet.remove vr in - let bad_out_vars = StrSet.remove vr out_vars in + let bad_out_vars = StrMap.remove vr out_vars in (if StrSet.card bad_in_vars > 0 then let vn = StrSet.min_elt bad_in_vars in Err.forbidden_in_var_in_function vn tname tpos); - if StrSet.card bad_out_vars > 0 then - let vn = StrSet.min_elt bad_out_vars in + if StrMap.card bad_out_vars > 0 then + let vn, _ = StrMap.min_binding bad_out_vars in Err.forbidden_out_var_in_function vn tname tpos); (prog, target_prog) in @@ -1790,7 +1881,7 @@ let check_rule (r : Mast.rule) (prog : program) : program = rule_tmp_vars in let rule_instrs = r.Mast.rule_formulaes in - let prog, rule_instrs, rule_in_vars, rule_out_vars = + let prog, rule_instrs, rule_in_vars, rule_out_vars, _ = let env = { prog; tmp_vars; ref_vars = StrMap.empty; res_var = None } in check_instructions rule_instrs true env in @@ -1844,9 +1935,6 @@ let convert_rules (prog : program) : program = in { prog with prog_targets } -let is_vartmp (var : string) = - String.length var >= 6 && String.sub var 0 6 = "VARTMP" - let create_rule_graph (in_vars_from : rule -> StrSet.t) (out_vars_from : rule -> StrSet.t) (rules : 'a IntMap.t) : string IntMap.t option IntMap.t = @@ -1947,20 +2035,53 @@ let rdom_rule_filter (rdom : Com.rule_domain_data Com.domain) (rule : rule) : Com.DomainId.equal rdom_id rule_rdom_id || Com.DomainIdSet.mem rule_rdom_id rdom.Com.dom_min +let check_no_variable_duplicates (rdom_rules : rule IntMap.t) + (rdom_id : Com.DomainId.t) : unit = + (* checks whether a variable is defined in two different rules given a rule "set". + We cannot do it over all the rules of a single program because some are defined in different chainings *) + let rule_defined = + IntMap.fold + (fun _ r rule_defined -> + let out = r.rule_out_vars in + StrMap.fold + (fun var var_pos rule_defined -> + let tail = + match StrMap.find_opt var rule_defined with + | Some tl -> tl + | None -> [] + in + StrMap.add var (var_pos :: tail) rule_defined) + out rule_defined) + rdom_rules StrMap.empty + in + StrMap.iter + (fun var_name pos_list -> + if (not (is_vartmp var_name)) && List.length pos_list > 1 then + let msg = + Format.asprintf + "Variable %s is defined in %d different rules in rule domain %a" + var_name (List.length pos_list) (Com.DomainId.pp ()) rdom_id + in + Errors.raise_multispanned_error msg + (List.map (fun pos -> (None, pos)) (List.rev pos_list))) + (* List.rev for cosmetic reasons *) + rule_defined + let complete_rule_domains (prog : program) : program = let prog_targets = Com.DomainIdMap.fold (fun rdom_id rdom prog_targets -> - if rdom.Com.dom_data.Com.rdom_computable then + if rdom.Com.dom_data.Com.rdom_computable then ( let rdom_rules = IntMap.filter (fun _ rule -> rdom_rule_filter rdom rule) prog.prog_rules in + check_no_variable_duplicates rdom_rules rdom_id; let rule_graph = create_rule_graph (fun r -> r.rule_in_vars) - (fun r -> r.rule_out_vars) + (fun r -> StrMap.keySet r.rule_out_vars) rdom_rules in let target_prog = @@ -1987,7 +2108,7 @@ let complete_rule_domains (prog : program) : program = target_nb_refs = 0; } in - StrMap.add tname target prog_targets + StrMap.add tname target prog_targets) else prog_targets) prog.prog_rdoms prog.prog_targets in @@ -2041,7 +2162,7 @@ let complete_chainings (prog : program) : program = in let inverted_rule_graph = create_rule_graph - (fun r -> r.rule_out_vars) + (fun r -> StrMap.keySet r.rule_out_vars) (fun r -> r.rule_in_vars) rdom_rules in @@ -2062,7 +2183,7 @@ let complete_chainings (prog : program) : program = let rule_graph = create_rule_graph (fun r -> r.rule_in_vars) - (fun r -> r.rule_out_vars) + (fun r -> StrMap.keySet r.rule_out_vars) rules in let target_prog = diff --git a/src/mlang/m_frontend/check_validity.mli b/src/mlang/m_frontend/check_validity.mli index 5b5c3ab27..45ddb2fc2 100644 --- a/src/mlang/m_frontend/check_validity.mli +++ b/src/mlang/m_frontend/check_validity.mli @@ -31,7 +31,7 @@ type rule = { (string Pos.marked * Mast.table_size Pos.marked option) StrMap.t; rule_instrs : Mast.instruction Pos.marked list; rule_in_vars : StrSet.t; - rule_out_vars : StrSet.t; + rule_out_vars : Pos.t StrMap.t; rule_seq : int; } diff --git a/src/mlang/utils/errors.ml b/src/mlang/utils/errors.ml index b43a1cc6f..78a8ef74f 100644 --- a/src/mlang/utils/errors.ml +++ b/src/mlang/utils/errors.ml @@ -63,3 +63,7 @@ let raise_spanned_error_with_continuation (msg : string) let print_spanned_warning (msg : string) ?(span_msg : string option) (span : Pos.t) : unit = Cli.warning_print "%a" format_structured_error (msg, [ (span_msg, span) ]) + +let print_multispanned_warning (msg : string) + (spans : (string option * Pos.t) list) = + Cli.warning_print "%a" format_structured_error (msg, spans) diff --git a/src/mlang/utils/errors.mli b/src/mlang/utils/errors.mli index 82ba93a39..9ad992046 100644 --- a/src/mlang/utils/errors.mli +++ b/src/mlang/utils/errors.mli @@ -39,3 +39,5 @@ val raise_spanned_error_with_continuation : (* {2 Prints warnings with useful error messages }*) val print_spanned_warning : string -> ?span_msg:string -> Pos.t -> unit + +val print_multispanned_warning : string -> (string option * Pos.t) list -> unit diff --git a/src/mlang/utils/strMap.ml b/src/mlang/utils/strMap.ml index b8b25360e..b13fe6be6 100644 --- a/src/mlang/utils/strMap.ml +++ b/src/mlang/utils/strMap.ml @@ -6,3 +6,5 @@ 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 + +let keySet t = fold (fun k _ s -> StrSet.add k s) t StrSet.empty diff --git a/src/mlang/utils/strMap.mli b/src/mlang/utils/strMap.mli index 95cfd0fb4..fca22cfb5 100644 --- a/src/mlang/utils/strMap.mli +++ b/src/mlang/utils/strMap.mli @@ -1,3 +1,5 @@ module type T = MapExt.T with type key = string include T + +val keySet : 'a t -> StrSet.t diff --git a/src/mlang/utils/strings.ml b/src/mlang/utils/strings.ml index 8428d5585..5ecb5b379 100644 --- a/src/mlang/utils/strings.ml +++ b/src/mlang/utils/strings.ml @@ -14,17 +14,17 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -let sanitize_str (s, p) = - String.map - (fun c -> - if c >= Char.chr 128 then - let () = - Cli.warning_print "Replaced char code %d by space %a" (Char.code c) - Pos.format_position p - in - ' ' - else c) - s +(* let sanitize_str (s, p) = + String.map + (fun c -> + if c >= Char.chr 128 then + let () = + Cli.warning_print "Replaced char code %d by space %a" (Char.code c) + Pos.format_position p + in + ' ' + else c) + s *) let compare_default = String.compare diff --git a/src/mlang/utils/strings.mli b/src/mlang/utils/strings.mli index 26d73cb5a..9bf044897 100644 --- a/src/mlang/utils/strings.mli +++ b/src/mlang/utils/strings.mli @@ -14,10 +14,10 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -val sanitize_str : string * Pos.t -> string +(* val sanitize_str : string * Pos.t -> string *) (** DGFiP sources are encoded in iso-8859-1 which is not compatible with some backend compilers such as Java and Python, this function transforms illegal - characters with a space. *) + characters with a space. - not useful anymore (for now) *) val compare_default : string -> string -> int From 8c0680fb0926767c6cdbb136fc35f90e6bc3dfdd Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Mon, 17 Feb 2025 11:46:45 +0100 Subject: [PATCH 28/32] Suppression de "#define BATCH" --- src/mlang/backend_compilers/dgfip_gen_files.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index 2b1067e91..b79107903 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -256,9 +256,7 @@ let gen_conf_h fmt (cprog : Mir.program) flags = if flags.flg_iliad then Format.fprintf fmt "#define FLG_ILIAD\n"; if flags.flg_pro then Format.fprintf fmt "#define FLG_PRO\n"; if flags.flg_cfir then Format.fprintf fmt "#define FLG_CFIR\n"; - if flags.flg_gcos then ( - Format.fprintf fmt "#define FLG_GCOS\n"; - Format.fprintf fmt "#define BATCH\n"); + if flags.flg_gcos then Format.fprintf fmt "#define FLG_GCOS\n"; if flags.flg_tri_ebcdic then Format.fprintf fmt "#define FLG_TRI_EBCDIC\n"; (* flag is not used *) if flags.flg_short then From fad33d328c5f9470baccdf848e22f8273a06e8f5 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 18 Feb 2025 16:51:17 +0100 Subject: [PATCH 29/32] =?UTF-8?q?Correction=20de=20l'acc=C3=A8s=20aux=20ta?= =?UTF-8?q?bleaux=20en=20C.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../dgfip_c/ml_primitif/ml_driver/stubs.c | 2 +- m_ext/2021/cibles.m | 26 +++++++---- m_ext/2023/cibles.m | 46 +++++++++++++++++-- src/mlang/backend_compilers/decoupledExpr.ml | 8 ++-- .../backend_compilers/dgfip_compir_files.ml | 2 +- .../backend_compilers/dgfip_gen_files.ml | 6 ++- src/mlang/utils/strings.ml | 21 +++++++++ src/mlang/utils/strings.mli | 2 + 8 files changed, 94 insertions(+), 19 deletions(-) diff --git a/examples/dgfip_c/ml_primitif/ml_driver/stubs.c b/examples/dgfip_c/ml_primitif/ml_driver/stubs.c index cb30a5999..008fd8eab 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/stubs.c +++ b/examples/dgfip_c/ml_primitif/ml_driver/stubs.c @@ -200,7 +200,7 @@ CAMLprim value ml_enchainement_primitif(value mlTgv) { CAMLlocal2(mlErrListTemp, mlErrListOut); T_irdata *tgv = Tgv_val(mlTgv); - T_discord *erreurs = enchainement_primitif(tgv); + T_discord *erreurs = enchainement_primitif_interpreteur(tgv); mlErrListOut = Val_emptylist; while (erreurs != NULL) { if (erreurs->erreur != NULL) { diff --git a/m_ext/2021/cibles.m b/m_ext/2021/cibles.m index 3caf386b0..7cb0731dc 100644 --- a/m_ext/2021/cibles.m +++ b/m_ext/2021/cibles.m @@ -370,13 +370,24 @@ si CMAJ dans (8, 11) alors application: iliad; VARTMP1 = 0; si - present(COD7QD) ou present(COD7QB) ou present(COD7QC) - ou present(RFORDI) ou present(RFROBOR) ou present(RFDORD) - ou present(RFDHIS) ou present(REPSNO3_A) - ou present(COD7QF) ou present(COD7QH) ou present(CELRREDLG_A) - ou present(PINELQM_A) ou present(RCMABD) ou present(COD7KM) - ou present(PINELQP_A) ou present(COD7QS_A) ou present(PINELQN_A) - ou present(PINELQO_A) + present(COD7QD) + ou present(COD7QB) + ou present(COD7QC) + ou present(RFORDI) + ou present(RFROBOR) + ou present(RFDORD) + ou present(RFDHIS) + # ou present(REPSNO3_A) + ou present(COD7QF) + ou present(COD7QH) + # ou present(CELRREDLG_A) + # ou present(PINELQM_A) + ou present(RCMABD) + ou present(COD7KM) + # ou present(PINELQP_A) + # ou present(COD7QS_A) + # ou present(PINELQN_A) + # ou present(PINELQO_A) alors VARTMP1 = 1; sinon @@ -674,4 +685,3 @@ si present(IAD11) alors ) afficher_erreur "titi fin\n\n"; - diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index 5ec1a1576..b056bf6ee 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -855,7 +855,7 @@ si nb_discordances() + nb_informatives() > 0 alors afficher_erreur "\n"; ) -cible test: +cible test_evenements: application: iliad; variables_temporaires: A0, A1, EVT; A0 = 1.6; @@ -988,6 +988,38 @@ si inf(champ_evenement(I, rappel) % 2) = 0 alors (attribut(champ_evenement(1000, code), primrest)) "\n"; afficher_erreur "\n"; +TAILLE_TOTO : const = 3; + +cible test_tableaux: +application : iliad; +variables_temporaires: TOTO tableau[TAILLE_TOTO], NB; +NB = TAILLE_TOTO - 1; +afficher_erreur "test_tableaux\n"; +TOTO[0] = 1; +iterer : variable I : 1..NB increment 1 : dans ( + TOTO[I] = 1 + TOTO[I - 1]; +) +iterer : variable I : 0..NB increment 1 : dans ( + afficher_erreur "TOTO[" (I) "] = " (TOTO[I]) "\n"; +) +afficher_erreur "\n"; +restaurer : variables TOTO : apres ( + iterer : variable I : 0..NB increment 1 : dans ( + TOTO[I] = indefini; + afficher_erreur "TOTO[" (I) "] = " (TOTO[I]) "\n"; + ) +) +afficher_erreur "\n"; +iterer : variable I : 0..NB increment 1 : dans ( + afficher_erreur "TOTO[" (I) "] = " (TOTO[I]) "\n"; +) +afficher_erreur "\n"; + +cible test: +application: iliad; +calculer cible test_evenements; +calculer cible test_tableaux; + cible enchainement_primitif: application: iliad; variables_temporaires: EXPORTE_ERREUR; @@ -1025,13 +1057,21 @@ puis_quand nb_anomalies() = 0 faire finquand calculer cible trace_out; #afficher_erreur "]traite_double_liquidation2\n"; -#calculer cible test; -# primitif iterpréteur +# correctif + +cible enchainement_correctif: +application: iliad; +neant; + +# iterpréteur cible enchainement_primitif_interpreteur: application: iliad; si V_IND_TRAIT = 4 alors # primitif calculer cible enchainement_primitif; +sinon_si V_IND_TRAIT = 5 alors # correctif + calculer cible enchainement_correctif; finsi +calculer cible test; diff --git a/src/mlang/backend_compilers/decoupledExpr.ml b/src/mlang/backend_compilers/decoupledExpr.ml index 5b64bf307..83d068363 100644 --- a/src/mlang/backend_compilers/decoupledExpr.ml +++ b/src/mlang/backend_compilers/decoupledExpr.ml @@ -19,7 +19,7 @@ let rec generate_variable (offset : offset) ?(def_flag = false) | None -> "" | GetValueVar offset -> " + (int)" ^ generate_variable None offset | GetValueConst offset -> " + " ^ string_of_int offset - | GetValueExpr offset -> Format.sprintf " + (%s)" offset + | GetValueExpr offset -> Format.sprintf " + (int)(%s)" offset | PassPointer -> assert false in if def_flag then VID.gen_def var offset @@ -524,10 +524,10 @@ let rec format_dexpr (dgfip_flags : Dgfip_options.flags) fmt (de : expr) = | Dinstr instr -> Format.fprintf fmt "%s" instr | Ddirect expr -> format_dexpr fmt expr | Daccess (var, dflag, de) -> - Format.fprintf fmt "(%s[(int)%a])" + let de_str = Format.asprintf "%a" format_dexpr de in + Format.fprintf fmt "(%s)" (generate_variable ~def_flag:(dflag = Def) - ~trace_flag:dgfip_flags.flg_trace PassPointer var) - format_dexpr de + ~trace_flag:dgfip_flags.flg_trace (GetValueExpr de_str) var) | Dite (dec, det, dee) -> Format.fprintf fmt "@[(%a ?@ %a@ : %a@])" format_dexpr dec format_dexpr det format_dexpr dee diff --git a/src/mlang/backend_compilers/dgfip_compir_files.ml b/src/mlang/backend_compilers/dgfip_compir_files.ml index fbc1f56a2..b704f676a 100644 --- a/src/mlang/backend_compilers/dgfip_compir_files.ml +++ b/src/mlang/backend_compilers/dgfip_compir_files.ml @@ -216,7 +216,7 @@ let get_vars (cprog : Mir.program) is_ebcdic = idxo_opt, name, Option.map Pos.unmark tgv.alias, - Pos.unmark tgv.descr, + Strings.sanitize_c_str (Pos.unmark tgv.descr), tgv.typ, tgv.attrs, size ) diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index b79107903..6735b08fb 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -227,8 +227,10 @@ let gen_erreurs_c fmt flags (cprog : Mir.program) = "T_erreur erreur_%s = { \"%s%s%s / %s\", \"%s\", \"%s\", \"%s\", \ \"%s\", %d };\n" (Pos.unmark e.name) (Pos.unmark e.famille) (Pos.unmark e.code_bo) - sous_code_suffix (Pos.unmark e.libelle) (Pos.unmark e.code_bo) - (Pos.unmark e.sous_code) (Pos.unmark e.is_isf) (Pos.unmark e.name) terr) + sous_code_suffix + (Strings.sanitize_c_str (Pos.unmark e.libelle)) + (Pos.unmark e.code_bo) (Pos.unmark e.sous_code) (Pos.unmark e.is_isf) + (Pos.unmark e.name) terr) cprog.program_errors; if flags.Dgfip_options.flg_pro || flags.flg_iliad then begin diff --git a/src/mlang/utils/strings.ml b/src/mlang/utils/strings.ml index 5ecb5b379..3db880a8c 100644 --- a/src/mlang/utils/strings.ml +++ b/src/mlang/utils/strings.ml @@ -26,6 +26,27 @@ else c) s *) +let sanitize_c_str s = + let len = String.length s in + let buf = Buffer.create len in + for i = 0 to len - 1 do + match s.[i] with + | '\b' -> Buffer.add_string buf "\\b" + | '\n' -> Buffer.add_string buf "\\n" + | '\r' -> Buffer.add_string buf "\\r" + | '\t' -> Buffer.add_string buf "\\t" + | '\007' -> Buffer.add_string buf "\\a" + | '\027' -> Buffer.add_string buf "\\e" + | '\012' -> Buffer.add_string buf "\\f" + | '\011' -> Buffer.add_string buf "\\v" + | ('\\' | '\'' | '"' | '?') as c -> Buffer.add_string buf (Pp.spr "\\%c" c) + | c when c <= '\031' || '\127' <= c -> + let code_str = Pp.spr "\\%03o" (Char.code c) in + Buffer.add_string buf code_str + | c -> Buffer.add_char buf c + done; + Buffer.contents buf + let compare_default = String.compare let ascii_to_ebcdic = diff --git a/src/mlang/utils/strings.mli b/src/mlang/utils/strings.mli index 9bf044897..69d31ad7c 100644 --- a/src/mlang/utils/strings.mli +++ b/src/mlang/utils/strings.mli @@ -19,6 +19,8 @@ backend compilers such as Java and Python, this function transforms illegal characters with a space. - not useful anymore (for now) *) +val sanitize_c_str : string -> string + val compare_default : string -> string -> int val compare_ebcdic : string -> string -> int From 770b7466595ad8c7691f2adc9d7adf16519ca412 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 18 Feb 2025 17:20:32 +0100 Subject: [PATCH 30/32] Corrections syntaxiques. --- m_ext/2023/cibles.m | 15 +++++++++++---- src/mlang/backend_compilers/dgfip_gen_files.ml | 2 +- src/mlang/m_frontend/mparser.mly | 2 +- 3 files changed, 13 insertions(+), 6 deletions(-) diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index b056bf6ee..ed0d2bc96 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -994,7 +994,7 @@ si inf(champ_evenement(I, rappel) % 2) = 0 alors application : iliad; variables_temporaires: TOTO tableau[TAILLE_TOTO], NB; NB = TAILLE_TOTO - 1; -afficher_erreur "test_tableaux\n"; +afficher_erreur "test_tableaux\n" indenter(2); TOTO[0] = 1; iterer : variable I : 1..NB increment 1 : dans ( TOTO[I] = 1 + TOTO[I - 1]; @@ -1003,7 +1003,14 @@ si inf(champ_evenement(I, rappel) % 2) = 0 alors afficher_erreur "TOTO[" (I) "] = " (TOTO[I]) "\n"; ) afficher_erreur "\n"; -restaurer : variables TOTO : apres ( +iterer : variable VAR : TOTO : dans ( + iterer : variable I : 0..NB increment 1 : dans ( + VAR[I] = VAR[I] * VAR[I]; + afficher_erreur nom(VAR) "[" (I) "] = " (VAR[I]) "\n"; + ) +) +afficher_erreur "\n"; +restaurer : TOTO : apres ( iterer : variable I : 0..NB increment 1 : dans ( TOTO[I] = indefini; afficher_erreur "TOTO[" (I) "] = " (TOTO[I]) "\n"; @@ -1013,7 +1020,7 @@ si inf(champ_evenement(I, rappel) % 2) = 0 alors iterer : variable I : 0..NB increment 1 : dans ( afficher_erreur "TOTO[" (I) "] = " (TOTO[I]) "\n"; ) -afficher_erreur "\n"; +afficher_erreur indenter(-2) "test_tableaux\n"; cible test: application: iliad; @@ -1073,5 +1080,5 @@ puis_quand nb_anomalies() = 0 faire sinon_si V_IND_TRAIT = 5 alors # correctif calculer cible enchainement_correctif; finsi -calculer cible test; +#calculer cible test; diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index 6735b08fb..41fb691c8 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -1149,7 +1149,7 @@ void set_print_indent(FILE *std, T_print_context *pr_ctx, double diff) { void print_indent(FILE *std, T_print_context *pr_ctx) { if (pr_ctx->is_newline) { int i; - for (i = 1; i < pr_ctx->indent; i++) { + for (i = 0; i < pr_ctx->indent; i++) { fprintf(pr_ctx->std, " "); } pr_ctx->is_newline = 0; diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 5fdb5c0f8..728d604bd 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -898,7 +898,7 @@ it_param_with_expr: | WITH expr = with_pos(expression) COLON { expr } rest_param: -| VARIABLES vars = separated_nonempty_list(COMMA, symbol_with_pos) COLON { +| vars = separated_nonempty_list(COMMA, symbol_with_pos) COLON { let vl = List.map (fun vn -> Pos.same_pos_as (Normal (Pos.unmark vn)) vn) vars in From 389fae4ccf28b0f764020ed8c6c80aef2f02783d Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Tue, 18 Feb 2025 18:06:46 +0100 Subject: [PATCH 31/32] Adaptations pour 2024. --- m_ext/2024/cibles.m | 819 +++++++++++++++++++++++++++++++ makefiles/variables.mk | 2 +- src/mlang/m_frontend/mlexer.mll | 1 - src/mlang/m_frontend/mparser.mly | 2 +- 4 files changed, 821 insertions(+), 3 deletions(-) create mode 100644 m_ext/2024/cibles.m diff --git a/m_ext/2024/cibles.m b/m_ext/2024/cibles.m new file mode 100644 index 000000000..f90ac2b3a --- /dev/null +++ b/m_ext/2024/cibles.m @@ -0,0 +1,819 @@ +# compir + +cible regle_1: +application: iliad; +BIDON = 1; +APPLI_BATCH = 0; +APPLI_ILIAD = 1; + +cible calcul_primitif: +application: iliad; +calculer domaine primitive; + +cible calcul_primitif_isf: +application: iliad; +calculer domaine isf; + +cible calcul_primitif_taux: +application: iliad; +calculer domaine taux; + +cible calcul_correctif: +application: iliad; +calculer domaine corrective; + +cible sauve_base_1728: +application: iliad; +calculer domaine base_1728 corrective; + +cible sauve_base_premier: +application: iliad; +calculer domaine base_premier corrective; + +cible sauve_base_stratemajo: +application: iliad; +calculer domaine base_stratemajo corrective; + +cible sauve_base_anterieure: +application: iliad; +calculer domaine base_anterieure corrective; + +cible sauve_base_anterieure_cor: +application: iliad; +calculer domaine base_anterieure_cor corrective; + +cible sauve_base_inr_tl: +application: iliad; +calculer domaine base_inr_tl corrective; + +cible sauve_base_inr_tl22: +application: iliad; +calculer domaine base_inr_tl22 corrective; + +cible sauve_base_inr_tl24: +application: iliad; +calculer domaine base_inr_tl24 corrective; + +cible sauve_base_inr_ntl: +application: iliad; +calculer domaine base_inr_ntl corrective; + +cible sauve_base_inr_ntl22: +application: iliad; +calculer domaine base_inr_ntl22 corrective; + +cible sauve_base_inr_ntl24: +application: iliad; +calculer domaine base_inr_ntl24 corrective; + +cible sauve_base_inr_ref: +application: iliad; +calculer domaine base_inr_ref corrective; + +cible sauve_base_inr_r9901: +application: iliad; +calculer domaine base_inr_r9901 corrective; + +cible sauve_base_inr_intertl: +application: iliad; +calculer domaine base_inr_intertl corrective; + +cible sauve_base_inr_inter22: +application: iliad; +calculer domaine base_inr_inter22 corrective; + +cible sauve_base_inr_cimr99: +application: iliad; +calculer domaine base_inr_cimr99 corrective; + +cible sauve_base_inr_cimr07: +application: iliad; +calculer domaine base_inr_cimr07 corrective; + +cible sauve_base_inr_cimr24: +application: iliad; +calculer domaine base_inr_cimr24 corrective; + +cible sauve_base_inr_tlcimr07: +application: iliad; +calculer domaine base_inr_tlcimr07 corrective; + +cible sauve_base_inr_tlcimr24: +application: iliad; +calculer domaine base_inr_tlcimr24 corrective; + +cible sauve_base_tlnunv: +application: iliad; +calculer domaine base_TLNUNV corrective; + +cible sauve_base_tl: +application: iliad; +calculer domaine base_tl corrective; + +cible sauve_base_tl_init: +application: iliad; +calculer domaine base_tl_init corrective; + +cible sauve_base_tl_rect: +application: iliad; +calculer domaine base_tl_rect corrective; + +cible sauve_base_initial: +application: iliad; +calculer domaine base_INITIAL corrective; + +cible sauve_base_abat98: +application: iliad; +calculer domaine base_ABAT98 corrective; + +cible sauve_base_abat99: +application: iliad; +calculer domaine base_ABAT99 corrective; + +cible sauve_base_majo: +application: iliad; +calculer domaine base_MAJO corrective; + +cible sauve_base_inr: +application: iliad; +calculer domaine base_INR corrective; + +cible sauve_base_HR: +application: iliad; +calculer domaine base_HR corrective; + +cible sauve_base_primitive_penalisee: +application: iliad; +calculer domaine base_primitive_penalisee corrective; + +cible ENCH_TL: +application: iliad; +calculer enchaineur ENCH_TL; + +cible verif_calcul_primitive_isf: +application: iliad; +nettoie_erreurs; +verifier domaine isf : avec nb_categorie(calculee *) > 0; + +cible verif_calcul_primitive: +application: iliad; +calculer cible verif_calcul_primitive_isf; +si nb_bloquantes() = 0 alors + verifier domaine primitive + : avec + nb_categorie(calculee *) > 0 + ou numero_verif() = 1021; +finsi + +cible verif_calcul_corrective: +application: iliad; +nettoie_erreurs; +calculer cible calcul_primitif_isf; +calculer cible verif_calcul_primitive_isf; +si nb_bloquantes() = 0 alors + verifier domaine corrective + : avec + nb_categorie(calculee *) > 0 + ou numero_verif() = 1021; +finsi + +cible verif_saisie_cohe_primitive_isf_raw: +application: iliad; +nettoie_erreurs; +verifier domaine isf +: avec nb_categorie(saisie *) > 0 et nb_categorie(calculee *) = 0; + +cible verif_saisie_cohe_primitive: +application: iliad; +nettoie_erreurs; +calculer cible verif_saisie_cohe_primitive_isf_raw; +si nb_bloquantes() = 0 alors + calculer cible calcul_primitif_isf; + calculer cible verif_calcul_primitive_isf; + si nb_bloquantes() = 0 alors + verifier domaine primitive + : avec + nb_categorie(saisie *) > 0 et nb_categorie(calculee *) = 0 + et numero_verif() != 1021; + finsi +finsi + +cible verif_saisie_cohe_corrective: +application: iliad; +nettoie_erreurs; +calculer cible verif_saisie_cohe_primitive_isf_raw; +si nb_bloquantes() = 0 alors + verifier domaine corrective + : avec + nb_categorie(saisie *) > 0 et nb_categorie(calculee *) = 0 + et numero_verif() != 1021; +finsi + +cible verif_cohe_horizontale: +application: iliad; +nettoie_erreurs; +verifier domaine horizontale corrective; + +cible verif_contexte_cohe_primitive: +application: iliad; +nettoie_erreurs; +verifier domaine primitive +: avec nb_categorie(saisie contexte) = nb_categorie(*); + +cible verif_contexte_cohe_corrective: +application: iliad; +nettoie_erreurs; +verifier domaine corrective +: avec nb_categorie(saisie contexte) = nb_categorie(*); + +cible verif_famille_cohe_primitive: +application: iliad; +nettoie_erreurs; +verifier domaine primitive +: avec + nb_categorie(saisie famille) > 0 + et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte) + et numero_verif() != 1021; + +cible verif_famille_cohe_corrective: +application: iliad; +nettoie_erreurs; +verifier domaine corrective +: avec + nb_categorie(saisie famille) > 0 + et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte) + et numero_verif() != 1021; + +cible verif_revenu_cohe_primitive: +application: iliad; +nettoie_erreurs; +verifier domaine primitive +: avec nb_categorie(saisie revenu) > 0 et nb_categorie(calculee *) = 0; + +cible verif_revenu_cohe_corrective: +application: iliad; +nettoie_erreurs; +verifier domaine corrective +: avec nb_categorie(saisie revenu) > 0 et nb_categorie(calculee *) = 0; + +# primitif ml + +cible trace_in: +application: iliad; +variables_temporaires: TOTO; +TOTO = 0; +#afficher_erreur indenter(2); + +cible trace_out: +application: iliad; +variables_temporaires: TOTO; +TOTO = 0; +#afficher_erreur indenter(-2); + +cible calcul_prim_corr: +application: iliad; +#afficher_erreur "calcul_prim_corr[\n"; +calculer cible trace_in; +si V_IND_TRAIT = 4 alors # PRIMITIF + calculer cible calcul_primitif; +sinon + calculer cible calcul_correctif; +finsi +calculer cible trace_out; +#afficher_erreur "]calcul_prim_corr\n"; + +cible effacer_base_etc: +application : iliad; +#afficher_erreur "effacer_base_etc[\n"; +calculer cible trace_in; +iterer +: variable ITBASE +: categorie calculee base +: dans ( + ITBASE = indefini; +) +calculer cible trace_out; +#afficher_erreur "]effacer_base_etc\n"; + +cible effacer_calculee_etc: +application : iliad; +#afficher_erreur "effacer_calculee_etc[\n"; +calculer cible trace_in; +iterer +: variable ITCAL +: categorie calculee +: dans ( + ITCAL = indefini; +) +calculer cible trace_out; +#afficher_erreur "]effacer_calculee_etc\n"; + +cible calcule_acomptes: +application: iliad; +variables_temporaires: SAUV_ART1731BIS, SAUV_PREM8_11; +#afficher_erreur "calcule_acomptes[\n"; +calculer cible trace_in; +FLAG_ACO = 1; +V_CALCUL_ACO = 1; +calculer cible calcul_prim_corr; +V_CALCUL_ACO = 0; +FLAG_ACO = 2; +SAUV_ART1731BIS = ART1731BIS + 0; +SAUV_PREM8_11 = PREM8_11 + 0; +calculer cible effacer_calculee_etc; +si V_IND_TRAIT = 4 alors # PRIMITIF + calculer cible effacer_base_etc; + ART1731BIS = SAUV_ART1731BIS; + PREM8_11 = SAUV_PREM8_11; +finsi +calculer cible trace_out; +#afficher_erreur "]calcule_acomptes\n"; + +cible effacer_avfisc_1: +application: iliad; +#afficher_erreur "effacer_avfisc_1[\n"; +calculer cible trace_in; +iterer +: variable REV_AV +: categorie saisie revenu, saisie revenu corrective +: avec attribut(REV_AV, avfisc) = 1 et present(REV_AV) +: dans ( + REV_AV = indefini; +) +calculer cible trace_out; +#afficher_erreur "]effacer_avfisc_1\n"; + +cible est_code_supp_avfisc: +application: iliad; +arguments: EXISTE_CODE_SUPP; +#afficher_erreur "est_code_supp_avfisc[\n"; +calculer cible trace_in; +EXISTE_CODE_SUPP = 0; +#si +# present(COD7QD) ou present(COD7QB) ou present(COD7QC) +# ou present(RFORDI) ou present(RFROBOR) ou present(RFDORD) +# ou present(RFDHIS) ou present(REPSNO3_A) +# ou present(COD7QF) ou present(COD7QH) ou present(CELRREDLG_A) +# ou present(PINELQM_A) ou present(RCMABD) ou present(COD7KM) +# ou present(PINELQP_A) ou present(COD7QS_A) ou present(PINELQN_A) +# ou present(PINELQO_A) +#alors +# EXISTE_CODE_SUPP = 1; +#sinon + iterer + : variable REV_AV + : categorie saisie revenu, saisie revenu corrective + : avec attribut(REV_AV, avfisc) = 2 et present(REV_AV) + : dans ( + EXISTE_CODE_SUPP = 1; + ) +#finsi +calculer cible trace_out; +#afficher_erreur "]est_code_supp_avfisc\n"; + +cible calcule_avfiscal: +application: iliad; +variables_temporaires: + EXISTE_AVFISC, EXISTE_CODE_SUPP, + SAUV_IAD11, SAUV_INE, SAUV_IRE, SAUV_ART1731BIS, SAUV_PREM8_11; +#afficher_erreur "calcule_avfiscal[\n"; +calculer cible trace_in; +EXISTE_AVFISC = 0; +iterer +: variable REV_AV +: categorie saisie revenu, saisie revenu corrective +: avec attribut(REV_AV, avfisc) dans (1, 2) et present(REV_AV) +: dans ( + EXISTE_AVFISC = 1; +) +calculer cible est_code_supp_avfisc : avec EXISTE_CODE_SUPP; +si EXISTE_CODE_SUPP = 0 alors + EXISTE_AVFISC = 1; +finsi +si EXISTE_AVFISC = 1 alors + restaurer + : variable REV_AV + : categorie saisie revenu, saisie revenu corrective + : avec attribut(REV_AV, avfisc) = 1 et present(REV_AV) + : apres ( + calculer cible effacer_avfisc_1; + V_INDTEO = 1; + V_CALCUL_NAPS = 1; + calculer cible calcul_prim_corr; + V_CALCUL_NAPS = 0; + SAUV_IAD11 = IAD11; + SAUV_INE = INE; + SAUV_IRE = IRE; + SAUV_ART1731BIS = ART1731BIS + 0; + SAUV_PREM8_11 = PREM8_11 + 0; + calculer cible effacer_calculee_etc; + si V_IND_TRAIT = 4 alors # PRIMITIF + calculer cible effacer_base_etc; + ART1731BIS = SAUV_ART1731BIS; + PREM8_11 = SAUV_PREM8_11; + finsi + ) + V_IAD11TEO = SAUV_IAD11; + V_IRETEO = SAUV_IRE; + V_INETEO = SAUV_INE; +sinon + calculer cible effacer_avfisc_1; +finsi +calculer cible trace_out; +#afficher_erreur "]calcule_avfiscal\n"; + +cible article_1731_bis: +application : iliad; +#afficher_erreur "article_1731_bis[\n"; +calculer cible trace_in; +si V_IND_TRAIT = 4 alors # PRIMITIF + si CMAJ dans (8, 11) alors + ART1731BIS = 1; + PREM8_11 = 1; + sinon + ART1731BIS = 0; + finsi +finsi +calculer cible trace_out; +#afficher_erreur "]article_1731_bis\n"; + +cible calcule_acomptes_avfisc: +application: iliad; +variables_temporaires: NAP_SANS_PENA_REEL, SAUV_ART1731BIS, SAUV_PREM8_11; +#afficher_erreur "calcule_acomptes_avfisc[\n"; +calculer cible trace_in; +NAP_SANS_PENA_REEL = 0; # toujours 0 ? +FLAG_ACO = 1; +calculer cible calcule_avfiscal; +V_INDTEO = 0; +V_NEGREEL = si (NAP_SANS_PENA_REEL > 0.0) alors (0) sinon (1) finsi; +V_NAPREEL = abs(NAP_SANS_PENA_REEL); +V_CALCUL_ACO = 1; +calculer cible calcul_prim_corr; +SAUV_ART1731BIS = ART1731BIS + 0; +SAUV_PREM8_11 = PREM8_11 + 0; +calculer cible effacer_calculee_etc; +si V_IND_TRAIT = 4 alors # PRIMITIF + ART1731BIS = SAUV_ART1731BIS; + PREM8_11 = SAUV_PREM8_11; +finsi +calculer cible trace_out; +#afficher_erreur "]calcule_acomptes_avfisc\n"; + +cible est_calcul_acomptes: +application: iliad; +arguments: EXISTE_ACOMPTES; +#afficher_erreur "est_calcul_acomptes[\n"; +calculer cible trace_in; +EXISTE_ACOMPTES = 0; +iterer +: variable REV_AC +: categorie saisie revenu, saisie revenu corrective +: avec attribut(REV_AC, acompte) = 0 et present(REV_AC) +: dans ( + EXISTE_ACOMPTES = 1; +) +calculer cible trace_out; +#afficher_erreur "]est_calcul_acomptes\n"; + +cible est_calcul_avfisc: +application: iliad; +arguments: EXISTE_AVFISC; +#afficher_erreur "est_calcul_avfisc[\n"; +calculer cible trace_in; +EXISTE_AVFISC = 0; +iterer +: variable REV_AV +: categorie saisie revenu, saisie revenu corrective +: avec attribut(REV_AV, avfisc) = 1 et present(REV_AV) +: dans ( + EXISTE_AVFISC = 1; +) +si EXISTE_AVFISC = 0 alors + calculer cible est_code_supp_avfisc : avec EXISTE_AVFISC; +finsi +calculer cible trace_out; +#afficher_erreur "]est_calcul_avfisc\n"; + +cible traite_double_liquidation3: +application: iliad; +arguments: P_EST_CALCUL_ACOMPTES; +variables_temporaires: CALCUL_ACOMPTES, CALCUL_AVFISC, SAUV_IRANT; +#afficher_erreur "traite_double_liquidation3[\n"; +calculer cible trace_in; +FLAG_ACO = 0; +V_NEGACO = 0; +V_AVFISCOPBIS = 0; +V_DIFTEOREEL = 0; +si V_IND_TRAIT = 4 alors # primitif + PREM8_11 = 0; + calculer cible article_1731_bis; +finsi +calculer cible est_calcul_acomptes : avec CALCUL_ACOMPTES; +calculer cible est_calcul_avfisc : avec CALCUL_AVFISC; +si CALCUL_AVFISC = 1 alors + SAUV_IRANT = IRANT + 0 ; + IRANT = indefini; +sinon + SAUV_IRANT = 0; +finsi +si CALCUL_ACOMPTES = 1 et P_EST_CALCUL_ACOMPTES != 0 alors + restaurer + : variable REV_AC + : categorie saisie revenu, saisie revenu corrective + : avec attribut(REV_AC, acompte) = 0 + : apres ( + iterer + : variable REV_AC + : categorie saisie revenu, saisie revenu corrective + : avec attribut(REV_AC, acompte) = 0 + : dans ( + REV_AC = indefini; + ) + si CALCUL_AVFISC = 1 alors + calculer cible calcule_acomptes_avfisc; + sinon + calculer cible calcule_acomptes; + finsi + ) +finsi +si CALCUL_AVFISC = 1 alors + V_AVFISCOPBIS = 0; + V_DIFTEOREEL = 0; + V_INDTEO = 1; + calculer cible calcule_avfiscal; + V_INDTEO = 0; + V_NEGREEL = 1; + V_NAPREEL = 0; +finsi +si CALCUL_AVFISC = 1 et SAUV_IRANT != 0 alors + IRANT = SAUV_IRANT; +finsi +V_ACO_MTAP = 0; +V_NEGACO = 0; +calculer cible calcul_primitif_isf; +calculer cible calcul_prim_corr; +#afficher_erreur "calcul_primitif_taux[\n"; +calculer cible trace_in; +calculer cible calcul_primitif_taux; +calculer cible trace_out; +#afficher_erreur "]calcul_primitif_taux\n"; +si V_IND_TRAIT = 4 alors # primitif + calculer cible verif_calcul_primitive; +finsi +calculer cible trace_out; +#afficher_erreur "]traite_double_liquidation3\n"; + +cible abs_flag: +application: iliad; +arguments: VAR, ABS, FLAG; +si present(VAR) alors + FLAG = (VAR < 0); + ABS = abs(VAR); + VAR = ABS; +finsi + +cible traite_double_liquidation_exit_taxe: +application: iliad; +variables_temporaires: CALCULER_ACOMPTES; +#afficher_erreur "traite_double_liquidation_exit_taxe[\n"; +calculer cible trace_in; +si present(PVIMPOS) ou present(CODRWB) alors + FLAG_3WBNEG = 0; + FLAG_EXIT = 1; + CALCULER_ACOMPTES = 0; + calculer cible traite_double_liquidation3 : avec CALCULER_ACOMPTES; + calculer cible abs_flag : avec NAPTIR, V_NAPTIR3WB, FLAG_3WBNEG; + si present(IHAUTREVT) alors + V_CHR3WB = IHAUTREVT; + finsi + si present(IAD11) alors + V_ID113WB = IAD11; + finsi + FLAG_EXIT = 0; +finsi +si present(PVSURSI) ou present(CODRWA) alors + FLAG_3WANEG = 0; + FLAG_EXIT = 2; + CALCULER_ACOMPTES = 0; + calculer cible traite_double_liquidation3 : avec CALCULER_ACOMPTES; + calculer cible abs_flag : avec NAPTIR, V_NAPTIR3WA, FLAG_3WANEG; + si present(IHAUTREVT) alors + V_CHR3WA = IHAUTREVT; + finsi + si present(IAD11) alors + V_ID113WA = IAD11; + finsi + FLAG_EXIT = 0; +finsi +FLAG_BAREM = 1; +CALCULER_ACOMPTES = 1; +calculer cible traite_double_liquidation3 : avec CALCULER_ACOMPTES; +si present(RASTXFOYER) alors + V_BARTXFOYER = RASTXFOYER; +finsi +si present(RASTXDEC1) alors + V_BARTXDEC1 = RASTXDEC1; +finsi +si present(RASTXDEC2) alors + V_BARTXDEC2 = RASTXDEC2; +finsi +si present(INDTAZ) alors + si INDTAZ >= 0 alors + V_BARINDTAZ = INDTAZ; +## Segfault !!! ## +# sinon +# leve_erreur A000; + finsi +finsi +calculer cible abs_flag : avec IITAZIR, V_BARIITAZIR, FLAG_BARIITANEG; +si present(IRTOTAL) alors + V_BARIRTOTAL = IRTOTAL; +finsi +FLAG_BAREM = 0; +CALCULER_ACOMPTES = 1; +calculer cible traite_double_liquidation3 : avec CALCULER_ACOMPTES; +calculer cible trace_out; +#afficher_erreur "]traite_double_liquidation_exit_taxe\n"; + +cible traite_double_liquidation_pvro: +application: iliad; +#afficher_erreur "traite_double_liquidation_pvro[\n"; +calculer cible trace_in; +si present(COD3WG) alors + FLAG_PVRO = 1; + calculer cible traite_double_liquidation_exit_taxe; + si present(IAD11) alors + V_IPVRO = IAD11; + finsi +finsi +FLAG_PVRO = 0; +calculer cible traite_double_liquidation_exit_taxe; +calculer cible trace_out; +#afficher_erreur "]traite_double_liquidation_pvro\n"; + +cible ir_verif_saisie_isf: +application: iliad; +calculer cible regle_1; +calculer cible verif_saisie_cohe_primitive_isf_raw; + +cible ir_verif_contexte: +application: iliad; +calculer cible regle_1; +calculer cible verif_contexte_cohe_primitive; + +cible ir_verif_famille: +application: iliad; +calculer cible regle_1; +calculer cible verif_famille_cohe_primitive; + +cible ir_verif_revenu: +application: iliad; +#afficher_erreur "ir_verif_revenu[\n"; +calculer cible trace_in; +si + present(COD9AA) ou present(COD9AB) ou present(COD9AC) ou present(COD9AD) + ou present(COD9AE) ou present(COD9BA) ou present(COD9BB) ou present(COD9CA) + ou present(COD9GF) ou present(COD9GH) ou present(COD9GL) ou present(COD9GM) + ou present(COD9GN) ou present(COD9GY) ou present(COD9NC) ou present(COD9NG) + ou present(COD9PR) ou present(COD9PX) ou present(COD9RS) ou present(CMAJ_ISF) + ou present(MOISAN_ISF) +alors + si V_REGCO + 0 = 0 alors + V_REGCO = 1; + finsi + si V_0DA + 0 = 0 alors + V_0DA = 1980; + finsi +finsi +calculer cible regle_1; +calculer cible verif_revenu_cohe_primitive; +calculer cible trace_out; +#afficher_erreur "]ir_verif_revenu\n"; + +cible ir_calcul_primitif_isf: +application: iliad; +#afficher_erreur "ir_calcul_primitif_isf[\n"; +calculer cible trace_in; +calculer cible calcul_primitif_isf; +nettoie_erreurs; +calculer cible verif_calcul_primitive_isf; +calculer cible trace_out; +#afficher_erreur "]ir_calcul_primitif_isf\n"; + +cible modulation_taxation: +application: iliad; +#afficher_erreur "modulation_taxation[\n"; +calculer cible trace_in; +si V_MODUL = 1 alors + iterer + : variable IT_MOD + : categorie saisie revenu, saisie revenu corrective, saisie famille + : avec present(IT_MOD) et attribut(IT_MOD, modcat) < 1 + : dans ( + IT_MOD = indefini; + leve_erreur DD40 IT_MOD; + ) + iterer + : variable IT_MOD + : categorie saisie contexte + : avec present(IT_MOD) et attribut(IT_MOD, modcat) < 1 + : dans ( + IT_MOD = indefini; + ) +finsi +si (non present(V_MODUL)) ou V_MODUL != 1 alors + iterer + : variable IT_MOD + : categorie saisie revenu, saisie revenu corrective, saisie famille + : avec present(IT_MOD) et attribut(IT_MOD, modcat) > 1 + : dans ( + IT_MOD = indefini; + ) + iterer + : variable IT_MOD + : categorie saisie contexte + : avec present(IT_MOD) et attribut(IT_MOD, modcat) > 1 + : dans ( + IT_MOD = indefini; + leve_erreur DD40 IT_MOD; + ) +finsi +calculer cible trace_out; +#afficher_erreur "]modulation_taxation\n"; + +cible traite_double_liquidation_2: +application: iliad; +calculer cible modulation_taxation; +calculer cible traite_double_liquidation_pvro; + +cible enchaine_calcul: +application: iliad; +# variables_temporaires: CALCULER_ACOMPTES; +si V_IND_TRAIT = 4 alors # primitif + calculer cible effacer_base_etc; + calculer cible traite_double_liquidation_2; + calculer cible sauve_base_initial; + calculer cible sauve_base_1728; + calculer cible sauve_base_anterieure; + calculer cible sauve_base_anterieure_cor; + calculer cible sauve_base_inr_inter22; +sinon + V_ACO_MTAP = 0; + V_NEGACO = 0; +# CALCULER_ACOMPTES = si (present(FLAGDERNIE)) alors (1) sinon (0) finsi; +# calculer cible traite_double_liquidation3 : avec CALCULER_ACOMPTES; + calculer cible traite_double_liquidation_pvro; +finsi + +cible exporte_si_non_bloquantes: +application: iliad; +si nb_discordances() + nb_informatives() > 0 alors + exporte_erreurs; +finsi + +cible enchainement_primitif: +application: iliad; +variables_temporaires: EXPORTE_ERREUR; +#afficher_erreur "traite_double_liquidation2[\n"; +calculer cible trace_in; +calculer cible ir_verif_saisie_isf; +finalise_erreurs; +EXPORTE_ERREUR = 1; +quand nb_anomalies() = 0 faire + EXPORTE_ERREUR = 0; +puis_quand nb_discordances() + nb_informatives() = 0 faire + calculer cible ir_verif_contexte; + finalise_erreurs; + EXPORTE_ERREUR = 0; +puis_quand nb_anomalies() = 0 faire + calculer cible exporte_si_non_bloquantes; + calculer cible ir_verif_famille; + finalise_erreurs; +puis_quand nb_anomalies() = 0 faire + EXPORTE_ERREUR = 1; +puis_quand nb_discordances() + nb_informatives() = 0 faire + calculer cible ir_verif_revenu; + finalise_erreurs; +puis_quand nb_anomalies() = 0 faire + calculer cible exporte_si_non_bloquantes; + calculer cible ir_calcul_primitif_isf; + finalise_erreurs; + calculer cible enchaine_calcul; + finalise_erreurs; + calculer cible exporte_si_non_bloquantes; +sinon_faire + si EXPORTE_ERREUR = 1 alors + exporte_erreurs; + finsi +finquand +calculer cible trace_out; +#afficher_erreur "]traite_double_liquidation2\n"; + +# primitif iterpréteur + +cible enchainement_primitif_interpreteur: +application: iliad; +V_IND_TRAIT = 4; # primitif +calculer cible enchainement_primitif; + diff --git a/makefiles/variables.mk b/makefiles/variables.mk index 44cb7ccb3..880d393ea 100644 --- a/makefiles/variables.mk +++ b/makefiles/variables.mk @@ -17,7 +17,7 @@ MPP_FUNCTION_BACKEND?=enchainement_primitif MPP_FUNCTION?=enchainement_primitif_interpreteur SOURCE_EXT_FILES?=$(call source_dir_ext,$(ROOT_DIR)/m_ext/$(YEAR)/) # Add a TESTS_DIR for 2023 when available -ifeq ($(YEAR), 2023) +ifeq ($(filter $(YEAR), 2023 2024), $(YEAR)) #$(warning WARNING: the source M files and fuzzer tests have not yet been published for year: $(YEAR). Should you choose to provide your own source files, you can create a directory ir-calcul/M_SVN/$(YEAR) and put them in there) SOURCE_FILES?=$(call source_dir,$(ROOT_DIR)/ir-calcul/M_SVN/$(YEAR)/code_m/) TESTS_DIR?=$(ROOT_DIR)/tests/$(YEAR)/fuzzing diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index 99397d471..feaffaa95 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -138,7 +138,6 @@ rule token = parse | "un" -> ONE | "valeur" -> VALUE | "variable" -> VARIABLE - | "variables" -> VARIABLES | "variables_temporaires" -> TEMP_VARS | "verif" -> VERIFICATION | "verifiable" -> VERIFIABLE diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 728d604bd..148f121b5 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -55,7 +55,7 @@ along with this program. If not, see . %token RAISE_ERROR EXPORT_ERRORS CLEAN_ERRORS FINALIZE_ERRORS %token ITERATE CATEGORY RESTORE AFTER %token ERROR ANOMALY DISCORDANCE -%token INFORMATIVE OUTPUT FONCTION VARIABLE VARIABLES ATTRIBUT +%token INFORMATIVE OUTPUT FONCTION VARIABLE ATTRIBUT %token BASE GIVEN_BACK COMPUTABLE BY_DEFAULT %token DOMAIN SPECIALIZE AUTHORIZE VERIFIABLE EVENT EVENTS VALUE STEP %token EVENT_FIELD ARRANGE_EVENTS SORT FILTER ADD REFERENCE From 60cd65f993b5e01f1d1abdf698749ad80b68b351 Mon Sep 17 00:00:00 2001 From: David MICHEL Date: Wed, 19 Feb 2025 18:44:52 +0100 Subject: [PATCH 32/32] Racourcissement des noms des fichiers "varinfo_*.c" --- src/mlang/backend_compilers/dgfip_gen_files.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index 41fb691c8..3db786039 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -22,7 +22,7 @@ let open_file filename = let gen_table_varinfo vars cat Com.CatVar.{ id_int; id_str; attributs; _ } (stats, var_map) = - let oc, fmt = open_file (Pp.spr "varinfo_%s.c" id_str) in + let oc, fmt = open_file (Pp.spr "varinfo_%d.c" id_int) in Format.fprintf fmt {|/****** LICENCE CECIL *****/ #include "mlang.h"