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/m.ml b/examples/dgfip_c/ml_primitif/ml_driver/m.ml index 94a819db3..54bd75785 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/m.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/m.ml @@ -148,4 +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 option + * float option + * float + * float option + ) 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..e1d4a2484 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/main.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/main.ml @@ -1,31 +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 res_prim, ctl_prim = - let fold_prim (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 - | `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 - | `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 - 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, 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 @@ -75,79 +116,39 @@ let var_addr () = in Lazy.force vars -let compare_dump out outexp = - let out = open_in_bin out in - let outexp = open_in_bin outexp in - let read64 ic = - let buf = Bytes.create 8 in - really_input ic buf 0 8; - buf - in - let rec read_val_diffs vars diffs = - match vars with - | [] -> diffs - | (addr, var)::vars -> - assert (pos_in out = addr); - let res_val = read64 out in - let expe_val = read64 outexp in - if Bytes.equal res_val expe_val then - read_val_diffs vars diffs - else - read_val_diffs vars ((var, res_val, expe_val)::diffs) - in - let rec read_strings ic strs = - try - let str = read64 ic in - let strs = StrSet.add (Bytes.to_string str) strs in - read_strings ic strs - with - | End_of_file -> strs - in - let diffs = read_val_diffs (var_addr ()) [] in - let raised_disco = read_strings out StrSet.empty in - let expected_disco = read_strings outexp StrSet.empty in - StrSet.iter (fun ano -> - Printf.eprintf "Raised unexpected discordance %s\n" ano - ) (StrSet.diff raised_disco expected_disco); - StrSet.iter (fun ano -> - Printf.eprintf "Expected discordance %s not raised\n" ano - ) (StrSet.diff expected_disco raised_disco); - let undef = Int64.of_string "0xefbeaddeefbeadde" in - let hex2floatstr bytes = - let i64 = Bytes.get_int64_le bytes 0 in - if Int64.equal i64 undef then "undef" - else string_of_float(Int64.float_of_bits i64) - in - List.iter (fun (var, res, exp) -> - Printf.eprintf "%s: %s found, expected %s\n" - var (hex2floatstr res) (hex2floatstr exp) - ) - diffs; - flush stderr; - close_in out; - close_in 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 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 ( @@ -175,7 +176,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 ce7967859..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; @@ -21,7 +23,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 +30,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 @@ -55,16 +60,33 @@ 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) + if String.length code = 0 then err (); + 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_opt penalite, + convert_float_opt base_tl, + convert_float date_evt, + convert_float_opt 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..f3972de10 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/stubs.c +++ b/examples/dgfip_c/ml_primitif/ml_driver/stubs.c @@ -18,6 +18,7 @@ #if OCAML_VERSION < 41200 #define Val_none Val_int(0) +#define Some_val(v) Field(v, 0) CAMLexport value caml_alloc_some(value v) { CAMLparam1(v); @@ -120,8 +121,11 @@ CAMLprim value ml_tgv_defined(value mlTgv, value mlCode) { T_irdata *tgv = Tgv_val(mlTgv); const char *code = String_val(mlCode); int def = 0; + char res_def = 0; + double res_val = 0.0; T_varinfo *varinfo = cherche_var(tgv, code); - def = lis_varinfo_def(tgv, varinfo); + lis_varinfo(tgv, varinfo, &res_def, &res_val); + def = (int)res_def; CAMLreturn(Val_int(def != 0)); } @@ -142,8 +146,11 @@ CAMLprim value ml_tgv_get(value mlTgv, value mlCode) { T_irdata *tgv = Tgv_val(mlTgv); const char *code = String_val(mlCode); T_varinfo *varinfo = cherche_var(tgv, code); - if (lis_varinfo_def(tgv, varinfo)) { - optOut = caml_alloc_some(caml_copy_double(lis_varinfo_val(tgv, varinfo))); + char res_def = 0; + double res_val = 0.0; + lis_varinfo(tgv, varinfo, &res_def, &res_val); + if (res_def) { + optOut = caml_alloc_some(caml_copy_double(res_val)); } else { optOut = Val_none; } @@ -158,11 +165,17 @@ CAMLprim value ml_tgv_get_array(value mlTgv, value mlCode, value mlIdx) { const char *code = String_val(mlCode); int idx = Int_val(mlIdx); T_varinfo *varinfo = cherche_var(tgv, code); - if (lis_varinfo_tab_def(tgv, varinfo, idx)) { - double val = lis_varinfo_tab_val(tgv, varinfo, idx); - optOut = caml_alloc_some(caml_copy_double(val)); + char res_def; + double res_val; + if (varinfo != NULL && varinfo->tab_idx >= 0) { + lis_tabaccess(tgv, varinfo->tab_idx, 1, (double)idx, &res_def, &res_val); + if (res_def > 0) { + optOut = caml_alloc_some(caml_copy_double(res_val)); + } else { + optOut = Val_none; + } } else { - optOut = Val_none; + optOut = Val_none; } CAMLreturn(optOut); } @@ -199,7 +212,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) { @@ -213,3 +226,79 @@ CAMLprim value ml_enchainement_primitif(value mlTgv) { CAMLreturn(mlErrListOut); } +CAMLprim value ml_set_evt_list(value mlTgv, value mlEvtList) { + CAMLparam2(mlTgv, mlEvtList); + CAMLlocal3(mlList, mlEvt, mlField); + + 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) { + T_event *evt = (T_event *)malloc(sizeof (T_event)); + tgv->events[i] = evt; + mlEvt = Field(mlList, 0); + + 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); + } + CAMLreturn(Val_unit); +} + + diff --git a/m_ext/0/cibles.m b/m_ext/0/cibles.m new file mode 100644 index 000000000..83f536ec6 --- /dev/null +++ b/m_ext/0/cibles.m @@ -0,0 +1,256 @@ +application iliad; + +V_ANCSDED : saisie contexte + classe = 0 priorite = 10 categorie_TL = 20 modcat = 1 primrest = 0 + restituee + alias ANCSDED + : "Annee de revenu pour variation CSG"; + +V_ANREV : saisie contexte + classe = 0 priorite = 10 categorie_TL = 20 modcat = 1 primrest = 0 + restituee + alias ANREV + : "Annee des revenus" type REEL; + +V_IND_TRAIT : saisie contexte + classe = 0 priorite = 10 categorie_TL = 20 modcat = 1 primrest = 0 + restituee + alias IND_TRAIT + : "indicateur de nature de traitement primitif ou correctif"; + +RESULTAT : calculee primrest = 0 restituee : "resultat du traitement" ; +TOTO01 : calculee primrest = 0 restituee : "" ; +TOTO03 : calculee primrest = 0 restituee : "" ; +TOTO05 : calculee primrest = 0 restituee : "" ; +TUTU : tableau[5] calculee primrest = 0 restituee : "" ; + +cible test_varcons: +application: iliad; +variables_temporaires: TITI tableau[5]; +afficher_erreur "entree test_varcons\n" indenter(2); +iterer : variable I : 1..5 increment 2 : dans ( + TOTO[00: I] = 450 + I; + afficher_erreur nom(TOTO[00: I]) " = " (TOTO[00: I]) "\n"; +) +iterer : variable I : 0..(taille(TUTU) - 1) increment 1 : dans ( + TUTU[I] = 787800 + I; +) +iterer : variable I : 0..(taille(TUTU) - 1) increment 1 : dans ( + afficher_erreur nom(TUTU[0: I]) " = " (TUTU[I]) "\n"; +) +iterer : variable I : 0..(taille(TITI) - 1) increment 1 : dans ( + TITI[I] = 717100 + I; +) +iterer : variable I : 0..(taille(TITI) - 1) increment 1 : dans ( + afficher_erreur nom(TITI[0: I]) " = " (TITI[I]) "\n"; +) +afficher_erreur indenter(-2) "sortie test_varcons\n"; + +fonction toto_fonction: +application: iliad; +arguments: A0, A1, A2, A3, A4, A5, A6; +resultat: R; +variables_temporaires: PROUT0, PROUT1, PROUT2; +R = A0 + A1 + A2 + A3 + A4 + A5 + A6; + +cible toto_cible: +application: iliad; +arguments: A0, A1, A2, A3, A4, A5, A6, R; +iterer : variable PROUT0 : categorie calculee * : dans ( + iterer : variable PROUT1 : categorie calculee * : dans ( + iterer : variable PROUT2 : categorie calculee * : dans ( + R = A0 + A1 + A2 + A3 + A4 + A5 + A6; + ) + ) +) + +cible test_args: +application: iliad; +variables_temporaires: A0, A1, A2, A3, AA tableau[3], A4, A5, A6, R; +afficher_erreur "entree test_args\n" indenter(2); +iterer : variable I : 0..6 increment 1 : dans ( + A[0: I] = I; +) +R = 7; +calculer cible toto_cible : avec A0, A1, A2, A3, A4, A5, A6, R; +afficher_erreur "toto_cible(...) = " (R) "\n"; +afficher_erreur "toto_fonction(...) = "; +afficher_erreur (toto_fonction(A0, A1, A2, A3, A4, A5, A6)); +afficher_erreur "\n"; +afficher_erreur indenter(-2) "sortie test_args\n"; + +cible tmpref_cible: +application: iliad; +arguments: X, A; +variables_temporaires: T; +afficher_erreur indenter(2); +afficher_erreur nom(X) " = " (X) " " nom(A) " = " (A) "\n"; +X = 444; +A = 12300 + A; +afficher_erreur indenter(-2); + +cible test_tmpref: +application: iliad; +variables_temporaires: A0, A1, A2, A3, A4, A5, A6, R; +afficher_erreur "entree test_tmpref\n" indenter(2); +A0 = 0; +A1 = 1; +A2 = 2; +A3 = 3; +A4 = 4; +A5 = 5; +A6 = 6; +R = 7; +afficher_erreur nom(A0) " = " (A0) "\n"; +afficher_erreur nom(A1) " = " (A1) "\n"; +afficher_erreur nom(A2) " = " (A2) "\n"; +afficher_erreur nom(A3) " = " (A3) "\n"; +afficher_erreur nom(A4) " = " (A4) "\n"; +afficher_erreur nom(A5) " = " (A5) "\n"; +afficher_erreur nom(A6) " = " (A6) "\n"; +afficher_erreur nom(R) " = " (R) "\n"; +calculer cible tmpref_cible : avec R, A3; +afficher_erreur nom(A0) " = " (A0) "\n"; +afficher_erreur nom(A1) " = " (A1) "\n"; +afficher_erreur nom(A2) " = " (A2) "\n"; +afficher_erreur nom(A3) " = " (A3) "\n"; +afficher_erreur nom(A4) " = " (A4) "\n"; +afficher_erreur nom(A5) " = " (A5) "\n"; +afficher_erreur nom(A6) " = " (A6) "\n"; +afficher_erreur nom(R) " = " (R) "\n"; +afficher_erreur indenter(-2) "sortie test_tmpref\n"; + +fonction test_aff_fonction: +application: iliad; +arguments: ARG0, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6; +resultat: RES; +variables_temporaires: PROUT0, PROUT1, PROUT2; +afficher_erreur "entree test_aff_fonction\n" indenter(2); +afficher_erreur "argument ARG3 <" nom(ARG3) "> <" alias(ARG3) ">\n"; +afficher_erreur "resultat RES <" nom(RES) "> <" alias(RES) ">\n"; +afficher_erreur indenter(-2) "sortie test_aff_fonction\n"; + +cible test_aff_cible: +application: iliad; +arguments: ARG0, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6; +variables_temporaires: PROUT0, PROUT1, PROUT2; +afficher_erreur "entree test_aff_cible\n" indenter(2); +afficher_erreur "argument ARG3 <" nom(ARG3) "> <" alias(ARG3) ">\n"; +afficher_erreur indenter(-2) "sortie test_aff_cible\n"; + +cible test_aff: +application: iliad; +variables_temporaires: A0, A1, A2, AA tableau [5], A3, A4, A5, A6, R; +afficher_erreur "entree test_aff\n" indenter(2); +afficher_erreur "saisie V_IND_TRAIT <" nom(V_IND_TRAIT) "> <" alias(V_IND_TRAIT) ">\n"; +afficher_erreur "calculee TOTO01 <" nom(TOTO01) "> <" alias(TOTO01) ">\n"; +afficher_erreur "calculee tableau TUTU <" nom(TUTU) "> <" alias(TUTU) ">\n"; +afficher_erreur "temporaire A0 <" nom(A0) "> <" alias(A0) ">\n"; +afficher_erreur "temporaire A2 <" nom(A2) "> <" alias(A2) ">\n"; +afficher_erreur "temporaire tableau AA <" nom(AA) "> <" alias(AA) ">\n"; +afficher_erreur "temporaire AA[2] <" nom(AA[2]) "> <" alias(AA[2]) ">\n"; +afficher_erreur "temporaire A[0: 2] <" nom(A[0: 2]) "> <" alias(A[0: 2]) ">\n"; +iterer : variable VAR : V_IND_TRAIT, TOTO01, A2 : dans ( + afficher_erreur "reference VAR <" nom(VAR) "> <" alias(VAR) ">\n"; +) +afficher_erreur "champ_evenement(2, code) <" nom(champ_evenement(2, code)) "> <" alias(champ_evenement(2, code)) ">\n"; +R = test_aff_fonction(A0, A1, A2, A3, A4, A5, A6); +calculer cible test_aff_cible : avec A0, A1, A2, A3, A4, A5, A6; +afficher_erreur indenter(-2) "sortie test_aff\n"; + +cible test_tab: +application: iliad; +variables_temporaires: A0, A1, A2, AA tableau [5], A3, A4, A5, A6, R; +afficher_erreur "entree test_tab\n" indenter(2); +iterer : variable I : 0..4 increment 1 : dans ( + AA[I] = 1000 + I; +) +afficher_erreur nom(AA) "[-2] = " (AA[-2]) "\n"; +iterer : variable I : 0..4 increment 1 : dans ( + afficher_erreur nom(AA) "[" (I) "] = " (AA[I]) "\n"; +) +afficher_erreur nom(AA) "[7] = " (AA[7]) "\n"; +iterer : variable I : 0..4 increment 1 : dans ( + TUTU[I] = 1000 + I; +) +afficher_erreur nom(TUTU) "[-2] = " (TUTU[-2]) "\n"; +iterer : variable I : 0..4 increment 1 : dans ( + afficher_erreur nom(TUTU) "[" (I) "] = " (TUTU[I]) "\n"; +) +afficher_erreur nom(TUTU) "[7] = " (TUTU[7]) "\n"; +afficher_erreur indenter(-2) "sortie test_tab\n"; + +cible test_est_variable: +application: iliad; +variables_temporaires: A0, AA tableau[25], AKK3, X; +afficher_erreur "entree test_est_variable\n" indenter(2); +X = 3; +afficher_erreur + nom(V_ANREV) ": V_ANREV " (est_variable(V_ANREV, V_ANREV)) + ", ANREV " (est_variable(V_ANREV, ANREV)) + ", PROUT " (est_variable(V_ANREV, PROUT)) "\n"; +afficher_erreur + nom(TUTU) ": TUTU " (est_variable(TUTU, TUTU)) + ", PROUT " (est_variable(TUTU, PROUT)) "\n"; +afficher_erreur + nom(TUTU) "[" (X) "]: TUTU3 " (est_variable(TUTU[X], TUTU3)) + ", PROUT " (est_variable(TUTU[X], PROUT)) "\n"; +afficher_erreur + nom(A0) ": A0 " (est_variable(A0, A0)) + ", PROUT " (est_variable(A0, PROUT)) "\n"; +afficher_erreur + nom(AA) ": AA " (est_variable(AA, AA)) + ", PROUT " (est_variable(AA, PROUT)) "\n"; +afficher_erreur + nom(AA) "[" (X) "]: AA03 " (est_variable(AA[X], AA03)) + ", PROUT " (est_variable(AA[X], PROUT)) "\n"; +afficher_erreur + nom(A[KKK: X]) ": AKK3 " (est_variable(A[KKK: X], AKK3)) + ", PROUT " (est_variable(A[KKK: X], PROUT)) "\n"; +iterer +: variable VAR +: V_ANREV, A0, AA03, AKK3 +: dans ( + afficher_erreur nom(VAR) ": " + "V_ANREV " (est_variable(VAR, V_ANREV)) + ", ANREV " (est_variable(VAR, ANREV)) + ", TUTU " (est_variable(VAR, TUTU)) + ", A0 " (est_variable(VAR, A0)) + ", AA03 " (est_variable(VAR, AA03)) + ", AKK3 " (est_variable(VAR, AKK3)) + ", PROUT " (est_variable(VAR, PROUT)) "\n"; +) +afficher_erreur + nom(champ_evenement(0, code)) ": " + "RESULTAT " (est_variable(champ_evenement(0, code), RESULTAT)) + ", PROUT " (est_variable(champ_evenement(0, code), PROUT)) "\n"; +afficher_erreur indenter(-2) "sortie test_est_variable\n"; + +cible tests: +application: iliad; +variables_temporaires: U0, UUU tableau[5], U1; +#calculer cible test_varcons; +#calculer cible test_args; +#calculer cible test_tmpref; +calculer cible test_aff; +calculer cible test_tab; +calculer cible test_est_variable; + +cible enchainement_primitif: +application: iliad; +afficher_erreur "\n"; +si V_IND_TRAIT = 4 alors + afficher_erreur "--- Primitif ---\n"; +sinon_si V_IND_TRAIT = 5 alors + afficher_erreur "--- Correctif ---\n"; +finsi +afficher_erreur "Bonjour le monde !\n"; +calculer cible tests; +RESULTAT = 0; + +cible enchainement_primitif_interpreteur: +application: iliad; +calculer cible enchainement_primitif; +afficher_erreur "FIN\n"; + + diff --git a/m_ext/2019/cibles.m b/m_ext/2019/cibles.m index d23029833..7c8829f48 100644 --- a/m_ext/2019/cibles.m +++ b/m_ext/2019/cibles.m @@ -252,7 +252,7 @@ si nb_anomalies() = 0 alors cible calcule_acomptes: application: iliad; -variable temporaire: SAUV_ART1731BIS, SAUV_PREM8_11; +variables_temporaires: SAUV_ART1731BIS, SAUV_PREM8_11; FLAG_ACO = 1; V_CALCUL_ACO = 1; calculer cible calcul_prim_corr; @@ -279,7 +279,7 @@ si nb_anomalies() = 0 alors cible calcule_avfiscal: application: iliad; -variable temporaire: EXISTE_AVFISC, SAUV_IAD11, SAUV_INE, SAUV_IRE, SAUV_ART1731BIS, SAUV_PREM8_11; +variables_temporaires: EXISTE_AVFISC, SAUV_IAD11, SAUV_INE, SAUV_IRE, SAUV_ART1731BIS, SAUV_PREM8_11; EXISTE_AVFISC = 0; iterer : variable REV_AV @@ -331,7 +331,7 @@ si CMAJ dans (8, 11) alors cible calcule_acomptes_avfisc: application: iliad; -variable temporaire: NAP_SANS_PENA_REEL, SAUV_ART1731BIS, SAUV_PREM8_11; +variables_temporaires: NAP_SANS_PENA_REEL, SAUV_ART1731BIS, SAUV_PREM8_11; NAP_SANS_PENA_REEL = 0; # toujours 0 ? FLAG_ACO = 1; calculer cible calcule_avfiscal; @@ -375,7 +375,7 @@ si CMAJ dans (8, 11) alors cible traite_double_liquidation3: application: iliad; -variable temporaire: P_EST_CALCUL_ACOMPTES, CALCUL_ACOMPTES, CALCUL_AVFISC, SAUV_IRANT; +variables_temporaires: P_EST_CALCUL_ACOMPTES, CALCUL_ACOMPTES, CALCUL_AVFISC, SAUV_IRANT; P_EST_CALCUL_ACOMPTES = VARTMP1; FLAG_ACO = 0; V_NEGACO = 0; diff --git a/m_ext/2020/cibles.m b/m_ext/2020/cibles.m index 9570d27c7..20809843a 100644 --- a/m_ext/2020/cibles.m +++ b/m_ext/2020/cibles.m @@ -259,7 +259,7 @@ si nb_anomalies() = 0 alors cible calcule_acomptes: application: iliad; -variable temporaire: SAUV_ART1731BIS, SAUV_PREM8_11; +variables_temporaires: SAUV_ART1731BIS, SAUV_PREM8_11; FLAG_ACO = 1; V_CALCUL_ACO = 1; calculer cible calcul_prim_corr; @@ -286,7 +286,7 @@ si nb_anomalies() = 0 alors cible calcule_avfiscal: application: iliad; -variable temporaire: EXISTE_AVFISC, SAUV_IAD11, SAUV_INE, SAUV_IRE, SAUV_ART1731BIS, SAUV_PREM8_11; +variables_temporaires: EXISTE_AVFISC, SAUV_IAD11, SAUV_INE, SAUV_IRE, SAUV_ART1731BIS, SAUV_PREM8_11; EXISTE_AVFISC = 0; iterer : variable REV_AV @@ -338,7 +338,7 @@ si CMAJ dans (8, 11) alors cible calcule_acomptes_avfisc: application: iliad; -variable temporaire: NAP_SANS_PENA_REEL, SAUV_ART1731BIS, SAUV_PREM8_11; +variables_temporaires: NAP_SANS_PENA_REEL, SAUV_ART1731BIS, SAUV_PREM8_11; NAP_SANS_PENA_REEL = 0; # toujours 0 ? FLAG_ACO = 1; calculer cible calcule_avfiscal; @@ -404,7 +404,7 @@ ou present(PINELQO) ou present(COD7LS) cible traite_double_liquidation3: application: iliad; -variable temporaire: P_EST_CALCUL_ACOMPTES, CALCUL_ACOMPTES, CALCUL_AVFISC, SAUV_IRANT; +variables_temporaires: P_EST_CALCUL_ACOMPTES, CALCUL_ACOMPTES, CALCUL_AVFISC, SAUV_IRANT; P_EST_CALCUL_ACOMPTES = VARTMP1; FLAG_ACO = 0; V_NEGACO = 0; diff --git a/m_ext/2021/cibles.m b/m_ext/2021/cibles.m index 0562620bb..4f7cc1292 100644 --- a/m_ext/2021/cibles.m +++ b/m_ext/2021/cibles.m @@ -259,7 +259,7 @@ si nb_anomalies() = 0 alors cible calcule_acomptes: application: iliad; -variable temporaire: SAUV_ART1731BIS, SAUV_PREM8_11; +variables_temporaires: SAUV_ART1731BIS, SAUV_PREM8_11; FLAG_ACO = 1; V_CALCUL_ACO = 1; calculer cible calcul_prim_corr; @@ -286,7 +286,7 @@ si nb_anomalies() = 0 alors cible calcule_avfiscal: application: iliad; -variable temporaire: EXISTE_AVFISC, SAUV_IAD11, SAUV_INE, SAUV_IRE, SAUV_ART1731BIS, SAUV_PREM8_11; +variables_temporaires: EXISTE_AVFISC, SAUV_IAD11, SAUV_INE, SAUV_IRE, SAUV_ART1731BIS, SAUV_PREM8_11; EXISTE_AVFISC = 0; iterer : variable REV_AV @@ -338,7 +338,7 @@ si CMAJ dans (8, 11) alors cible calcule_acomptes_avfisc: application: iliad; -variable temporaire: NAP_SANS_PENA_REEL, SAUV_ART1731BIS, SAUV_PREM8_11; +variables_temporaires: NAP_SANS_PENA_REEL, SAUV_ART1731BIS, SAUV_PREM8_11; NAP_SANS_PENA_REEL = 0; # toujours 0 ? FLAG_ACO = 1; calculer cible calcule_avfiscal; @@ -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 @@ -404,7 +415,7 @@ ou present(PINELQO_A) cible traite_double_liquidation3: application: iliad; -variable temporaire: P_EST_CALCUL_ACOMPTES, CALCUL_ACOMPTES, CALCUL_AVFISC, SAUV_IRANT; +variables_temporaires: P_EST_CALCUL_ACOMPTES, CALCUL_ACOMPTES, CALCUL_AVFISC, SAUV_IRANT; P_EST_CALCUL_ACOMPTES = VARTMP1; FLAG_ACO = 0; V_NEGACO = 0; @@ -594,85 +605,3 @@ si present(IAD11) alors calculer cible calcul_primitif; calculer cible calcul_primitif_taux; - - - - - - - - - - - - - - - - - - -# debug - -cible toto: -application: iliad; -afficher "toto " "FLAG_PVRO=" (FLAG_PVRO) " tutu" "\n"; -afficher_erreur "toto " nom(FLAG_PVRO) " " alias(FLAG_PVRO) "+27.745=" (FLAG_PVRO + 27.745) " tutu " (indefini) "\n"; -afficher_erreur "toto " "27.745=" (0 + 27.745) : 0 .. 2 " tutu " (3 * indefini) "\n"; - -cible tutu: -application: iliad; -iterer -: variable ITC -: categorie saisie revenu -: avec attribut(ITC, acompte) = 0 -: dans ( - afficher_erreur "tutu0 " nom(ITC) " (" alias(ITC) ") = " (ITC) : 0..2 "\n"; - afficher_erreur "tutu1 attribut(" nom(ITC) ", acompte) = " (attribut(ITC, acompte)) : 0 "\n"; - afficher_erreur "tutu1 attribut(" nom(V_VAR7WZ) ", acompte) = " (attribut(V_VAR7WZ, acompte)) : 0 "\n"; -) - -cible titi: -application : iliad; -variable temporaire: TOTO tableau[3]; -TOTO[0] = 0; -TOTO[1] = 1 + TOTO[0]; -TOTO[2] = 2 + TOTO[1]; -afficher_erreur "titi debut\n"; -afficher_erreur "titi0 TOTO[0] = " (TOTO[0]) " TOTO[1] = " (TOTO[1]) " TOTO[2] = " (TOTO[2]) "\n"; -afficher_erreur "titi0 " nom(FLAG_PVRO) " = " (FLAG_PVRO) "\n"; -iterer -: variable ITC : categorie saisie contexte : avec present(ITC) -: dans ( - afficher_erreur "titi0 " nom(ITC) " = " (ITC) "\n"; -) -afficher_erreur "\n"; -restaurer -: FLAG_PVRO -: TOTO -: variable RESTREV : categorie saisie contexte : avec present(RESTREV) -: apres ( - FLAG_PVRO = indefini; - afficher_erreur "titi1 " nom(FLAG_PVRO) " = " (FLAG_PVRO) "\n"; - TOTO[0] = indefini; - TOTO[1] = indefini; - TOTO[2] = indefini; - afficher_erreur "titi1 TOTO[0] = " (TOTO[0]) " TOTO[1] = " (TOTO[1]) " TOTO[2] = " (TOTO[2]) "\n"; - iterer - : variable ITC : categorie saisie contexte : avec present(ITC) - : dans ( - ITC = indefini; - afficher_erreur "titi1 " nom(ITC) " = " (ITC) "\n"; - ) -) -afficher_erreur "\n"; -afficher_erreur "toiti2 TOTO[0] = " (TOTO[0]) " TOTO[1] = " (TOTO[1]) " TOTO[2] = " (TOTO[2]) "\n"; -afficher_erreur "titi2 " nom(FLAG_PVRO) " = " (FLAG_PVRO) "\n"; -iterer -: variable ITC : categorie saisie contexte : avec present(ITC) -: dans ( - afficher_erreur "titi2 " nom(ITC) " = " (ITC) "\n"; -) -afficher_erreur "titi fin\n\n"; - - diff --git a/m_ext/2022/cibles.m b/m_ext/2022/cibles.m index 4448b011c..0ccfbf801 100644 --- a/m_ext/2022/cibles.m +++ b/m_ext/2022/cibles.m @@ -261,13 +261,13 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte cible trace_in: application: iliad; -variable temporaire: TOTO; +variables_temporaires: TOTO; TOTO = 0; #afficher_erreur indenter(2); cible trace_out: application: iliad; -variable temporaire: TOTO; +variables_temporaires: TOTO; TOTO = 0; #afficher_erreur indenter(-2); @@ -311,7 +311,7 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte cible calcule_acomptes: application: iliad; -variable temporaire: SAUV_ART1731BIS, SAUV_PREM8_11; +variables_temporaires: SAUV_ART1731BIS, SAUV_PREM8_11; #afficher_erreur "calcule_acomptes[\n"; calculer cible trace_in; FLAG_ACO = 1; @@ -346,7 +346,7 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte cible est_code_supp_avfisc: application: iliad; -argument: EXISTE_CODE_SUPP; +arguments: EXISTE_CODE_SUPP; #afficher_erreur "est_code_supp_avfisc[\n"; calculer cible trace_in; EXISTE_CODE_SUPP = 0; @@ -374,7 +374,7 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte cible calcule_avfiscal: application: iliad; -variable temporaire: +variables_temporaires: EXISTE_AVFISC, EXISTE_CODE_SUPP, SAUV_IAD11, SAUV_INE, SAUV_IRE, SAUV_ART1731BIS, SAUV_PREM8_11; #afficher_erreur "calcule_avfiscal[\n"; @@ -440,7 +440,7 @@ si CMAJ dans (8, 11) alors cible calcule_acomptes_avfisc: application: iliad; -variable temporaire: NAP_SANS_PENA_REEL, SAUV_ART1731BIS, SAUV_PREM8_11; +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 ? @@ -463,7 +463,7 @@ si CMAJ dans (8, 11) alors cible est_calcul_acomptes: application: iliad; -argument: EXISTE_ACOMPTES; +arguments: EXISTE_ACOMPTES; #afficher_erreur "est_calcul_acomptes[\n"; calculer cible trace_in; EXISTE_ACOMPTES = 0; @@ -479,7 +479,7 @@ si CMAJ dans (8, 11) alors cible est_calcul_avfisc: application: iliad; -argument: EXISTE_AVFISC; +arguments: EXISTE_AVFISC; #afficher_erreur "est_calcul_avfisc[\n"; calculer cible trace_in; EXISTE_AVFISC = 0; @@ -498,8 +498,8 @@ si CMAJ dans (8, 11) alors cible traite_double_liquidation3: application: iliad; -argument: P_EST_CALCUL_ACOMPTES; -variable temporaire: CALCUL_ACOMPTES, CALCUL_AVFISC, SAUV_IRANT; +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; @@ -567,7 +567,7 @@ si CMAJ dans (8, 11) alors cible abs_flag: application: iliad; -argument: VAR, ABS, FLAG; +arguments: VAR, ABS, FLAG; si present(VAR) alors FLAG = (VAR < 0); ABS = abs(VAR); @@ -576,7 +576,7 @@ si present(VAR) alors cible traite_double_liquidation_exit_taxe: application: iliad; -variable temporaire: CALCULER_ACOMPTES; +variables_temporaires: CALCULER_ACOMPTES; #afficher_erreur "traite_double_liquidation_exit_taxe[\n"; calculer cible trace_in; si present(PVIMPOS) ou present(CODRWB) alors @@ -750,7 +750,7 @@ ou present(MOISAN_ISF) cible enchaine_calcul: application: iliad; -# variable temporaire: CALCULER_ACOMPTES; +# variables_temporaires: CALCULER_ACOMPTES; si V_IND_TRAIT = 4 alors # primitif calculer cible effacer_base_etc; calculer cible traite_double_liquidation_2; @@ -775,7 +775,7 @@ si nb_discordances() + nb_informatives() > 0 alors cible enchainement_primitif: application: iliad; -variable temporaire: EXPORTE_ERREUR; +variables_temporaires: EXPORTE_ERREUR; #afficher_erreur "traite_double_liquidation2[\n"; calculer cible trace_in; calculer cible ir_verif_saisie_isf; diff --git a/m_ext/2023/cibles.m b/m_ext/2023/cibles.m index f1120323b..7c30e660d 100644 --- a/m_ext/2023/cibles.m +++ b/m_ext/2023/cibles.m @@ -261,13 +261,13 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte cible trace_in: application: iliad; -variable temporaire: TOTO; +variables_temporaires: TOTO; TOTO = 0; #afficher_erreur indenter(2); cible trace_out: application: iliad; -variable temporaire: TOTO; +variables_temporaires: TOTO; TOTO = 0; #afficher_erreur indenter(-2); @@ -311,7 +311,7 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte cible calcule_acomptes: application: iliad; -variable temporaire: SAUV_ART1731BIS, SAUV_PREM8_11; +variables_temporaires: SAUV_ART1731BIS, SAUV_PREM8_11; #afficher_erreur "calcule_acomptes[\n"; calculer cible trace_in; FLAG_ACO = 1; @@ -346,7 +346,7 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte cible est_code_supp_avfisc: application: iliad; -argument: EXISTE_CODE_SUPP; +arguments: EXISTE_CODE_SUPP; #afficher_erreur "est_code_supp_avfisc[\n"; calculer cible trace_in; EXISTE_CODE_SUPP = 0; @@ -374,7 +374,7 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte cible calcule_avfiscal: application: iliad; -variable temporaire: +variables_temporaires: EXISTE_AVFISC, EXISTE_CODE_SUPP, SAUV_IAD11, SAUV_INE, SAUV_IRE, SAUV_ART1731BIS, SAUV_PREM8_11; #afficher_erreur "calcule_avfiscal[\n"; @@ -440,7 +440,7 @@ si CMAJ dans (8, 11) alors cible calcule_acomptes_avfisc: application: iliad; -variable temporaire: NAP_SANS_PENA_REEL, SAUV_ART1731BIS, SAUV_PREM8_11; +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 ? @@ -463,7 +463,7 @@ si CMAJ dans (8, 11) alors cible est_calcul_acomptes: application: iliad; -argument: EXISTE_ACOMPTES; +arguments: EXISTE_ACOMPTES; #afficher_erreur "est_calcul_acomptes[\n"; calculer cible trace_in; EXISTE_ACOMPTES = 0; @@ -479,7 +479,7 @@ si CMAJ dans (8, 11) alors cible est_calcul_avfisc: application: iliad; -argument: EXISTE_AVFISC; +arguments: EXISTE_AVFISC; #afficher_erreur "est_calcul_avfisc[\n"; calculer cible trace_in; EXISTE_AVFISC = 0; @@ -498,8 +498,8 @@ si CMAJ dans (8, 11) alors cible traite_double_liquidation3: application: iliad; -argument: P_EST_CALCUL_ACOMPTES; -variable temporaire: CALCUL_ACOMPTES, CALCUL_AVFISC, SAUV_IRANT; +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; @@ -567,7 +567,7 @@ si CMAJ dans (8, 11) alors cible abs_flag: application: iliad; -argument: VAR, ABS, FLAG; +arguments: VAR, ABS, FLAG; si present(VAR) alors FLAG = (VAR < 0); ABS = abs(VAR); @@ -576,7 +576,7 @@ si present(VAR) alors cible traite_double_liquidation_exit_taxe: application: iliad; -variable temporaire: CALCULER_ACOMPTES; +variables_temporaires: CALCULER_ACOMPTES; #afficher_erreur "traite_double_liquidation_exit_taxe[\n"; calculer cible trace_in; si present(PVIMPOS) ou present(CODRWB) alors @@ -750,7 +750,7 @@ ou present(MOISAN_ISF) cible enchaine_calcul: application: iliad; -# variable temporaire: CALCULER_ACOMPTES; +# variables_temporaires: CALCULER_ACOMPTES; si V_IND_TRAIT = 4 alors # primitif calculer cible effacer_base_etc; calculer cible traite_double_liquidation_2; @@ -773,9 +773,282 @@ si nb_discordances() + nb_informatives() > 0 alors exporte_erreurs; finsi +fonction truc: +application: iliad; +arguments: A0, A1; +resultat: RES; +variables_temporaires: 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; +arguments: I0, I1; +variables_temporaires: 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 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(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 + 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 ( + calculer cible afficher_evenement : avec I; + afficher_erreur "\n"; +) + +cible test_evenements: +application: iliad; +variables_temporaires: A0, A1, EVT; +A0 = 1.6; +A1 = 3.6; +calculer cible test_boucle : avec A0, A1; +afficher_erreur "\n"; +afficher_erreur "nb_evenements() = " (nb_evenements()) "\n"; +afficher_erreur "\n"; +calculer cible afficher_evenements; +afficher_erreur "\n"; +si nb_evenements() > 0 alors + afficher_erreur "0: " nom(champ_evenement(0, code)) " = " (champ_evenement(0, code)) "\n"; + champ_evenement(0, code) = 456; + 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"; +sinon + afficher_erreur "!!! AUCUN EVENEMENT !!!\n"; +finsi +afficher_erreur "\n"; +arranger_evenements +: trier I, J : avec + champ_evenement(I, rappel) <= champ_evenement(J, rappel) + ou ( + 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 +: 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"; + 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 "1: "; + 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 "\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"; +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"; + +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" indenter(2); +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 : 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 indenter(-2) "test_tableaux\n\n"; + +cible test_varcons: +application: iliad; +variables_temporaires: TOTO, TUTU, PROUT02; +afficher_erreur "test_varcons\n" indenter(2); +TOTO = 2; +PROUT02 = 2; +si (TOTO dans (PROUT[00: TOTO])) alors + afficher_erreur "dans OK\n"; +sinon + afficher_erreur "dans KO\n"; +finsi +TOTO = 2; +afficher_erreur + nom(PROUT[00: TOTO]) + " = " (PROUT[00: TOTO]) " (" alias(PROUT[00: TOTO]) ")\n"; +iterer : variable TRUC2 : PROUT02 : dans ( + afficher_erreur + "TRUC2: " nom(TRUC[0: TOTO]) + " = " (TRUC[0: TOTO]) " (" alias(TRUC[0: TOTO]) ")\n"; +) +afficher_erreur + "attribut(" nom(ALLO[0: TOTO]) ", priorite) = " + (attribut(ALLO[0: TOTO], priorite)) " (" alias(ALLO[0: TOTO]) ")\n"; +afficher_erreur + "taille(" nom(TMAJORSE[0: TOTO]) ") = " + (taille(TMAJORSE[0: TOTO])) " (" alias(TMAJORSE[0: TOTO]) ")\n"; +PROUT[00: TOTO] = 11; +afficher_erreur nom(PROUT[00: TOTO]) " = " (PROUT[00: TOTO]) "\n"; +STR_TR[00: 3] = 12; +afficher_erreur nom(STR_TR[00: 3]) " = " (STR_TR[00: 3]) "\n"; +TOTO = 22; +STR_TR[00: TOTO] = 13; +afficher_erreur nom(STR_TR[00: TOTO]) " = " (STR_TR[00: TOTO]) "\n"; +TUTU = indefini; +iterer : variable TRUC2 : TUTU : dans ( + TRUC[0: 2] = 14; + afficher_erreur nom(TRUC[0: 2]) " = " (TRUC[0: 2]) "\n"; +) +TUTU = indefini; +TOTO = 2; +iterer : variable TRUC2 : TUTU : dans ( + TRUC[0: TOTO] = 15; + afficher_erreur nom(TRUC[0: TOTO]) " = " (TRUC[0: TOTO]) "\n"; +) +afficher_erreur indenter(-2) "test_varcons\n\n"; + +cible test: +application: iliad; +calculer cible test_evenements; +calculer cible test_tableaux; +calculer cible test_varcons; + cible enchainement_primitif: application: iliad; -variable temporaire: EXPORTE_ERREUR; +variables_temporaires: EXPORTE_ERREUR; #afficher_erreur "traite_double_liquidation2[\n"; calculer cible trace_in; calculer cible ir_verif_saisie_isf; @@ -811,10 +1084,86 @@ puis_quand nb_anomalies() = 0 faire calculer cible trace_out; #afficher_erreur "]traite_double_liquidation2\n"; -# primitif iterpréteur +# correctif + +cible enchainement_correctif: +application: iliad; +neant; + +# iterpréteur 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; +sinon_si V_IND_TRAIT = 5 alors # correctif + calculer cible enchainement_correctif; +finsi +#calculer cible test; + +#{ + +# debug + +cible toto: +application: iliad; +afficher "toto " "FLAG_PVRO=" (FLAG_PVRO) " tutu" "\n"; +afficher_erreur "toto " nom(FLAG_PVRO) " " alias(FLAG_PVRO) "+27.745=" (FLAG_PVRO + 27.745) " tutu " (indefini) "\n"; +afficher_erreur "toto " "27.745=" (0 + 27.745) : 0 .. 2 " tutu " (3 * indefini) "\n"; + +cible tutu: +application: iliad; +iterer +: variable ITC +: categorie saisie revenu +: avec attribut(ITC, acompte) = 0 +: dans ( + afficher_erreur "tutu0 " nom(ITC) " (" alias(ITC) ") = " (ITC) : 0..2 "\n"; + afficher_erreur "tutu1 attribut(" nom(ITC) ", acompte) = " (attribut(ITC, acompte)) : 0 "\n"; + afficher_erreur "tutu1 attribut(" nom(V_VAR7WZ) ", acompte) = " (attribut(V_VAR7WZ, acompte)) : 0 "\n"; +) + +cible titi: +application : iliad; +variables_temporaires: TOTO tableau[3]; +TOTO[0] = 0; +TOTO[1] = 1 + TOTO[0]; +TOTO[2] = 2 + TOTO[1]; +afficher_erreur "titi debut\n"; +afficher_erreur "titi0 TOTO[0] = " (TOTO[0]) " TOTO[1] = " (TOTO[1]) " TOTO[2] = " (TOTO[2]) "\n"; +afficher_erreur "titi0 " nom(FLAG_PVRO) " = " (FLAG_PVRO) "\n"; +iterer +: variable ITC : categorie saisie contexte : avec present(ITC) +: dans ( + afficher_erreur "titi0 " nom(ITC) " = " (ITC) "\n"; +) +afficher_erreur "\n"; +restaurer +: variables FLAG_PVRO, TOTO +: variable RESTREV : categorie saisie contexte : avec present(RESTREV) +: apres ( + FLAG_PVRO = indefini; + afficher_erreur "titi1 " nom(FLAG_PVRO) " = " (FLAG_PVRO) "\n"; + TOTO[0] = indefini; + TOTO[1] = indefini; + TOTO[2] = indefini; + afficher_erreur "titi1 TOTO[0] = " (TOTO[0]) " TOTO[1] = " (TOTO[1]) " TOTO[2] = " (TOTO[2]) "\n"; + iterer + : variable ITC : categorie saisie contexte : avec present(ITC) + : dans ( + ITC = indefini; + afficher_erreur "titi1 " nom(ITC) " = " (ITC) "\n"; + ) +) +afficher_erreur "\n"; +afficher_erreur "toiti2 TOTO[0] = " (TOTO[0]) " TOTO[1] = " (TOTO[1]) " TOTO[2] = " (TOTO[2]) "\n"; +afficher_erreur "titi2 " nom(FLAG_PVRO) " = " (FLAG_PVRO) "\n"; +iterer +: variable ITC : categorie saisie contexte : avec present(ITC) +: dans ( + afficher_erreur "titi2 " nom(ITC) " = " (ITC) "\n"; +) +afficher_erreur "titi fin\n\n"; + +}# 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/functions.mk b/makefiles/functions.mk index 7dcadd6b0..0000ec977 100644 --- a/makefiles/functions.mk +++ b/makefiles/functions.mk @@ -44,7 +44,7 @@ $(if $(call not,$(call is_in,$(1))), \ endef define make_in_raw -@$(MAKE) --no-print-directory -f $(ROOT_DIR)/Makefile -C $(ROOT_DIR)/$(1) ROOT_DIR=$(ROOT_DIR) $(2) +$(MAKE) --no-print-directory -f $(ROOT_DIR)/Makefile -C $(ROOT_DIR)/$(1) ROOT_DIR=$(ROOT_DIR) $(2) endef define check_in diff --git a/makefiles/mlang.mk b/makefiles/mlang.mk index 407fa1dc0..15659e899 100644 --- a/makefiles/mlang.mk +++ b/makefiles/mlang.mk @@ -61,6 +61,9 @@ endif build: FORCE | format dune +build-dev: DUNE_OPTIONS=--profile dev +build-dev: FORCE | format dune + build-ci: DUNE_OPTIONS=--profile ci build-ci: FORCE | dune @@ -78,11 +81,11 @@ build-doc: FORCE | dune ################################################## # use: TEST_FILE=bla make test -test: FORCE build +test: FORCE build-dev ifeq ($(call is_in,),) $(call make_in,,$@) else - $(MLANG_TEST) --run_test=$(TEST_FILE) $(SOURCE_FILES) $(SOURCE_EXT_FILES) + OCAMLRUNPARAM=b $(MLANG_TEST) --run_test=$(TEST_FILE) $(SOURCE_FILES) $(SOURCE_EXT_FILES) endif # use: TESTS_DIR=bla make test @@ -93,19 +96,18 @@ else $(MLANG_TEST) $(MLANGOPTS) --run_all_tests=$(TESTS_DIR)/ $(TEST_FILTER_FLAG) $(SOURCE_FILES) $(SOURCE_EXT_FILES) endif -test_one: FORCE build +test_one: FORCE build-dev ifeq ($(call is_in,),) $(call make_in,,$@) else - $(MLANG_TEST) --run_test=$(TESTS_DIR)/$(TEST_ONE) $(SOURCE_FILES) $(SOURCE_EXT_FILES) + OCAMLRUNPARAM=b $(MLANG_TEST) --run_test=$(TESTS_DIR)/$(TEST_ONE) $(SOURCE_FILES) $(SOURCE_EXT_FILES) endif - -test_file: FORCE build +test_file: FORCE build-dev ifeq ($(call is_in,),) $(call make_in,,$@) else - $(MLANG_TEST) --run_test=$(TEST_FILE) $(SOURCE_FILES) $(SOURCE_EXT_FILES) + OCAMLRUNPARAM=b $(MLANG_TEST) --run_test=$(TEST_FILE) $(SOURCE_FILES) $(SOURCE_EXT_FILES) endif diff --git a/makefiles/variables.mk b/makefiles/variables.mk index 44cb7ccb3..ac7c4a949 100644 --- a/makefiles/variables.mk +++ b/makefiles/variables.mk @@ -17,13 +17,16 @@ 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 else ifeq ($(filter $(YEAR), 2019 2020 2021 2022), $(YEAR)) SOURCE_FILES?=$(call source_dir,$(ROOT_DIR)/ir-calcul/sources$(YEAR)*/) TESTS_DIR?=$(ROOT_DIR)/tests/$(YEAR)/fuzzing +else ifeq ($(filter $(YEAR), 0), $(YEAR)) + SOURCE_FILES?=$(call source_dir,$(ROOT_DIR)/m_ext/$(YEAR)/src/) + TESTS_DIR?=$(ROOT_DIR)/tests/$(YEAR) else $(warning WARNING: there is no default configuration for year: $(YEAR)) $(warning WARNING: example specification files and fuzzer tests are not included for year: $(YEAR)) diff --git a/mlang-deps b/mlang-deps index f7cd952e3..67a897f36 160000 --- a/mlang-deps +++ b/mlang-deps @@ -1 +1 @@ -Subproject commit f7cd952e3200ebac6b413da56c4b84776573df41 +Subproject commit 67a897f36a3962104eaead9d3510b1830b9f2555 diff --git a/src/dune b/src/dune index 0a773a7a3..07489c622 100644 --- a/src/dune +++ b/src/dune @@ -1,7 +1,7 @@ (env (dev (flags - (:standard -warn-error -a))) + (:standard -warn-error -a -g))) ;; fail on warnings in CI mode (ci (flags diff --git a/src/irj_checker/backend_irj/pas_calc.ml b/src/irj_checker/backend_irj/pas_calc.ml index 8561f312a..ecee5db80 100644 --- a/src/irj_checker/backend_irj/pas_calc.ml +++ b/src/irj_checker/backend_irj/pas_calc.ml @@ -1,3 +1,4 @@ +open Mlang open Mlang.Irj_ast type avis_type = Texte | Gavlir @@ -14,7 +15,8 @@ let format_value fmt (value : literal) = | I i -> Format.fprintf fmt "%d" i | F f -> Format.fprintf fmt "%f" f -let format_code_revenu fmt (((var, _), (value, _)) : var_value) = +let format_code_revenu fmt + ((Pos.Mark (var, _), Pos.Mark (value, _)) : var_value) = Format.fprintf fmt {|@;<0 2>{@;<0 4>"code": "%s",@;<0 4>"valeur": "%a"@;<0 2>}|} var format_value value diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index 93e2fc34d..bd4f0de0d 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -48,7 +48,37 @@ let fresh_c_local = incr c; s -let rec generate_c_expr (e : Mir.expression Pos.marked) : +let rec lis_tabaccess (program : Mir.program) v m_idx = + let d_irdata = D.ddirect @@ D.dinstr "irdata" in + let set_vars, idx_def, idx_val = + let e_idx = generate_c_expr program m_idx in + (e_idx.set_vars, e_idx.def_test, e_idx.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 d_fun = + D.dfun "lis_tabaccess" + [ + d_irdata; + D.ddirect @@ D.dinstr @@ Pp.spr "%d" (Com.Var.loc_tab_idx v); + idx_def; + idx_val; + D.ddirect @@ D.dinstr @@ Pp.spr "&%s" res_def; + D.ddirect @@ D.dinstr @@ Pp.spr "&%s" res_val; + ] + 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 } + +and generate_c_expr (program : Mir.program) (e : Mir.expression Pos.marked) : D.expression_composition = let comparison op se1 se2 = let safe_def = false in @@ -75,7 +105,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 +117,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 @@ -102,7 +134,7 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : in match Pos.unmark e with | Com.TestInSet (positive, e0, values) -> - let se0 = generate_c_expr e0 in + let se0 = generate_c_expr program e0 in let ldef, lval = D.locals_from_m () in let sle0 = { @@ -119,14 +151,85 @@ 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 - let def_test = D.m_var v None Def in - let value_comp = D.m_var v None Val in + | Com.VarValue (Pos.Mark (VarAccess v, _)) -> + let s_v = + let def_test = + D.m_var program.program_var_space_def v Def + in + let value_comp = + D.m_var program.program_var_space_def v Val + in D.{ set_vars = []; def_test; value_comp } in - comparison (Com.Eq, Pos.no_pos) sle0 s_set_var + comparison (Pos.without Com.Eq) sle0 s_v + | Com.VarValue (Pos.Mark (TabAccess (v, m_i), _)) -> + let s_v = lis_tabaccess program v m_i in + comparison (Pos.without Com.Eq) sle0 s_v + | Com.VarValue (Pos.Mark (ConcAccess (m_vn, m_if, i), _)) -> + 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 name = Com.get_normal_var (Pos.unmark m_vn) in + let set_vars, def_i, val_i = + let ei = generate_c_expr program i in + (ei.set_vars, ei.def_test, ei.value_comp) + in + let d_fun = + D.dfun "lis_concaccess" + [ + D.ddirect (D.dinstr "irdata"); + D.ddirect (D.dinstr (Pp.spr "\"%s\"" name)); + D.ddirect (D.dinstr (Pp.spr "\"%s\"" (Pos.unmark m_if))); + def_i; + val_i; + 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 + let s_f = D.{ set_vars; def_test; value_comp } in + comparison (Pos.without Com.Eq) sle0 s_f + | Com.VarValue (Pos.Mark (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 program 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 (Pos.without Com.Eq) sle0 s_f | Com.FloatValue i -> let s_i = { @@ -135,8 +238,8 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : D.value_comp = D.lit (Pos.unmark i); } in - comparison (Com.Eq, Pos.no_pos) sle0 s_i - | Com.Interval (bn, en) -> + comparison (Pos.without Com.Eq) sle0 s_i + | 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' } @@ -145,63 +248,36 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : let en' = float_of_int (Pos.unmark en) in D.{ set_vars = []; def_test = dtrue; value_comp = lit en' } in - binop (Com.And, Pos.no_pos) - (comparison (Com.Gte, Pos.no_pos) sle0 s_bn) - (comparison (Com.Lte, Pos.no_pos) sle0 s_en) + binop (Pos.without Com.And) + (comparison (Pos.without Com.Gte) sle0 s_bn) + (comparison (Pos.without Com.Lte) sle0 s_en) in - binop (Com.Or, Pos.no_pos) or_chain equal_test) + binop (Pos.without Com.Or) or_chain equal_test) D.{ set_vars = []; def_test = dfalse; value_comp = lit 0. } values in let se = if positive then or_chain else unop Com.Not or_chain in { - D.set_vars = se0.set_vars; + D.set_vars = se0.set_vars @ se.set_vars; D.def_test = declare_local se.def_test; D.value_comp = declare_local se.value_comp; } | Comparison (op, e1, e2) -> - let se1 = generate_c_expr e1 in - let se2 = generate_c_expr e2 in + let se1 = generate_c_expr program e1 in + let se2 = generate_c_expr program e2 in comparison op se1 se2 | Binop (op, e1, e2) -> - let se1 = generate_c_expr e1 in - let se2 = generate_c_expr e2 in + let se1 = generate_c_expr program e1 in + let se2 = generate_c_expr program e2 in binop op se1 se2 - | 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 } + | Unop (op, e) -> unop op @@ generate_c_expr program e | Conditional (c, t, f_opt) -> - let cond = generate_c_expr c in - let thenval = generate_c_expr t in + let cond = generate_c_expr program c in + let thenval = generate_c_expr program t in let elseval = match f_opt with | None -> D.{ set_vars = []; def_test = dfalse; value_comp = lit 0. } - | Some f -> generate_c_expr f + | Some f -> generate_c_expr program f in let set_vars = cond.D.set_vars @ thenval.D.set_vars @ elseval.D.set_vars @@ -214,22 +290,22 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : D.ite cond.value_comp thenval.value_comp elseval.value_comp in D.build_transitive_composition { set_vars; def_test; value_comp } - | FuncCall ((Supzero, _), [ arg ]) -> - let se = generate_c_expr arg in + | FuncCall (Pos.Mark (Supzero, _), [ arg ]) -> + let se = generate_c_expr program arg in let set_vars = se.D.set_vars in let cond = D.dand se.def_test (D.comp ">=" se.value_comp (D.lit 0.0)) in let def_test = D.ite cond D.dfalse se.def_test in let value_comp = D.ite cond (D.lit 0.0) se.value_comp in D.build_transitive_composition { set_vars; def_test; value_comp } - | FuncCall ((PresentFunc, _), [ arg ]) -> - let se = generate_c_expr arg in + | FuncCall (Pos.Mark (PresentFunc, _), [ arg ]) -> + let se = generate_c_expr program arg in let set_vars = se.D.set_vars in let def_test = D.dtrue in let value_comp = se.def_test in D.build_transitive_composition ~safe_def:true { set_vars; def_test; value_comp } - | FuncCall ((NullFunc, _), [ arg ]) -> - let se = generate_c_expr arg in + | FuncCall (Pos.Mark (NullFunc, _), [ arg ]) -> + let se = generate_c_expr program arg in let set_vars = se.D.set_vars in let def_test = se.def_test in let value_comp = @@ -237,8 +313,8 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : in D.build_transitive_composition ~safe_def:true { set_vars; def_test; value_comp } - | FuncCall ((ArrFunc, _), [ arg ]) -> - let se = generate_c_expr arg in + | FuncCall (Pos.Mark (ArrFunc, _), [ arg ]) -> + let se = generate_c_expr program arg in let set_vars = se.D.set_vars in let def_test = se.def_test in let value_comp = D.dfun "my_arr" [ se.value_comp ] in @@ -247,58 +323,136 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) : `safe_def` to false *) D.build_transitive_composition ~safe_def:true { set_vars; def_test; value_comp } - | FuncCall ((InfFunc, _), [ arg ]) -> - let se = generate_c_expr arg in + | FuncCall (Pos.Mark (InfFunc, _), [ arg ]) -> + let se = generate_c_expr program arg in let set_vars = se.D.set_vars in let def_test = se.def_test in let value_comp = D.dfun "my_floor" [ se.value_comp ] in (* same as above *) D.build_transitive_composition ~safe_def:true { set_vars; def_test; value_comp } - | FuncCall ((AbsFunc, _), [ arg ]) -> - let se = generate_c_expr arg in + | FuncCall (Pos.Mark (AbsFunc, _), [ arg ]) -> + let se = generate_c_expr program arg in let set_vars = se.D.set_vars in let def_test = se.def_test in let value_comp = D.dfun "fabs" [ se.value_comp ] in D.build_transitive_composition ~safe_def:true { set_vars; def_test; value_comp } - | FuncCall ((MaxFunc, _), [ e1; e2 ]) -> - let se1 = generate_c_expr e1 in - let se2 = generate_c_expr e2 in + | FuncCall (Pos.Mark (MaxFunc, _), [ e1; e2 ]) -> + let se1 = generate_c_expr program e1 in + let se2 = generate_c_expr program e2 in let set_vars = se1.D.set_vars @ se2.D.set_vars in let def_test = D.dor se1.def_test se2.def_test in let value_comp = D.dfun "max" [ se1.value_comp; se2.value_comp ] in D.build_transitive_composition ~safe_def:true { set_vars; def_test; value_comp } - | FuncCall ((MinFunc, _), [ e1; e2 ]) -> - let se1 = generate_c_expr e1 in - let se2 = generate_c_expr e2 in + | FuncCall (Pos.Mark (MinFunc, _), [ e1; e2 ]) -> + let se1 = generate_c_expr program e1 in + let se2 = generate_c_expr program e2 in let set_vars = se1.D.set_vars @ se2.D.set_vars in let def_test = D.dor se1.def_test se2.def_test in 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, _) ]) -> - 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 ((Func fn, _), args) -> + | FuncCall (Pos.Mark (Multimax, _), [ e1; Pos.Mark (Var m_acc, _) ]) -> ( + match m_acc with + | VarAccess v -> + let ptr = VID.gen_info_ptr v in + let d_irdata = D.ddirect (D.dinstr "irdata") in + let set_vars, bound_def, bound_val = + let bound = generate_c_expr program e1 in + (bound.set_vars, bound.def_test, bound.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 "multimax_varinfo" + [ + d_irdata; + D.ddirect @@ D.dinstr ptr; + 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 } + | ConcAccess (m_vn, m_if, i) -> + let d_irdata = D.ddirect (D.dinstr "irdata") in + let name = Com.get_normal_var (Pos.unmark m_vn) in + let set_vars, bound_def, bound_val = + let bound = generate_c_expr program e1 in + (bound.set_vars, bound.def_test, bound.value_comp) + in + let set_vars, conc_d_fun = + let ei = generate_c_expr program i in + let conc_fn = Pp.spr "lis_concaccess_varinfo" in + let conc_d_fun = + D.dfun conc_fn + [ + d_irdata; + D.ddirect @@ D.dinstr @@ Pp.spr "\"%s\"" name; + D.ddirect @@ D.dinstr @@ Pp.spr "\"%s\"" @@ Pos.unmark m_if; + ei.def_test; + ei.value_comp; + ] + in + (set_vars @ ei.set_vars, conc_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 "multimax_varinfo" + [ + d_irdata; + D.ddirect conc_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 } + | TabAccess _ | FieldAccess _ -> assert false) + | FuncCall (Pos.Mark (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 (Pos.Mark (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) | a :: la -> - let e = generate_c_expr a in + let e = generate_c_expr program a in let set_vars = List.rev e.set_vars @ set_vars in let arg_exprs = e.value_comp :: e.def_test :: arg_exprs in aux (set_vars, arg_exprs) la @@ -308,46 +462,359 @@ 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) -> { 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 -> - { - 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) + | Var (VarAccess var) -> + let def_test = D.m_var program.program_var_space_def var Def in + let value_comp = D.m_var program.program_var_space_def var Val in + { set_vars = []; def_test; value_comp } + | Var (TabAccess (v, m_idx)) -> lis_tabaccess program v m_idx + | Var (ConcAccess (m_vn, m_if, i)) -> + let d_irdata = D.ddirect (D.dinstr "irdata") in + let set_vars, i_def, i_val = + let ei = generate_c_expr program i in + (ei.set_vars, ei.def_test, ei.value_comp) in - let value_comp = - D.dinstr - (Format.sprintf "attribut_%s((T_varinfo *)%s)" (Pos.unmark a) ptr) + 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 name = Com.get_normal_var (Pos.unmark m_vn) in + let d_fun = + D.dfun "lis_concaccess" + [ + d_irdata; + D.ddirect (D.dinstr (Pp.spr "\"%s\"" name)); + D.ddirect (D.dinstr (Pp.spr "\"%s\"" (Pos.unmark m_if))); + i_def; + i_val; + D.ddirect (D.dinstr res_def_ptr); + D.ddirect (D.dinstr res_val_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 } + 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 } + | Var (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 program 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 + 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 | TabAccess (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 } + | ConcAccess (m_vn, m_if, i) -> + let d_irdata = D.ddirect (D.dinstr "irdata") in + let name = Com.get_normal_var (Pos.unmark m_vn) in + let set_vars, conc_d_fun = + let ei = generate_c_expr program i in + let conc_fn = Pp.spr "lis_concaccess_varinfo" in + let conc_d_fun = + D.dfun conc_fn + [ + d_irdata; + D.ddirect (D.dinstr (Pp.spr "\"%s\"" name)); + D.ddirect (D.dinstr (Pp.spr "\"%s\"" (Pos.unmark m_if))); + ei.def_test; + ei.value_comp; + ] + in + (ei.set_vars, conc_d_fun) + in + let def_test = + D.dfun (Pp.spr "attribut_%s_def" attr) [ D.ddirect conc_d_fun ] + in + let value_comp = + D.dfun (Pp.spr "attribut_%s" attr) [ D.ddirect conc_d_fun ] + 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 program 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 } + | TabAccess _ -> + let def_test = D.dinstr "1.0" in + let value_comp = D.dinstr "1.0" in + D.build_transitive_composition { set_vars = []; def_test; value_comp } + | ConcAccess (m_vn, m_if, i) -> + let d_irdata = D.ddirect (D.dinstr "irdata") in + let name = Com.get_normal_var (Pos.unmark m_vn) in + let set_vars, conc_d_fun = + let ei = generate_c_expr program i in + let conc_fn = Pp.spr "lis_concaccess_varinfo" in + let conc_d_fun = + D.dfun conc_fn + [ + d_irdata; + D.ddirect (D.dinstr (Pp.spr "\"%s\"" name)); + D.ddirect (D.dinstr (Pp.spr "\"%s\"" (Pos.unmark m_if))); + ei.def_test; + ei.value_comp; + ] + in + (ei.set_vars, conc_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 "size_varinfo" + [ + D.ddirect conc_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 } + | FieldAccess (ie, f, _) -> + let d_irdata = D.ddirect (D.dinstr "irdata") in + let set_vars, evt_d_fun = + let e = generate_c_expr program 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 }) + | IsVariable (m_acc, m_name) -> ( + match Pos.unmark m_acc with + | VarAccess v -> + let ptr = VID.gen_info_ptr v in + let nameCmp = Pos.unmark m_name 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 "est_variable" + [ + D.ddirect @@ D.dinstr ptr; + D.ddirect @@ D.dinstr @@ Pp.spr "\"%s\"" nameCmp; + D.ddirect @@ D.dinstr res_def_ptr; + D.ddirect @@ D.dinstr res_val_ptr; + ] + in + let 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 } + | TabAccess (v, m_i) -> + let d_irdata = D.ddirect (D.dinstr "irdata") in + let nameCmp = Pos.unmark m_name 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 set_vars, d_fun = + let ei = generate_c_expr program m_i in + let d_fun = + D.dfun "est_variable_tabaccess" + [ + d_irdata; + D.ddirect @@ D.dinstr @@ Pp.spr "%d" (Com.Var.loc_tab_idx v); + ei.def_test; + ei.value_comp; + D.ddirect @@ D.dinstr @@ Pp.spr "\"%s\"" nameCmp; + D.ddirect @@ D.dinstr res_def_ptr; + D.ddirect @@ D.dinstr res_val_ptr; + ] + in + (ei.set_vars, d_fun) + 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 } + | ConcAccess (m_vn, m_if, m_i) -> + let d_irdata = D.ddirect (D.dinstr "irdata") in + let name = Com.get_normal_var (Pos.unmark m_vn) in + let nameCmp = Pos.unmark m_name 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 set_vars, d_fun = + let ei = generate_c_expr program m_i in + let d_fun = + D.dfun "est_variable_concaccess" + [ + d_irdata; + D.ddirect @@ D.dinstr @@ Pp.spr "\"%s\"" name; + D.ddirect @@ D.dinstr @@ Pp.spr "\"%s\"" (Pos.unmark m_if); + ei.def_test; + ei.value_comp; + D.ddirect @@ D.dinstr @@ Pp.spr "\"%s\"" nameCmp; + D.ddirect @@ D.dinstr res_def_ptr; + D.ddirect @@ D.dinstr res_val_ptr; + ] + in + (ei.set_vars, d_fun) + 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 (ie, f, _) -> + let d_irdata = D.ddirect (D.dinstr "irdata") in + let set_vars, evt_d_fun = + let e = generate_c_expr program 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 nameCmp = Pos.unmark m_name 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 "est_variable" + [ + D.ddirect evt_d_fun; + D.ddirect @@ D.dinstr @@ Pp.spr "\"%s\"" nameCmp; + 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 @@ -364,342 +831,664 @@ 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) - : unit = +let generate_expr_with_res_in program 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 program 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 (program : Mir.program) + (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t) + (oc : Format.formatter) (expr : Mir.expression Pos.marked) : unit = + let var_def = + D.generate_variable ~def_flag:true program.program_var_space_def var + in + let var_val = D.generate_variable program.program_var_space_def var in + generate_expr_with_res_in program 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 - 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 "@;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 "@]@;}"; - pr "@]@;}@;") - else generate_m_assign dgfip_flags var None fmt se - | 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 "@]@;}@;" +let generate_var_def (program : Mir.program) (dgfip_flags : Dgfip_options.flags) + (var : Com.Var.t) (vexpr : Mir.expression Pos.marked) + (oc : Format.formatter) : unit = + generate_m_assign program dgfip_flags var oc vexpr + +let generate_var_def_tab (program : Mir.program) + (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t) + (vidx : Mir.m_expression) (vexpr : Mir.m_expression) (oc : Format.formatter) + : unit = + let pr form = Format.fprintf oc form in + pr "@;@[{"; + let idx_tab = Com.Var.loc_tab_idx var in + pr "@;T_varinfo *info = tab_varinfo[%d];" idx_tab; + 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 program dgfip_flags oc idx_def idx_val vidx; + pr "@;%s = (int)%s;" idx idx_val; + pr "@;@[if (%s && 0 <= %s && %s < info->size) {" 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 program dgfip_flags oc res_def res_val vexpr; + pr "@;ecris_tabaccess(irdata, %d, %s, %s, %s, %s);" idx_tab idx_def idx_val + res_def res_val; + pr "@]@;}"; + pr "@]@;}" + +let generate_conc_def (program : Mir.program) + (dgfip_flags : Dgfip_options.flags) (m_vn : Com.m_var_name) + (m_if : string Pos.marked) (idx_expr : Mir.m_expression) + (expr : Mir.m_expression) (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;" idx_def idx_val; + 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 program dgfip_flags oc idx_def idx_val idx_expr; + generate_expr_with_res_in program dgfip_flags oc res_def res_val expr; + let name = Com.get_normal_var (Pos.unmark m_vn) in + pr "@;ecris_concaccess(irdata, \"%s\", \"%s\", %s, %s, %s, %s);" name + (Pos.unmark m_if) idx_def idx_val res_def res_val; + pr "@]@;}" + +let generate_event_field_def (program : Mir.program) + (dgfip_flags : Dgfip_options.flags) (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 "@;@[{"; + 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 program 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 program dgfip_flags oc res_def res_val expr; + if (StrMap.find field program.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 program 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); + pr "@]@;}"; + pr "@]@;}" + +let generate_event_field_ref (program : Mir.program) + (dgfip_flags : Dgfip_options.flags) (idx_expr : Mir.expression Pos.marked) + (field : string) (var : Com.Var.t) (oc : Format.formatter) : unit = + if (StrMap.find field program.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_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 program 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 (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 - | 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 "@]@,}@;" + | Affectation (Pos.Mark (SingleFormula (VarDecl (m_acc, expr)), _)) -> ( + match Pos.unmark m_acc with + | VarAccess v -> generate_var_def program dgfip_flags v expr oc + | TabAccess (v, m_idx) -> + generate_var_def_tab program dgfip_flags v m_idx expr oc + | ConcAccess (m_vn, m_if, i) -> + generate_conc_def program dgfip_flags m_vn m_if i expr oc + | FieldAccess (i, f, _) -> + let fn = Pos.unmark f in + generate_event_field_def program dgfip_flags i fn None expr oc) + | Affectation (Pos.Mark (SingleFormula (EventFieldRef (idx, f, _, var)), _)) + -> + generate_event_field_ref program dgfip_flags idx (Pos.unmark f) var oc + | Affectation (Pos.Mark (MultipleFormulaes _, _)) -> assert false + | 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 program 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 program 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 - Format.fprintf oc "@[{@,char %s;@;double %s;@;" print_def print_val; + 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; 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) - | PrintName (var, _) -> - let ptr = VID.gen_info_ptr var in - Format.fprintf oc "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\");" print_std pr_ctx + (str_escape s) + | PrintAccess (info, m_a) -> ( + match Pos.unmark m_a with + | VarAccess v -> + let ptr = VID.gen_info_ptr v in + let fld = + match info with Com.Name -> "name" | Com.Alias -> "alias" + in + pr "@;print_string(%s, %s, %s->%s);" print_std pr_ctx ptr fld + | TabAccess (v, m_idx) -> + pr "@;@[{"; + pr "T_varinfo *info;"; + let idx_tab = Com.Var.loc_tab_idx v in + generate_expr_with_res_in program dgfip_flags oc print_def + print_val m_idx; + pr "info = lis_tabaccess_varinfo(irdata, %d, %s, %s);" idx_tab + print_def print_val; + let fld = + match info with Com.Name -> "name" | Com.Alias -> "alias" + in + pr "@;print_string(%s, %s, (info == NULL ? \"\" : info->%s));" + print_std pr_ctx fld; + pr "@]@;}" + | ConcAccess (m_vn, m_if, i) -> + let fld = + match info with Com.Name -> "name" | Com.Alias -> "alias" + in + let name = Com.get_normal_var (Pos.unmark m_vn) in + generate_expr_with_res_in program dgfip_flags oc print_def + print_val i; + pr "@;%s = (int)%s;" print print_val; + pr "@;@[{"; + pr + "@;\ + T_varinfo *info = lis_concaccess_varinfo(irdata, \"%s\", \ + \"%s\", %s, %s);" + name (Pos.unmark m_if) print_def print_val; + pr "@;@[if (info != NULL) {"; + pr "@;print_string(%s, %s, info->%s);" print_std pr_ctx fld; + pr "@]@;}"; + pr "@]@;}" + | FieldAccess (e, f, _) -> + let fld = + match info with Com.Name -> "name" | Com.Alias -> "alias" + in + let ef = + StrMap.find (Pos.unmark f) program.program_event_fields + in + if ef.is_var then ( + generate_expr_with_res_in program 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) fld; + pr "@]@;}")) | 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 program 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 program 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 "@]@;}@;" - | ComputeTarget ((tn, _), targs) -> - let pr fmt = Format.fprintf oc fmt in + pr "@]@;}" + | ComputeTarget (Pos.Mark (tn, _), targs) -> ignore (List.fold_left - (fun n ((v : Com.Var.t), _) -> + (fun n (v : Com.Var.t) -> let ref_idx = Format.sprintf "irdata->ref_org + %d" n in + let ref_name = Format.sprintf "irdata->ref_name[%s]" ref_idx in + pr "@;%s = \"%s\";" ref_name (Com.Var.name_str v); 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; + let v_def_p = VID.gen_def_ptr program.program_var_space_def v in + 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; + let v_val_p = VID.gen_val_ptr program.program_var_space_def v in + pr "@;%s = %s;" ref_val v_val_p; n + 1) 0 targs); - Format.fprintf oc "%s(irdata);" tn - | Iterate (m_var, vars, var_params, stmts) -> - let pr fmt = Format.fprintf oc fmt in + pr "@;%s(irdata);" tn + | Iterate (var, vars, var_params, stmts) -> let it_name = fresh_c_local "iterate" in - let var = Pos.unmark m_var in + let ref_name = VID.gen_ref_name_ptr var in 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 ref_def = VID.gen_def_ptr program.program_var_space_def var in + let ref_val = VID.gen_val_ptr program.program_var_space_def var in + pr "@;%s = \"%s\";" ref_name (Com.Var.name_str var); 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 "@]@;}@;") + (fun v -> + pr "@;@[{"; + pr "@;%s = %s;" ref_info (VID.gen_info_ptr v); + pr "@;%s = %s;" ref_def + (VID.gen_def_ptr program.program_var_space_def v); + pr "@;%s = %s;" ref_val + (VID.gen_val_ptr program.program_var_space_def v); + pr "%a" (generate_stmts dgfip_flags program) stmts; + pr "@]@;}") vars; List.iter (fun (vcs, expr) -> Com.CatVar.Map.iter (fun vc _ -> let vcd = Com.CatVar.Map.find vc program.program_var_categories in + let ref_sp = Pos.unmark program.program_var_space_def.vs_name 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 "@;@[if (%s->tab_idx < 0) {" ref_info; + pr "@;%s = &(D%s(%s,%s->idx));" ref_def ref_tab ref_sp ref_info; + pr "@;%s = &(%s(%s,%s->idx));" ref_val ref_tab ref_sp ref_info; + generate_expr_with_res_in program 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 "@]@;}@;") + pr "@;tab_%s++;" it_name; + pr "@;nb_%s++;" it_name; + pr "@]@;}"; + pr "@]@;}") vcs) var_params - | Restore (vars, var_params, stmts) -> - let pr fmt = Format.fprintf oc fmt in - pr "@[{@;"; + | Iterate_values (var, var_intervals, stmts) -> + let itval_def = VID.gen_def program.program_var_space_def var in + let itval_val = VID.gen_val program.program_var_space_def var 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 "@;@[{"; + 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 program dgfip_flags oc e0_def e0_val e0; + generate_expr_with_res_in program dgfip_flags oc e1_def e1_val e1; + generate_expr_with_res_in program 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 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, 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 + 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; + (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 program 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 (var, expr) -> + pr "@;@[while(%s < %s) {" cpt_j nb_events_sav; + let ref_def = VID.gen_def program.program_var_space_def var in + let ref_val = VID.gen_val program.program_var_space_def var in + 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; + generate_expr_with_res_in program 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 "@]@;}"; + pr "@;%s++;" cpt_j; + pr "@]@;}"; + pr "@;irdata->events = %s;" events_tmp; + pr "@;irdata->nb_events = %s;" cpt_i + | None -> + 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); + (match sort with + | Some (var0, var1, expr) -> + pr "@;/* merge sort */"; + pr "@;@[{"; + pr "@;int aBeg = %s;" nb_add; + pr "@;int aEnd = irdata->nb_events;"; + 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 < aEnd;@ width = 2 * \ + width) {@]"; + pr + "@;\ + @[@[for (iLeft = aBeg;@ iLeft < aEnd;@ iLeft = iLeft \ + + 2 * width) {@]"; + pr "@;int iRight = iLeft + width;"; + pr "@;int iEnd = iLeft + 2 * width;"; + pr "@;if (iRight > aEnd) iRight = aEnd;"; + pr "@;if (iEnd > aEnd) iEnd = aEnd;"; + 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 ref0_def = VID.gen_def program.program_var_space_def var0 in + let ref0_val = VID.gen_val program.program_var_space_def var0 in + let ref1_def = VID.gen_def program.program_var_space_def var1 in + let ref1_val = VID.gen_val program.program_var_space_def var1 in + let cmp_def = fresh_c_local "cmp_def" in + let cmp_val = fresh_c_local "cmp_val" in + 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; + generate_expr_with_res_in program 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)) {"; + 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 = aBeg;@ i < aEnd;@ 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);"; + pr "@;irdata->events = %s;" events_sav; + pr "@;irdata->nb_events = %s;" nb_events_sav; + pr "@]@;}" + | Restore (vars, var_params, evts, evtfs, 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) - (VID.gen_val_ptr v) (VID.gen_size v)) + (fun v -> + pr "@;env_sauvegarder(&%s, %s, %s, %s);" rest_name + (VID.gen_def_ptr program.program_var_space_def v) + (VID.gen_val_ptr program.program_var_space_def v) + (VID.gen_size v)) vars; List.iter - (fun (m_var, vcs, expr) -> - let var = Pos.unmark m_var in + (fun (var, vcs, expr) -> let it_name = fresh_c_local "iterate" in Com.CatVar.Map.iter (fun vc _ -> let vcd = Com.CatVar.Map.find vc program.program_var_categories in + let ref_sp = Pos.unmark program.program_var_space_def.vs_name in let ref_tab = VID.gen_tab vcd.loc in + let ref_name = VID.gen_ref_name_ptr var in 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 ref_def = VID.gen_def_ptr program.program_var_space_def var in + let ref_val = VID.gen_val_ptr program.program_var_space_def var in + 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 - (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 "@;int nb_%s = 0;" it_name; + pr "@;%s = \"%s\";" ref_name (Com.Var.name_str var); + 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,%s->idx));" ref_def ref_tab ref_sp ref_info; + pr "@;%s = &(%s(%s,%s->idx));" ref_val ref_tab ref_sp ref_info; + generate_expr_with_res_in program 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 program.program_var_space_def var) + (VID.gen_val_ptr program.program_var_space_def var) + (VID.gen_size var); 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 program 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; + List.iter + (fun (var, expr) -> + let idx = fresh_c_local "idx" in + let ref_def = VID.gen_def program.program_var_space_def var in + let ref_val = VID.gen_val program.program_var_space_def 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 program 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; + pr "@]@;}" | RaiseError (m_err, var_opt) -> let err = Pos.unmark m_err in let err_name = Pos.unmark err.Com.Error.name in @@ -708,84 +1497,111 @@ 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 "@]" + List.iter (generate_stmt dgfip_flags program oc) stmts -let generate_var_tmp_decls (oc : Format.formatter) (tf : Mir.target_data) = +let generate_function_tmp_decls (oc : Format.formatter) (tf : Mir.target) = let pr fmt = Format.fprintf oc fmt in + let nb_args = List.length tf.target_args in + pr "@;@[{"; + pr "@;int i;"; + pr "@;T_varinfo *info;"; + pr "@;irdata->def_tmps[irdata->tmps_org] = 0;"; + pr "@;irdata->tmps[irdata->tmps_org] = 0.0;"; + pr "@;irdata->info_tmps[irdata->tmps_org] = NULL;"; + List.iteri + (fun i var -> + let idx = Pp.spr "irdata->tmps_org + %d" (i + 1) in + pr "@;irdata->def_tmps[%s] = arg_def%d;" idx i; + pr "@;irdata->tmps[%s] = arg_val%d;" idx i; + let loc_cat_idx = Com.Var.loc_cat_idx var in + let name = Com.Var.name_str var in + pr "@;irdata->info_tmps[%s] = &(tmp_varinfo[%d]); /* %s */" idx + loc_cat_idx name) + tf.target_args; + let vres = Option.get tf.target_result in + let loc_cat_idx_vres = Com.Var.loc_cat_idx vres in + let name_vres = Com.Var.name_str vres in + pr "@;irdata->def_tmps[irdata->tmps_org] = 0;"; + pr "@;irdata->tmps[irdata->tmps_org] = 0.0;"; + pr "@;irdata->info_tmps[irdata->tmps_org] = &(tmp_varinfo[%d]); /* %s */" + loc_cat_idx_vres name_vres; if tf.target_sz_tmps > 0 then ( - pr "@[{"; - pr "@;int i;"; - pr "@;T_varinfo *info;"; - pr "@;@[for (i = 0; i < %d; i++) {" tf.target_sz_tmps; + pr "@;@[@[for (i = %d;@ i < %d;@ i++) {@]" (1 + nb_args) + tf.target_sz_tmps; pr "@;irdata->def_tmps[irdata->tmps_org + i] = 0;"; pr "@;irdata->tmps[irdata->tmps_org + i] = 0.0;"; + pr "@;irdata->info_tmps[irdata->tmps_org + i] = NULL;"; pr "@]@;}"; pr "@;irdata->tmps_org = irdata->tmps_org + %d;" tf.target_sz_tmps; StrMap.iter - (fun vn (var, _, sz_opt) -> - let loc_str = - Format.sprintf "irdata->tmps_org + (%d)" (Com.Var.loc_int var) - in - pr "@;info = &(irdata->info_tmps[%s]);" loc_str; - pr "@;info->name = \"%s\";" vn; - pr "@;info->alias = \"\";"; - pr "@;info->idx = %s;" loc_str; - (match sz_opt with - | None -> pr "@;info->size = 1;" - | Some i -> pr "@;info->size = %d;" i); - pr "@;info->cat = ID_TMP_VARS;"; - pr "@;info->loc_cat = EST_TEMPORAIRE;") - tf.target_tmp_vars; - pr "@]@;}"); + (fun vn var -> + let loc_str = Pp.spr "irdata->tmps_org + (%d)" (Com.Var.loc_idx var) in + let loc_cat_idx = Com.Var.loc_cat_idx var in + pr "@;irdata->info_tmps[%s] = &(tmp_varinfo[%d]); /* %s */" loc_str + loc_cat_idx vn) + 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) = + (fd : Mir.target) = 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 - fd.Mir.target_args + "int %s(T_irdata* irdata, char *res_def, double *res_val%a)%s" fn pp_args + fd.target_args (if add_semicolon then ";" else "") 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; + let fd = StrMap.find fn program.program_functions in + pr "@.@[%a {" (generate_function_prototype false) fd; + let sav = fresh_c_local "sav" in + let sav_nb_tmps = Pp.spr "%s_nb_tmps_target" sav in + let sav_nb_refs = Pp.spr "%s_nb_refs_target" sav in + pr "@;int %s = irdata->nb_tmps_target;" sav_nb_tmps; + pr "@;int %s = irdata->nb_refs_target;" sav_nb_refs; + pr "%a" generate_function_tmp_decls fd; + pr "@;irdata->nb_tmps_target = %d;" + (StrMap.fold (fun _ v n -> n + Com.Var.size v) fd.target_tmp_vars 0); + pr "@;irdata->nb_refs_target = %d;" fd.target_nb_refs; + 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 "@;irdata->nb_refs_target = %s;" sav_nb_refs; + pr "@;irdata->nb_tmps_target = %s;" sav_nb_tmps; + pr "@;*res_def = irdata->def_tmps[irdata->tmps_org];"; + pr "@;*res_val = irdata->tmps[irdata->tmps_org];"; + pr "@;return 1;"; + pr "@]@;}@." let generate_functions (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (filemap : (out_channel * Format.formatter) StrMap.t) = - let functions = Com.TargetMap.bindings program.program_functions in + let functions = StrMap.bindings program.program_functions in List.iter - (fun (name, Mir.{ target_file; _ }) -> + (fun (name, ({ target_file; _ } : Mir.target)) -> let file_str = match target_file with Some s -> s | None -> "" in let _, fmt = StrMap.find file_str filemap in generate_function (dgfip_flags : Dgfip_options.flags) program fmt name) @@ -796,27 +1612,62 @@ let generate_target_prototype (add_semicolon : bool) (oc : Format.formatter) Format.fprintf oc "struct S_discord * %s(T_irdata* irdata)%s" function_name (if add_semicolon then ";" else "") +let generate_cible_tmp_decls (oc : Format.formatter) (tf : Mir.target) = + let pr fmt = Format.fprintf oc fmt in + if tf.target_sz_tmps > 0 then ( + pr "@;@[{"; + pr "@;int i;"; + pr "@;T_varinfo *info;"; + 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 "@;irdata->info_tmps[irdata->tmps_org + i] = NULL;"; + pr "@]@;}"; + pr "@;irdata->tmps_org = irdata->tmps_org + %d;" tf.target_sz_tmps; + StrMap.iter + (fun vn var -> + let loc_str = Pp.spr "irdata->tmps_org + (%d)" (Com.Var.loc_idx var) in + let loc_cat_idx = Com.Var.loc_cat_idx var in + pr "@;irdata->info_tmps[%s] = &(tmp_varinfo[%d]); /* %s */" loc_str + loc_cat_idx vn) + tf.target_tmp_vars; + pr "@]@;}"); + if tf.target_nb_refs > 0 then + pr "@;irdata->ref_org = irdata->ref_org + %d;" tf.target_nb_refs + 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; + let tf = StrMap.find f program.program_targets in + pr "@.@[%a {" (generate_target_prototype false) f; + let sav = fresh_c_local "sav" in + let sav_nb_tmps = Pp.spr "%s_nb_tmps_target" sav in + let sav_nb_refs = Pp.spr "%s_nb_refs_target" sav in + pr "@;int %s = irdata->nb_tmps_target;" sav_nb_tmps; + pr "@;int %s = irdata->nb_refs_target;" sav_nb_refs; + pr "%a" generate_cible_tmp_decls tf; + pr "@;irdata->nb_tmps_target = %d;" + (StrMap.fold (fun _ v n -> n + Com.Var.size v) tf.target_tmp_vars 0); + pr "@;irdata->nb_refs_target = %d;" tf.target_nb_refs; + 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 "@;irdata->nb_refs_target = %s;" sav_nb_refs; + pr "@;irdata->nb_tmps_target = %s;" sav_nb_tmps; + pr "@;return irdata->discords;"; + pr "@]@;}@." let generate_targets (dgfip_flags : Dgfip_options.flags) (program : Mir.program) (filemap : (out_channel * Format.formatter) StrMap.t) = - let targets = Com.TargetMap.bindings program.program_targets in + let targets = StrMap.bindings program.program_targets in List.iter - (fun (name, Mir.{ target_file; _ }) -> + (fun (name, ({ target_file; _ } : Mir.target)) -> let file_str = match target_file with Some s -> s | None -> "" in let _, fmt = StrMap.find file_str filemap in generate_target (dgfip_flags : Dgfip_options.flags) program fmt name) @@ -845,8 +1696,8 @@ let generate_c_program (dgfip_flags : Dgfip_options.flags) let oc = Format.formatter_of_out_channel _oc in Format.fprintf oc "%a@\n@." generate_implem_header Prelude.message; let filemap = - Com.TargetMap.fold - (fun _ (t : Mir.target_data) filemap -> + StrMap.fold + (fun _ (t : Mir.target) filemap -> let file_str = match t.target_file with Some s -> s | None -> "" in let update = function | Some fmt -> Some fmt @@ -854,7 +1705,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) @@ -865,6 +1716,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/decoupledExpr.ml b/src/mlang/backend_compilers/decoupledExpr.ml index 6a970e3a8..fe162878f 100644 --- a/src/mlang/backend_compilers/decoupledExpr.ml +++ b/src/mlang/backend_compilers/decoupledExpr.ml @@ -1,38 +1,18 @@ module VID = Dgfip_varid -type offset = - | GetValueConst of int - | GetValueExpr of string - | GetValueVar of Com.Var.t - | PassPointer - | None - -let rec generate_variable (offset : offset) ?(def_flag = false) - ?(trace_flag = false) (var : Com.Var.t) : string = +let generate_variable ?(def_flag = false) ?(trace_flag = false) + (vsd : Com.variable_space) (var : Com.Var.t) : string = try - match offset with - | PassPointer -> - if def_flag then VID.gen_def_ptr var else VID.gen_val_ptr var - | _ -> - let offset = - match offset with - | None -> "" - | GetValueVar offset -> " + (int)" ^ generate_variable None offset - | GetValueConst offset -> " + " ^ string_of_int offset - | GetValueExpr offset -> Format.sprintf " + (%s)" offset - | PassPointer -> assert false - in - if def_flag then VID.gen_def var offset - else - let access_val = VID.gen_val var offset in - (* When the trace flag is present, we print the value of the - non-temporary variable being used *) - if trace_flag && not (Com.Var.is_temp var) then - let vn = Pos.unmark var.Com.Var.name in - let pos_tgv = VID.gen_pos_from_start var in - Format.asprintf "(aff3(\"%s\",irdata, %s), %s)" vn pos_tgv - access_val - else access_val + if def_flag then VID.gen_def vsd var + else + let access_val = VID.gen_val vsd var in + (* When the trace flag is present, we print the value of the + non-temporary variable being used *) + if trace_flag && not (Com.Var.is_temp var) then + let vn = Pos.unmark var.Com.Var.name in + let pos_tgv = VID.gen_pos_from_start var in + Format.asprintf "(aff3(\"%s\",irdata, %s), %s)" vn pos_tgv access_val + else access_val with Not_found -> Errors.raise_error (Format.asprintf "Variable %s not found in TGV" @@ -68,12 +48,13 @@ and expr = | Dunop of string * expr | Dbinop of string * expr * expr | Dfun of string * expr list - | 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 +and expr_var = + | Local of stack_slot + | M of Com.variable_space * Com.Var.t * dflag and t = expr * dflag * local_vars @@ -136,7 +117,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 *) @@ -212,8 +193,9 @@ let dfalse _stacks _lv : t = (Dfalse, Def, []) let lit (f : float) _stacks _lv : t = (Dlit f, Val, []) -let m_var (v : Com.Var.t) (offset : offset) (df : dflag) _stacks _lv : t = - (Dvar (M (v, offset, df)), df, []) +let m_var (vsd : Com.variable_space) (v : Com.Var.t) (df : dflag) _stacks _lv : + t = + (Dvar (M (vsd, v, df)), df, []) let local_var (lvar : local_var) (stacks : local_stacks) (ctx : local_vars) : t = @@ -315,6 +297,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 @@ -359,13 +352,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 access (var : Com.Var.t) (df : dflag) (e : constr) (stacks : local_stacks) - (ctx : local_vars) : t = - let _, lv, e = push_with_kind stacks ctx Val e in - (Daccess (var, df, e), df, lv) +let ddirect (c : constr) (stacks : local_stacks) (ctx : local_vars) : t = + let expr, flags, ctx = c stacks ctx in + (Ddirect expr, flags, ctx) let ite (c : constr) (t : constr) (e : constr) (stacks : local_stacks) (ctx : local_vars) : t = @@ -452,11 +441,10 @@ let format_slot fmt ({ kind; depth } : stack_slot) = let format_expr_var (dgfip_flags : Dgfip_options.flags) fmt (ev : expr_var) = match ev with | Local slot -> format_slot fmt slot - | M (var, offset, df) -> + | M (vsd, var, df) -> let def_flag = df = Def in Format.fprintf fmt "%s" - (generate_variable ~trace_flag:dgfip_flags.flg_trace offset ~def_flag - var) + (generate_variable ~trace_flag:dgfip_flags.flg_trace ~def_flag vsd var) let rec format_dexpr (dgfip_flags : Dgfip_options.flags) fmt (de : expr) = let format_dexpr = format_dexpr dgfip_flags in @@ -509,12 +497,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 - | Daccess (var, dflag, de) -> - Format.fprintf fmt "(%s[(int)%a])" - (generate_variable ~def_flag:(dflag = Def) - ~trace_flag:dgfip_flags.flg_trace PassPointer var) - format_dexpr de + | Dinstr instr -> Format.fprintf fmt "%s" instr + | Ddirect expr -> format_dexpr fmt expr | Dite (dec, det, dee) -> Format.fprintf fmt "@[(%a ?@ %a@ : %a@])" format_dexpr dec format_dexpr det format_dexpr dee @@ -522,10 +506,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 () @@ -533,14 +517,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 @@ -548,9 +532,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/decoupledExpr.mli b/src/mlang/backend_compilers/decoupledExpr.mli index d76f679b3..25f2c830d 100644 --- a/src/mlang/backend_compilers/decoupledExpr.mli +++ b/src/mlang/backend_compilers/decoupledExpr.mli @@ -1,12 +1,9 @@ -type offset = - | GetValueConst of int - | GetValueExpr of string - | GetValueVar of Com.Var.t - | PassPointer - | None - val generate_variable : - offset -> ?def_flag:bool -> ?trace_flag:bool -> Com.Var.t -> string + ?def_flag:bool -> + ?trace_flag:bool -> + Com.variable_space -> + Com.Var.t -> + string type dflag = Def | Val @@ -62,7 +59,7 @@ val dfalse : constr val lit : float -> constr (** Float literal *) -val m_var : Com.Var.t -> offset -> dflag -> constr +val m_var : Com.variable_space -> Com.Var.t -> dflag -> constr (** Value from TGV. [m_var v off df] represents an access to the TGV variable [v] with [df] to read defineness or valuation. [off] is the access type for M array, and should be [None] most of the time. For array access, see @@ -100,6 +97,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 *) @@ -109,12 +110,9 @@ 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 -(** Arbitrary access to M TGV variable. Either defineness of valuation *) - val ite : constr -> constr -> constr -> constr (** Functionnal if-the-else construction. [ite cond_expr then_expr else_expr] is akin to [if cond_expr then then_expr else else_expr] *) diff --git a/src/mlang/backend_compilers/dgfip_compir_files.ml b/src/mlang/backend_compilers/dgfip_compir_files.ml index fbc1f56a2..0967de8bf 100644 --- a/src/mlang/backend_compilers/dgfip_compir_files.ml +++ b/src/mlang/backend_compilers/dgfip_compir_files.ml @@ -205,7 +205,7 @@ let get_vars (cprog : Mir.program) is_ebcdic = match var.scope with | Tgv tgv -> let tvar = get_cat_var tgv in - let size = match tgv.is_table with Some i -> i | None -> 1 in + let size = Com.Var.size var in let idx1, idx2, idxo_opt = next_idx idx tvar (var_is_output tgv) size in @@ -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 04a6bbbc0..5e986d3c7 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -20,67 +20,94 @@ let open_file filename = 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 *****/ +let gen_table_varinfo vars cat Com.CatVar.{ id_int; id_str; attributs; _ } stats + = + let oc, fmt = open_file (Pp.spr "varinfo_%d.c" id_int) in + Pp.fpr 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 = - StrMap.fold - (fun _ var (nb, var_map) -> - if Com.CatVar.compare (Com.Var.cat var) cat = 0 then ( - let loc_tgv = Com.Var.loc_tgv var in - let name = Com.Var.name_str var in - let alias = Com.Var.alias_str var in - let idx = loc_tgv.loc_idx in - let size = Com.Var.size var in - let loc_cat = - match loc_tgv.loc_cat with - | Com.CatVar.LocComputed -> "EST_CALCULEE" - | Com.CatVar.LocBase -> "EST_BASE" - | Com.CatVar.LocInput -> "EST_SAISIE" - in - let attrs = Com.Var.attrs var in - Format.fprintf fmt " { \"%s\", \"%s\", %d, %d, %d, %s" name alias idx - size id_int loc_cat; - StrMap.iter - (fun _ av -> Format.fprintf fmt ", %d" (Pos.unmark av)) - attrs; - Format.fprintf fmt " },\n"; - let var_addr = - Format.sprintf "(T_varinfo *)&(varinfo_%s[%d])" id_str nb - in - let var_map = StrMap.add (Com.Var.name_str var) var_addr var_map in - let var_map = - match Com.Var.alias var with - | None -> var_map - | Some m_alias -> StrMap.add (Pos.unmark m_alias) var_addr var_map - in - (nb + 1, var_map)) - else (nb, var_map)) - vars (0, var_map) - in - Format.fprintf fmt " NULL\n};\n\n"; + Pp.fpr fmt "T_varinfo_%s varinfo_%s[NB_%s + 1] = {\n" id_str id_str id_str; + IntMap.iter + (fun _ var -> + let loc_tgv = Com.Var.loc_tgv var in + let name = Com.Var.name_str var in + let alias = Com.Var.alias_str var in + let idx = loc_tgv.loc_idx in + let size = Com.Var.size var in + let loc_cat = + match loc_tgv.loc_cat with + | Com.CatVar.LocComputed -> "EST_CALCULEE" + | Com.CatVar.LocBase -> "EST_BASE" + | Com.CatVar.LocInput -> "EST_SAISIE" + in + let attrs = Com.Var.attrs var in + let tab_idx = + if Com.Var.is_table var then Com.Var.loc_tab_idx var else -1 + in + Pp.fpr fmt " { \"%s\", \"%s\", %d, %d, %d, %d, %s" name alias idx tab_idx + size id_int loc_cat; + StrMap.iter (fun _ av -> Pp.fpr fmt ", %d" (Pos.unmark av)) attrs; + Pp.fpr fmt " },\n") + vars; + Pp.fpr fmt " NULL\n};\n\n"; close_out oc; + let nb = IntMap.cardinal vars in 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) + Com.CatVar.Map.add cat (id_str, id_int, nb, attr_set) stats + +let gen_table_tmp_varinfo (cprog : Mir.program) fmt = + let vars = IntMap.filter (fun _ v -> Com.Var.is_temp v) cprog.program_dict in + Pp.fpr fmt "T_varinfo tmp_varinfo[%d] = {\n" (IntMap.cardinal vars + 1); + IntMap.iter + (fun _ var -> + let name = Com.Var.name_str var in + let idx = Com.Var.loc_idx var in + let tab_idx = + if Com.Var.is_table var then Com.Var.loc_tab_idx var else -1 + in + let size = Com.Var.size var in + Pp.fpr fmt + " { \"%s\", \"\", %d, %d, %d, ID_TMP_VARS, EST_TEMPORAIRE },\n" name + idx tab_idx size) + vars; + Pp.fpr fmt " NULL\n};\n\n" + +let gen_table_tab_varinfo (cprog : Mir.program) fmt = + let table_map = cprog.program_stats.table_map in + Pp.fpr fmt "T_varinfo *tab_varinfo[TAILLE_TAB_VARINFO + 1] = {\n"; + IntMap.iter + (fun _ var -> + let idx = Com.Var.loc_cat_idx var in + let name = Com.Var.name_str var in + if Com.Var.is_tgv var then + let loc = Com.Var.loc_tgv var in + Pp.fpr fmt " (T_varinfo *)&(varinfo_%s[%d]), /* %s */\n" + loc.loc_cat_str idx name + else Pp.fpr fmt " &(tmp_varinfo[%d]), /* %s */\n" idx name) + table_map; + Pp.fpr fmt " NULL\n};\n\n" 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) + let stats_varinfos = + let fold cv data res = + let vars = + let foldVars _ var vars = + if Com.CatVar.compare (Com.Var.cat var) cv = 0 then + IntMap.add (Com.Var.loc_cat_idx var) var vars + else vars + in + StrMap.fold foldVars cprog.program_vars IntMap.empty + in + gen_table_varinfo vars cv data res + in + Com.CatVar.Map.fold fold cprog.program_var_categories Com.CatVar.Map.empty in let oc, fmt = open_file "varinfos.c" in - Format.fprintf fmt {|/****** LICENCE CECIL *****/ + Pp.fpr fmt {|/****** LICENCE CECIL *****/ #include "mlang.h" @@ -93,45 +120,67 @@ let gen_table_varinfos (cprog : Mir.program) flags = 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; if flags.Dgfip_options.flg_gcos then - Format.fprintf fmt "T_varinfo_map varinfo[1] = {NULL};\n\n" + Pp.fpr 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"); + Pp.fpr fmt "T_varinfo_map varinfo[NB_variable + NB_saisie + 1] = {\n"; + let var_map = + let fold name var var_map = + let var_map = StrMap.add name var var_map in + match Com.Var.alias var with + | Some m_alias -> StrMap.add (Pos.unmark m_alias) var var_map + | None -> var_map + in + StrMap.fold fold cprog.program_vars StrMap.empty + in + let iter name var = + let id_str = + let cv = Com.Var.cat var in + Com.CatVar.((Map.find cv cprog.program_var_categories).id_str) + in + let idx = Com.Var.loc_cat_idx var in + let var_addr = Pp.spr "(T_varinfo *)&(varinfo_%s[%d])" id_str idx in + Pp.fpr fmt " { \"%s\", %s },\n" name var_addr + in + StrMap.iter iter var_map; + Pp.fpr fmt " NULL\n};\n\n"); + gen_table_tmp_varinfo cprog fmt; + gen_table_tab_varinfo cprog fmt; close_out oc; stats_varinfos let gen_decl_varinfos fmt (cprog : Mir.program) stats = - Format.fprintf fmt + Pp.fpr fmt {|typedef struct S_varinfo { char *name; char *alias; int idx; + int tab_idx; int size; int cat; int loc_cat; @@ -145,29 +194,31 @@ typedef struct S_varinfo_map { |}; Com.CatVar.Map.iter (fun _ (id_str, _, _, attr_set) -> - Format.fprintf fmt + Pp.fpr fmt {|typedef struct S_varinfo_%s { char *name; char *alias; int idx; + int tab_idx; int size; int cat; int loc_cat; |} id_str; - StrSet.iter (fun an -> Format.fprintf fmt " int attr_%s;\n" an) attr_set; - Format.fprintf fmt "} T_varinfo_%s;\n\n" id_str) + StrSet.iter (fun an -> Pp.fpr fmt " int attr_%s;\n" an) attr_set; + Pp.fpr fmt "} T_varinfo_%s;\n\n" id_str) stats; - Format.fprintf fmt "\n"; + Pp.fpr fmt "\n"; Com.CatVar.Map.iter (fun _ (id_str, _, _, _) -> - Format.fprintf fmt "extern T_varinfo_%s varinfo_%s[];\n" id_str id_str) + Pp.fpr fmt "extern T_varinfo_%s varinfo_%s[];\n" id_str id_str) stats; - Format.fprintf fmt "extern T_varinfo_map varinfo[];\n"; - Format.fprintf fmt "\n"; + Pp.fpr fmt "extern T_varinfo_map varinfo[];\n"; + Pp.fpr fmt "extern T_varinfo tmp_varinfo[];\n"; + Pp.fpr fmt "extern T_varinfo *tab_varinfo[];\n"; + Pp.fpr fmt "\n"; Com.CatVar.Map.iter - (fun _ (id_str, _, nb, _) -> - Format.fprintf fmt "#define NB_%s %d\n" id_str nb) + (fun _ (id_str, _, nb, _) -> Pp.fpr fmt "#define NB_%s %d\n" id_str nb) stats; let nb_saisie, nb_variable = Com.CatVar.Map.fold @@ -178,17 +229,17 @@ typedef struct S_varinfo_map { | _ -> (nb_saisie, nb_variable)) stats (0, 0) in - Format.fprintf fmt "#define NB_saisie %d\n" nb_saisie; - Format.fprintf fmt "#define NB_variable %d\n" nb_variable; - Format.fprintf fmt "\n"; + Pp.fpr fmt "#define NB_saisie %d\n" nb_saisie; + Pp.fpr fmt "#define NB_variable %d\n" nb_variable; + Pp.fpr fmt "\n"; let id_tmp = Com.CatVar.Map.fold (fun _ (id_str, id_int, _, _) id_tmp -> - Format.fprintf fmt "#define ID_%s %d\n" id_str id_int; + Pp.fpr fmt "#define ID_%s %d\n" id_str id_int; max (id_int + 1) id_tmp) stats (-1) in - Format.fprintf fmt "#define ID_TMP_VARS %d\n" id_tmp; + Pp.fpr fmt "#define ID_TMP_VARS %d\n" id_tmp; let attrs = Com.CatVar.Map.fold @@ -198,15 +249,15 @@ typedef struct S_varinfo_map { in StrSet.iter (fun attr -> - Format.fprintf fmt "\nextern char attribut_%s_def(T_varinfo *vi);\n" attr; - Format.fprintf fmt "extern double attribut_%s(T_varinfo *vi);\n" attr) + Pp.fpr fmt "\nextern char attribut_%s_def(T_varinfo *vi);\n" attr; + Pp.fpr fmt "extern double attribut_%s(T_varinfo *vi);\n" attr) attrs let is_valid_app apps = StrMap.exists (fun app _ -> List.mem app !Cli.application_names) apps let gen_erreurs_c fmt flags (cprog : Mir.program) = - Format.fprintf fmt {|/****** LICENCE CECIL *****/ + Pp.fpr fmt {|/****** LICENCE CECIL *****/ #include "mlang.h" @@ -221,83 +272,83 @@ let gen_erreurs_c fmt flags (cprog : Mir.program) = if String.equal (Pos.unmark e.sous_code) "00" then "" else "-" ^ Pos.unmark e.sous_code in - Format.fprintf fmt + Pp.fpr fmt "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 - Format.fprintf fmt "T_erreur *tabErreurs[] = {\n"; + Pp.fpr fmt "T_erreur *tabErreurs[] = {\n"; StrMap.iter (fun _ (e : Com.Error.t) -> - Format.fprintf fmt " &erreur_%s,\n" (Pos.unmark e.name)) + Pp.fpr fmt " &erreur_%s,\n" (Pos.unmark e.name)) cprog.program_errors; - Format.fprintf fmt " NULL\n};\n" + Pp.fpr fmt " NULL\n};\n" end (* Print #defines corresponding to generation options *) let gen_conf_h fmt (cprog : Mir.program) flags = let open Dgfip_options in - Format.fprintf fmt + Pp.fpr fmt {|/****** LICENCE CECIL *****/ #ifndef _CONF_H_ #define _CONF_H_ |}; - if flags.flg_correctif then Format.fprintf fmt "#define FLG_CORRECTIF\n"; - 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_tri_ebcdic then Format.fprintf fmt "#define FLG_TRI_EBCDIC\n"; + if flags.flg_correctif then Pp.fpr fmt "#define FLG_CORRECTIF\n"; + if flags.flg_iliad then Pp.fpr fmt "#define FLG_ILIAD\n"; + if flags.flg_pro then Pp.fpr fmt "#define FLG_PRO\n"; + if flags.flg_cfir then Pp.fpr fmt "#define FLG_CFIR\n"; + if flags.flg_gcos then Pp.fpr fmt "#define FLG_GCOS\n"; + if flags.flg_tri_ebcdic then Pp.fpr fmt "#define FLG_TRI_EBCDIC\n"; (* flag is not used *) - if flags.flg_short then - Format.fprintf fmt "#define FLG_SHORT /* inutile ? */\n"; - if flags.flg_register then Format.fprintf fmt "#define FLG_REGISTER\n"; + if flags.flg_short then Pp.fpr fmt "#define FLG_SHORT /* inutile ? */\n"; + if flags.flg_register then Pp.fpr fmt "#define FLG_REGISTER\n"; (* flag is not used *) if flags.flg_optim_min_max then - Format.fprintf fmt "#define FLG_OPTIM_MIN_MAX /* inutile ? */\n"; - if flags.flg_extraction then Format.fprintf fmt "#define FLG_EXTRACTION\n"; + Pp.fpr fmt "#define FLG_OPTIM_MIN_MAX /* inutile ? */\n"; + if flags.flg_extraction then Pp.fpr fmt "#define FLG_EXTRACTION\n"; if flags.flg_genere_libelle_restituee then - Format.fprintf fmt "#define FLG_GENERE_LIBELLE_RESTITUEE\n"; - if flags.flg_controle_separe then - Format.fprintf fmt "#define FLG_CONTROLE_SEPARE\n"; + Pp.fpr fmt "#define FLG_GENERE_LIBELLE_RESTITUEE\n"; + if flags.flg_controle_separe then Pp.fpr fmt "#define FLG_CONTROLE_SEPARE\n"; if flags.flg_controle_immediat then - Format.fprintf fmt "#define FLG_CONTROLE_IMMEDIAT\n"; + Pp.fpr fmt "#define FLG_CONTROLE_IMMEDIAT\n"; (* does not need to be printed *) - (*if flags.flg_overlays then Format.fprintf fmt "#define FLG_OVERLAYS\n"; *) - if flags.flg_colors then Format.fprintf fmt "#define FLG_COLORS\n"; - if flags.flg_ticket then Format.fprintf fmt "#define FLG_TICKET\n"; - if flags.flg_trace then Format.fprintf fmt "#define FLG_TRACE\n"; + (*if flags.flg_overlays then Pp.fpr fmt "#define FLG_OVERLAYS\n"; *) + if flags.flg_colors then Pp.fpr fmt "#define FLG_COLORS\n"; + if flags.flg_ticket then Pp.fpr fmt "#define FLG_TICKET\n"; + if flags.flg_trace then Pp.fpr fmt "#define FLG_TRACE\n"; (* flag is not used *) - (*if flags.flg_trace_irdata then Format.fprintf fmt "#define + (*if flags.flg_trace_irdata then Pp.fpr fmt "#define FLG_TRACE_IRDATA\n"; *) - if flags.flg_debug then Format.fprintf fmt "#define FLG_DEBUG\n"; - Format.fprintf fmt "#define NB_DEBUG_C %d\n" flags.nb_debug_c; - Format.fprintf fmt "#define EPSILON %f\n" !Cli.comparison_error_margin; + if flags.flg_debug then Pp.fpr fmt "#define FLG_DEBUG\n"; + Pp.fpr fmt "#define NB_DEBUG_C %d\n" flags.nb_debug_c; + Pp.fpr fmt "#define EPSILON %f\n" !Cli.comparison_error_margin; let count loc = StrMap.fold (fun _ var nb -> - nb + if Com.Var.cat_var_loc var = Some loc then Com.Var.size var else 0) + nb + if Com.Var.cat_var_loc var = loc then Com.Var.size var else 0) cprog.program_vars 0 in let nb_saisie = count Com.CatVar.LocInput in let nb_calculee = count Com.CatVar.LocComputed in let nb_base = count Com.CatVar.LocBase in let nb_vars = nb_saisie + nb_calculee + nb_base in - Format.fprintf fmt "#define NB_VARS %d\n" nb_vars; - Format.fprintf fmt {| + Pp.fpr fmt "#define NB_VARS %d\n" nb_vars; + Pp.fpr fmt {| #endif /* _CONF_H_ */ |} let gen_dbg fmt = - Format.fprintf fmt + Pp.fpr fmt {|int change_couleur(int couleur, int typographie); int get_couleur(); int get_typo(); @@ -315,8 +366,8 @@ extern void aff_val(const char *nom, const T_irdata *irdata, int indice, int niv #endif /* FLG_TRACE */ |} -let gen_const fmt = - Format.fprintf fmt +let gen_const fmt (cprog : Mir.program) = + Pp.fpr fmt {|#define FALSE 0 #define TRUE 1 @@ -355,21 +406,58 @@ 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 Pp.fpr fmt " T_varinfo *field_%s_var;\n" fname + else ( + Pp.fpr fmt " char field_%s_def;\n" fname; + Pp.fpr fmt " double field_%s_val;\n" fname)) + cprog.program_event_field_idxs; + Pp.fpr fmt + {|}; + +typedef struct S_event T_event; + struct S_irdata { + char *def_saisie; double *saisie; + char *def_calculee; double *calculee; + char *def_base; double *base; +|}; + IntMap.iter + (fun _ (vsd : Com.variable_space) -> + let sp = Pos.unmark vsd.vs_name in + Com.CatVar.LocMap.iter + (fun loc _ -> + match loc with + | Com.CatVar.LocInput -> + Pp.fpr fmt " char *def_saisie_%s;@\n" sp; + Pp.fpr fmt " double *saisie_%s;@\n" sp + | Com.CatVar.LocComputed -> + Pp.fpr fmt " char *def_calculee_%s;@\n" sp; + Pp.fpr fmt " double *calculee_%s;@\n" sp + | Com.CatVar.LocBase -> + Pp.fpr fmt " char *def_base_%s;@\n" sp; + Pp.fpr fmt " double *base_%s;@\n" sp) + vsd.vs_cats) + cprog.program_var_spaces_idx; + Pp.fpr fmt + {| char *def_tmps; double *tmps; - double **ref; - char *def_saisie; - char *def_calculee; - char *def_base; - char *def_tmps; + int tmps_org; + int nb_tmps_target; + T_varinfo **info_tmps; char **def_ref; - T_varinfo *info_tmps; + double **ref; T_varinfo **info_ref; - int tmps_org; int ref_org; + int nb_refs_target; + char **ref_name; T_keep_discord *keep_discords; T_discord *discords; int nb_anos; @@ -387,31 +475,56 @@ 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; -#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 DC_ irdata->def_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*/ +|}; + StrMap.iter + (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) + cprog.program_event_fields; + Pp.fpr fmt + {| +#define DS_(sp,idx) irdata->def_saisie_##sp[idx] +#define S_(sp,idx) irdata->saisie_##sp[idx] + +#define DC_(sp,idx) irdata->def_calculee_##sp[idx] +#define C_(sp,idx) irdata->calculee_##sp[idx] + +#define DB_(sp,idx) irdata->def_base_##sp[idx] +#define B_(sp,idx) irdata->base_##sp[idx] + +#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 NR_(idx) (irdata->ref_name[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 #define EST_TEMPORAIRE 0x10000 -#define EST_ARGUMENT 0x20000 -#define EST_RESULTAT 0x40000 #define EST_MASQUE 0x3c000 #define INDICE_VAL 0x03fff @@ -426,9 +539,8 @@ extern void free_erreur(); #define min(a,b) (((a) <= (b)) ? (a) : (b)) #define max(a,b) (((a) >= (b)) ? (a) : (b)) |}; - Format.fprintf fmt "#define EPSILON %f" !Cli.comparison_error_margin; - - Format.fprintf fmt + Pp.fpr fmt "#define EPSILON %f" !Cli.comparison_error_margin; + Pp.fpr fmt {| #define GT_E(a,b) ((a) > (b) + EPSILON) #define LT_E(a,b) ((a) + EPSILON < (b)) @@ -443,8 +555,13 @@ 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_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); |} @@ -453,7 +570,7 @@ let gen_lib fmt (cprog : Mir.program) flags = let count loc = StrMap.fold (fun _ var nb -> - nb + if Com.Var.cat_var_loc var = Some loc then Com.Var.size var else 0) + nb + if Com.Var.cat_var_loc var = loc then Com.Var.size var else 0) cprog.program_vars 0 in let taille_saisie = count Com.CatVar.LocInput in @@ -465,7 +582,7 @@ let gen_lib fmt (cprog : Mir.program) flags = let nb_call = IntMap.cardinal cprog.program_rules in let nb_verif = IntMap.cardinal cprog.program_verifs in - Format.fprintf fmt + Pp.fpr fmt {|#define TAILLE_SAISIE %d #define TAILLE_CALCULEE %d #define TAILLE_BASE %d @@ -475,13 +592,12 @@ let gen_lib fmt (cprog : Mir.program) flags = |} taille_saisie taille_calculee taille_base taille_totale nb_ench; - Format.fprintf fmt {|#define TAILLE_TMP_VARS %d -#define TAILLE_REFS %d - -|} - cprog.program_stats.sz_all_tmps cprog.program_stats.nb_all_refs; + Pp.fpr fmt "#define TAILLE_TMP_VARS %d\n" cprog.program_stats.sz_all_tmps; + Pp.fpr fmt "#define TAILLE_REFS %d\n" cprog.program_stats.nb_all_refs; + Pp.fpr fmt "#define TAILLE_TAB_VARINFO %d\n" + (IntMap.cardinal cprog.program_stats.table_map); - Format.fprintf fmt + Pp.fpr fmt {|#define ANOMALIE 1 #define DISCORDANCE 2 #define INFORMATIVE 4 @@ -502,24 +618,24 @@ let gen_lib fmt (cprog : Mir.program) flags = |}; - Format.fprintf fmt "#define NB_ERR %d\n" nb_err; - Format.fprintf fmt "#define NB_CALL %d\n" nb_call; - Format.fprintf fmt "#define NB_VERIF %d\n\n" nb_verif; + Pp.fpr fmt "#define NB_ERR %d\n" nb_err; + Pp.fpr fmt "#define NB_CALL %d\n" nb_call; + Pp.fpr fmt "#define NB_VERIF %d\n\n" nb_verif; (* TODO external declaration of individual control rules (seems to be no longer used) *) StrMap.iter (fun _ (e : Com.Error.t) -> let en = Pos.unmark e.name in - Format.fprintf fmt "extern T_erreur erreur_%s;\n" en) + Pp.fpr fmt "extern T_erreur erreur_%s;\n" en) cprog.program_errors; (* TODO function declarations (seems to be no longer used) *) if flags.Dgfip_options.flg_pro then - Format.fprintf fmt "extern struct S_erreur *tabErreurs[];\n\n" - else Format.fprintf fmt "\n"; + Pp.fpr fmt "extern struct S_erreur *tabErreurs[];\n\n" + else Pp.fpr fmt "\n"; - Format.fprintf fmt + Pp.fpr fmt {|extern void set_print_indent(FILE *std, T_print_context *pr_ctx, double diff); extern void print_indent(FILE *std, T_print_context *pr_ctx); extern void print_string(FILE *std, T_print_context *pr_ctx, char *str); @@ -533,8 +649,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); @@ -577,43 +701,110 @@ 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 char *concat_nom_index(char *nom, const char *fmt, char def, double val); extern T_varinfo *cherche_varinfo(T_irdata *irdata, const char *nom); -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 char lis_varinfo( + T_irdata *irdata, + T_varinfo *info, + char *res_def, double *res_val +); + +extern char lis_varinfo_tab( + T_irdata *irdata, + int idx_tab, char idx_def, double idx_val, + char *res_def, double *res_val +); + 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 ecris_varinfo_tab( + T_irdata *irdata, + int idx_tab, int idx_def, double idx_val, + char def, double val +); + +extern T_varinfo *lis_tabaccess_varinfo( + T_irdata *irdata, int idx_tab, + char idx_def, double idx_val +); + +extern char lis_tabaccess( + T_irdata *irdata, int idx_tab, + char idx_def, double idx_val, + char *res_def, double *res_val +); + +extern void ecris_tabaccess( + T_irdata *irdata, int idx_tab, + char idx_def, double idx_val, + char def, double val +); + +extern char lis_concaccess( + T_irdata *irdata, + char *nom, const char *fmt, char idx_def, double idx_val, + char *res_def, double *res_val +); + +extern T_varinfo *lis_concaccess_varinfo( + T_irdata *irdata, + char *nom, const char *fmt, char idx_def, double idx_val +); + +extern void ecris_concaccess( + T_irdata *irdata, + char *nom, const char *fmt, char idx_def, double idx_val, + char def, double val +); + extern void pr_var(T_print_context *pr_ctx, T_irdata *irdata, char *nom); extern void pr_out_var(T_irdata *irdata, char *nom); extern void pr_err_var(T_irdata *irdata, char *nom); + +extern char est_variable( + T_varinfo *info, char *nomCmp, char *res_def, double *res_val +); + +extern char est_variable_tabaccess( + T_irdata *irdata, int idx_tab, + char idx_def, double idx_val, + char *nomCmp, char *res_def, double *res_val +); + +extern char est_variable_concaccess( + T_irdata *irdata, + char *nom, const char *fmt, char idx_def, double idx_val, + char *nomCmp, char *res_def, double *res_val +); + |} let gen_decl_functions fmt (cprog : Mir.program) = - let functions = Com.TargetMap.bindings cprog.program_functions in + let functions = StrMap.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);" - fn pp_args fd.Mir.target_args)) + Pp.fpr fmt "@[%a@]@," + (Format.pp_print_list (fun fmt (fn, (fd : Mir.target)) -> + Pp.fpr fmt + "extern int %s(T_irdata* irdata, char *res_def, double *res_val%a);" + fn pp_args fd.target_args)) functions let gen_decl_targets fmt (cprog : Mir.program) = - let targets = Com.TargetMap.bindings cprog.program_targets in - Format.fprintf fmt "@[%a@]@," + let targets = StrMap.bindings cprog.program_targets in + Pp.fpr fmt "@[%a@]@," (Format.pp_print_list (fun fmt (name, _) -> - Format.fprintf fmt "extern struct S_discord *%s(T_irdata* irdata);" - name)) + Pp.fpr fmt "extern struct S_discord *%s(T_irdata* irdata);" name)) targets let gen_mlang_h fmt cprog flags stats_varinfos = - let pr form = Format.fprintf fmt form in + let pr form = Pp.fpr fmt form in pr "/****** LICENCE CECIL *****/\n\n"; pr "#ifndef _MLANG_H_\n"; pr "#define _MLANG_H_\n"; @@ -633,7 +824,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; @@ -645,8 +836,8 @@ 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 = - Format.fprintf fmt "%s" +let gen_mlang_c fmt (cprog : Mir.program) flags = + Pp.fpr fmt "%s" {|/****** LICENCE CECIL *****/ #include "mlang.h" @@ -807,12 +998,12 @@ void add_erreur(T_irdata *irdata, T_erreur *ref_erreur, char *code) { if (ref_erreur->type == INFORMATIVE) irdata->nb_infos++; |}; if flags.Dgfip_options.flg_pro || flags.flg_iliad then - Format.fprintf fmt "%s" + Pp.fpr fmt "%s" {|if (strcmp(ref_erreur->isisf, "O") != 0 && ref_erreur->type == ANOMALIE) { |} - else Format.fprintf fmt "%s" {|if (ref_erreur->type == ANOMALIE) { + else Pp.fpr fmt "%s" {|if (ref_erreur->type == ANOMALIE) { |}; - Format.fprintf fmt "%s" + Pp.fpr fmt "%s" {|irdata->nb_bloqs++; if (irdata->nb_bloqs >= irdata->max_bloqs) { longjmp(irdata->jmp_bloq, 1); @@ -836,156 +1027,47 @@ int nb_bloquantes(T_irdata *irdata) { return irdata->nb_bloqs; } -#ifdef FLG_TRACE - -/* int niv_trace = 3; */ - -#ifdef FLG_API -#define TRACE_FILE fd_trace_dialog -#else -#define TRACE_FILE stderr -#endif /* FLG_API */ - -void aff1(nom) -char *nom ; -{ -#ifdef FLG_COLORS -if (niv_trace >= 1) fprintf(stderr, "\033[%d;%dm%s\033[0m", color, typo, nom) ; -#else -if (niv_trace >= 1) fprintf(stderr, "%s \n", nom) ; -#endif +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]; } -void aff_val(const char *nom, const T_irdata *irdata, int indice, int niv, const char *chaine, int is_tab, int expr, int maxi) { - double valeur; - int def; - if (expr < 0) { - if (niv_trace >= niv) { -#ifdef FLG_COLORS - fprintf(TRACE_FILE, "\033[%d;%dm%s[%d] %s 0\033[0m\n", - color, typo, nom, expr, chaine); -#else - fprintf(TRACE_FILE, "%s[%d] %s 0m\n", nom, expr, chaine); -#endif /* FLG_COLORS */ - } - return; - } else if (expr >= maxi) { -#ifdef FLG_COLORS - fprintf(TRACE_FILE, - "\033[%d;%dmerreur: indice (%d) superieur au maximum (%d)\033[0m\n", - color, typo, expr, maxi); -#else - fprintf(TRACE_FILE, "erreur: indice (%d) superieur au maximum (%d)\n", - expr, maxi); -#endif /* FLG_COLORS */ - expr = 0; - } - switch (indice & EST_MASQUE) { - case EST_SAISIE: - valeur = irdata->saisie[(indice & INDICE_VAL) + expr]; - def = irdata->def_saisie[(indice & INDICE_VAL) + expr]; - break; - case EST_CALCULEE: - valeur = irdata->calculee[(indice & INDICE_VAL) + expr]; - def = irdata->def_calculee[(indice & INDICE_VAL) + expr]; - break; - case EST_BASE: - valeur = irdata->base[(indice & INDICE_VAL) + expr]; - def = irdata->def_base[(indice & INDICE_VAL) + expr]; - break; - case EST_TEMPORAIRE: - valeur = irdata->tmps[irdata->tmps_org - (indice & INDICE_VAL) + expr]; - def = irdata->def_tmps[irdata->tmps_org - (indice & INDICE_VAL) + expr]; - break; - } - if (is_tab) { - if (def == 0) { - if (valeur != 0) { -#ifdef FLG_COLORS - fprintf(TRACE_FILE, "\033[%d;%dm%s[%d] : erreur undef = %lf\033[0m\n", - color, typo, nom, expr, valeur); -#else - fprintf(TRACE_FILE, "%s[%d] : erreur undef = %lf\n", nom, expr, valeur); -#endif /* FLG_COLORS */ - } else if (niv_trace >= niv) { -#ifdef FLG_COLORS - fprintf(TRACE_FILE, "\033[%d;%dm%s[%d] %s undef\033[0m\n", - color, typo, nom, expr, chaine); -#else - fprintf(TRACE_FILE, "%s[%d] %s undef\n", nom, expr, chaine); -#endif /* FLG_COLORS */ - } - } else if (def != 1) { -#ifdef FLG_COLORS - fprintf(TRACE_FILE, "\033[%d;%dm%s[%d] : erreur flag def = %d\033[0m\n", - color, typo, nom, expr, def); -#else - fprintf(TRACE_FILE, "%s[%d] : erreur flag def = %d\n", nom, expr, def); -#endif /* FLG_COLORS */ - } else if (niv_trace >= niv) { -#ifdef FLG_COLORS - fprintf(TRACE_FILE, "\033[%d;%dm%s[%d] %s %lf\033[0m\n", - color, typo, nom, expr, chaine, valeur); -#else - fprintf(TRACE_FILE, "%s[%d] %s %lf\n", nom, expr, chaine, valeur); -#endif /* FLG_COLORS */ - } - } else { - if (def == 0) { - if (valeur != 0) { -#ifdef FLG_COLORS - fprintf(TRACE_FILE, "\033[%d;%dm%s : erreur undef = %lf\033[0m\n", - color, typo, nom, valeur); -#else - fprintf(TRACE_FILE, "%s : erreur undef = %lf\n", nom, valeur); -#endif /* FLG_COLORS */ - } else if (niv_trace >= niv) { -#ifdef FLG_COLORS - fprintf(TRACE_FILE, "\033[%d;%dm%s %s undef\033[0m\n", - color, typo, nom, chaine); -#else - fprintf(TRACE_FILE, "%s %s undef\n", nom, chaine); -#endif /* FLG_COLORS */ - } - } else if (def != 1) { -#ifdef FLG_COLORS - fprintf(TRACE_FILE, "\033[%d;%dm%s : erreur flag def = %d\033[0m\n", - color, typo, nom, def); -#else - fprintf(TRACE_FILE, "%s : erreur flag def = %d\n", nom, def); -#endif /* FLG_COLORS */ - } else if (niv_trace >= niv) { -#ifdef FLG_COLORS - fprintf(TRACE_FILE, "\033[%d;%dm%s %s %lf\033[0m\n", - color, typo, nom, chaine, valeur); -#else - fprintf(TRACE_FILE, "%s %s %lf\n", nom, chaine, valeur); -#endif /* FLG_COLORS */ - } +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; } -#endif /* FLG_TRACE */ - T_discord *no_error(T_irdata *irdata) { return NULL; } -int multimax_def(int nbopd, char *var) { - int i = 0; - for (i = 0; i < nbopd; i++) { - if (var[i] == 1) return 1; - } - return 0; -} - -double multimax(double nbopd, double *var) { - int i = 0; - double s = 0.0; - for (i = 0; i < (int)nbopd; i++) { - if (var[i] >= s) s = var[i]; +int multimax_varinfo( + T_irdata *irdata, T_varinfo *info, + char nb_def, double nb_val, + char *res_def, double *res_val +) { + int i; + int nb = (int)nb_val; + char def; + double val; + *res_def = 0; + *res_val = 0.0; + if (irdata == NULL || info == NULL || info->tab_idx < 0 || nb_def == 0) return *res_def; + for (i = 0; i < nb && i < info->size; i++) { + lis_tabaccess(irdata, info->tab_idx, 1, (double)i, &def, &val); + if (def == 1) *res_def = 1; + if (val >= *res_val) *res_val = val; } - return s; + return *res_def; } int modulo_def(int a, int b) { @@ -1018,13 +1100,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 + Pp.fpr fmt " dst->field_%s_var = src->field_%s_var;\n" f f + else ( + Pp.fpr fmt " dst->field_%s_def = src->field_%s_def;\n" f f; + Pp.fpr fmt " dst->field_%s_val = src->field_%s_val;\n" f f)) + cprog.program_event_fields; + Pp.fpr 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); @@ -1033,7 +1148,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; @@ -1129,16 +1244,31 @@ void init_saisie(T_irdata *irdata) { init_tab(irdata->def_saisie, irdata->saisie, TAILLE_SAISIE); } +void init_saisie_espace(char *def, double *val) { + if (def == NULL || val == NULL) return; + init_tab(def, val, TAILLE_SAISIE); +} + void init_calculee(T_irdata *irdata) { if (irdata == NULL) return; init_tab(irdata->def_calculee, irdata->calculee, TAILLE_CALCULEE); } +void init_calculee_espace(char *def, double *val) { + if (def == NULL || val == NULL) return; + init_tab(def, val, TAILLE_CALCULEE); +} + void init_base(T_irdata *irdata) { if (irdata == NULL) return; init_tab(irdata->def_base, irdata->base, TAILLE_BASE); } +void init_base_espace(char *def, double *val) { + if (def == NULL || val == NULL) return; + init_tab(def, val, TAILLE_BASE); +} + void init_erreur(T_irdata *irdata) { if (irdata == NULL) return; irdata->discords = NULL; @@ -1151,22 +1281,63 @@ void init_erreur(T_irdata *irdata) { void detruis_irdata(T_irdata *irdata) { if (irdata == NULL) return; - if (irdata->saisie != NULL) free(irdata->saisie); - if (irdata->def_saisie != NULL) free(irdata->def_saisie); - if (irdata->calculee != NULL) free(irdata->calculee); - if (irdata->def_calculee != NULL) free(irdata->def_calculee); - if (irdata->base != NULL) free(irdata->base); - if (irdata->def_base != NULL) free(irdata->def_base); + irdata->def_saisie = NULL; + irdata->saisie = NULL; + irdata->def_calculee = NULL; + irdata->calculee = NULL; + irdata->def_base = NULL; + irdata->base = NULL; +|}; + IntMap.iter + (fun _ (vsd : Com.variable_space) -> + let sp = Pos.unmark vsd.vs_name in + Com.CatVar.LocMap.iter + (fun loc _ -> + match loc with + | Com.CatVar.LocInput -> + Pp.fpr fmt + " if (irdata->def_saisie_%s != NULL) \ + free(irdata->def_saisie_%s);@\n" + sp sp; + Pp.fpr fmt + " if (irdata->saisie_%s != NULL) free(irdata->saisie_%s);@\n" + sp sp + | Com.CatVar.LocComputed -> + Pp.fpr fmt + " if (irdata->def_calculee_%s != NULL) \ + free(irdata->def_calculee_%s);@\n" + sp sp; + Pp.fpr fmt + " if (irdata->calculee_%s != NULL) free(irdata->calculee_%s);@\n" + sp sp + | Com.CatVar.LocBase -> + Pp.fpr fmt + " if (irdata->def_base_%s != NULL) free(irdata->def_base_%s);@\n" + sp sp; + Pp.fpr fmt + " if (irdata->base_%s != NULL) free(irdata->base_%s);@\n" sp sp) + vsd.vs_cats) + cprog.program_var_spaces_idx; + Pp.fpr fmt + {| if (irdata->tmps != NULL) free(irdata->tmps); if (irdata->def_tmps != NULL) free(irdata->def_tmps); if (irdata->info_tmps != NULL) free(irdata->info_tmps); if (irdata->ref != NULL) free(irdata->ref); if (irdata->def_ref != NULL) free(irdata->def_ref); + if (irdata->ref_name != NULL) free(irdata->ref_name); if (irdata->info_ref != NULL) free(irdata->info_ref); init_erreur(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); } @@ -1175,33 +1346,47 @@ T_irdata *cree_irdata(void) { irdata = (T_irdata *)malloc(sizeof (T_irdata)); if (irdata == NULL) return NULL; - irdata->saisie = NULL; - irdata->def_saisie = NULL; - if (TAILLE_SAISIE > 0) { - irdata->saisie = (double *)malloc(TAILLE_SAISIE * sizeof (double)); - if (irdata->saisie == NULL) goto erreur_cree_irdata; - irdata->def_saisie = (char *)malloc(TAILLE_SAISIE * sizeof (char)); - if (irdata->def_saisie == NULL) goto erreur_cree_irdata; - } - init_saisie(irdata); - irdata->calculee = NULL; - irdata->def_calculee = NULL; - if (TAILLE_CALCULEE > 0) { - irdata->calculee = (double *)malloc(TAILLE_CALCULEE * sizeof (double)); - if (irdata->calculee == NULL) goto erreur_cree_irdata; - irdata->def_calculee = (char *)malloc(TAILLE_CALCULEE * sizeof (char)); - if (irdata->def_calculee == NULL) goto erreur_cree_irdata; - } - init_calculee(irdata); - irdata->base = NULL; - irdata->def_base = NULL; - if (TAILLE_BASE > 0) { - irdata->base = (double *)malloc(TAILLE_BASE * sizeof (double)); - if (irdata->base == NULL) goto erreur_cree_irdata; - irdata->def_base = (char *)malloc(TAILLE_BASE * sizeof (char)); - if (irdata->def_base == NULL) goto erreur_cree_irdata; - } - init_base(irdata); +|}; + IntMap.iter + (fun _ (vsd : Com.variable_space) -> + let sp = Pos.unmark vsd.vs_name in + Com.CatVar.LocMap.iter + (fun loc _ -> + let init_loc loc_str nb_str = + Pp.fpr fmt " irdata->def_%s_%s = NULL;@\n" loc_str sp; + Pp.fpr fmt " irdata->%s_%s = NULL;@\n" loc_str sp; + Pp.fpr fmt " if (TAILLE_%s > 0) {@\n" nb_str; + Pp.fpr fmt + " irdata->def_%s_%s = (char *)malloc(TAILLE_%s * sizeof \ + (char));@\n" + loc_str sp nb_str; + Pp.fpr fmt + " if (irdata->def_%s_%s == NULL) goto erreur_cree_irdata;@\n" + loc_str sp; + Pp.fpr fmt + " irdata->%s_%s = (double *)malloc(TAILLE_%s * sizeof \ + (double));@\n" + loc_str sp nb_str; + Pp.fpr fmt + " if (irdata->%s_%s == NULL) goto erreur_cree_irdata;@\n" + loc_str sp; + Pp.fpr fmt + " init_%s_espace(irdata->def_%s_%s, irdata->%s_%s);@\n" loc_str + loc_str sp loc_str sp; + Pp.fpr fmt " }@\n"; + if vsd.vs_by_default then ( + Pp.fpr fmt " irdata->def_%s = irdata->def_%s_%s;@\n" loc_str + loc_str sp; + Pp.fpr fmt " irdata->%s = irdata->%s_%s;@\n" loc_str loc_str sp) + in + match loc with + | Com.CatVar.LocInput -> init_loc "saisie" "SAISIE" + | Com.CatVar.LocComputed -> init_loc "calculee" "CALCULEE" + | Com.CatVar.LocBase -> init_loc "base" "BASE") + vsd.vs_cats) + cprog.program_var_spaces_idx; + Pp.fpr fmt "%s" + {| irdata->tmps = NULL; irdata->def_tmps = NULL; irdata->info_tmps = NULL; @@ -1210,22 +1395,27 @@ T_irdata *cree_irdata(void) { if (irdata->tmps == NULL) goto erreur_cree_irdata; irdata->def_tmps = (char *)malloc(TAILLE_TMP_VARS * sizeof (char)); if (irdata->def_tmps == NULL) goto erreur_cree_irdata; - irdata->info_tmps = (T_varinfo *)malloc(TAILLE_TMP_VARS * sizeof (T_varinfo)); + irdata->info_tmps = (T_varinfo **)malloc(TAILLE_TMP_VARS * sizeof (T_varinfo *)); if (irdata->info_tmps == NULL) goto erreur_cree_irdata; } irdata->ref = NULL; irdata->def_ref = NULL; + irdata->ref_name = NULL; irdata->info_ref = NULL; if (TAILLE_REFS > 0) { irdata->ref = (double **)malloc(TAILLE_REFS * (sizeof (double *))); if (irdata->ref == NULL) goto erreur_cree_irdata; irdata->def_ref = (char **)malloc(TAILLE_REFS * (sizeof (char *))); if (irdata->def_ref == NULL) goto erreur_cree_irdata; + irdata->ref_name = (char **)malloc(TAILLE_REFS * (sizeof (char *))); + if (irdata->ref_name == NULL) goto erreur_cree_irdata; irdata->info_ref = (T_varinfo **)malloc(TAILLE_REFS * (sizeof (T_varinfo *))); if (irdata->info_ref == NULL) goto erreur_cree_irdata; } irdata->tmps_org = 0; + irdata->nb_tmps_target = 0; irdata->ref_org = 0; + irdata->nb_refs_target = 0; irdata->keep_discords = NULL; irdata->discords = NULL; irdata->sz_err_finalise = 0; @@ -1238,6 +1428,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; @@ -1425,12 +1617,62 @@ 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; +} + +char *concat_nom_index(char *nom, const char *fmt, char def, double val) { + char *res; + int sz = 0; + int szNom, szFmt; + int idx = (int)val; + int j, k; + if (nom == NULL || fmt == NULL || def == 0 || idx < 0) return NULL; + j = idx; + while (j > 0) { + j = j / 10; + sz++; + } + szNom = strlen(nom); + szFmt = strlen(fmt); + sz = szNom + (szFmt > sz ? szFmt : sz); + res = (char *)malloc((sz + 1) * (sizeof (char))); + res[sz] = 0; + for (k = 0; k < szNom; k++) { + res[k] = nom[k]; + } + for (k = 0; k < szFmt; k++) { + res[szNom + k] = fmt[k]; + } + j = idx; + k = sz - 1; + while (j > 0) { + switch (j % 10) { + case 0: res[k] = '0'; break; + case 1: res[k] = '1'; break; + case 2: res[k] = '2'; break; + case 3: res[k] = '3'; break; + case 4: res[k] = '4'; break; + case 5: res[k] = '5'; break; + case 6: res[k] = '6'; break; + case 7: res[k] = '7'; break; + case 8: res[k] = '8'; break; + case 9: res[k] = '9'; break; + } + k--; + j = j / 10; + } + return res; +} + T_varinfo *cherche_varinfo(T_irdata *irdata, const char *nom) { T_varinfo_map *map = NULL; int res = -1; int inf = 0; int sup = NB_variable + NB_saisie; int millieu = 0; + int i; if (irdata == NULL || nom == NULL) return NULL; while ((res != 0) && (inf < sup)) { @@ -1446,34 +1688,86 @@ T_varinfo *cherche_varinfo(T_irdata *irdata, const char *nom) { if (res == 0) { return map->info; } + for (i = 1; i <= irdata->nb_tmps_target; i++) { + T_varinfo *info = irdata->info_tmps[irdata->tmps_org - i]; + if (info != NULL && strcmp(nom, info->name) == 0) { + return info; + } + } + for (i = 1; i <= irdata->nb_refs_target; i++) { + char *ref_name = irdata->ref_name[irdata->ref_org - i]; + if (strcmp(nom, ref_name) == 0) { + return irdata->info_ref[irdata->ref_org - i]; + } + } return NULL; } -char lis_varinfo_def(T_irdata *irdata, T_varinfo *info) { - if (irdata == NULL || info == NULL) return 0; +char lis_varinfo( + T_irdata *irdata, + T_varinfo *info, + char *res_def, double *res_val +) { + *res_def = 0; + *res_val = 0.0; + if (irdata == NULL || info == NULL) return *res_def; switch (info->loc_cat) { case EST_SAISIE: - return irdata->def_saisie[info->idx]; + *res_def = irdata->def_saisie[info->idx]; + *res_val = irdata->saisie[info->idx]; + return *res_def; case EST_CALCULEE: - return irdata->def_calculee[info->idx]; + *res_def = irdata->def_calculee[info->idx]; + *res_val = irdata->calculee[info->idx]; + return *res_def; case EST_BASE: - return irdata->def_base[info->idx]; + *res_def = irdata->def_base[info->idx]; + *res_val = irdata->base[info->idx]; + return *res_def; + case EST_TEMPORAIRE: + *res_def = irdata->def_tmps[irdata->tmps_org + info->idx]; + *res_val = irdata->tmps[irdata->tmps_org + info->idx]; + return *res_def; default: - return 0; + return *res_def; } } -double lis_varinfo_val(T_irdata *irdata, T_varinfo *info) { - if (irdata == NULL || info == NULL) return 0.0; +char lis_varinfo_tab( + T_irdata *irdata, + int idx_tab, char idx_def, double idx_val, + char *res_def, double *res_val +) { + int idx = (int)idx_val; + T_varinfo *info = NULL; + *res_def = 0; + *res_val = 0.0; + if (irdata == NULL || idx_tab < 0 || TAILLE_TAB_VARINFO <= idx_tab) return *res_def; + info = tab_varinfo[idx_tab]; + if (info == NULL || idx_def == 0 || info->size <= idx) return *res_def; + if (idx <= 0) { + *res_def = 1; + return *res_def; + } switch (info->loc_cat) { case EST_SAISIE: - return irdata->saisie[info->idx]; + *res_def = irdata->def_saisie[info->idx + idx]; + *res_val = irdata->saisie[info->idx + idx]; + return *res_def; case EST_CALCULEE: - return irdata->calculee[info->idx]; + *res_def = irdata->def_calculee[info->idx + idx]; + *res_val = irdata->calculee[info->idx + idx]; + return *res_def; case EST_BASE: - return irdata->base[info->idx]; + *res_def = irdata->def_base[info->idx + idx]; + *res_val = irdata->base[info->idx + idx]; + return *res_def; + case EST_TEMPORAIRE: + *res_def = irdata->def_tmps[irdata->tmps_org + info->idx + idx]; + *res_val = irdata->tmps[irdata->tmps_org + info->idx + idx]; + return *res_def; default: - return 0.0; + return *res_def; } } @@ -1487,25 +1781,13 @@ char lis_varinfo_tab_def(T_irdata *irdata, T_varinfo *info, int idx) { return irdata->def_calculee[info->idx + idx]; case EST_BASE: return irdata->def_base[info->idx + idx]; + case EST_TEMPORAIRE: + return irdata->def_tmps[irdata->tmps_org + info->idx + idx]; default: return 0; } } -double lis_varinfo_tab_val(T_irdata *irdata, T_varinfo *info, int idx) { - if (irdata == NULL || info == NULL || idx < 0 || info->size <= idx) return 0.0; - switch (info->loc_cat) { - case EST_SAISIE: - return irdata->saisie[info->idx + idx]; - case EST_CALCULEE: - return irdata->calculee[info->idx + idx]; - case EST_BASE: - return irdata->base[info->idx + idx]; - default: - return 0.0; - } -} - void ecris_varinfo(T_irdata *irdata, T_varinfo *info, char def, double val) { if (irdata == NULL || info == NULL) return; if (def == 0) { @@ -1526,16 +1808,25 @@ void ecris_varinfo(T_irdata *irdata, T_varinfo *info, char def, double val) { irdata->def_base[info->idx] = def; irdata->base[info->idx] = val; return; + case EST_TEMPORAIRE: + irdata->def_tmps[irdata->tmps_org + info->idx] = def; + irdata->tmps[irdata->tmps_org + info->idx] = val; + return; default: return; } } -void ecris_varinfo_tab(T_irdata *irdata, T_varinfo *info, int idx, char def, double val) { - int var_idx = 0; - - if (irdata == NULL || info == NULL || idx < 0 || info->size <= idx) return; - var_idx = info->idx + idx; +void ecris_varinfo_tab( + T_irdata *irdata, + int idx_tab, int idx_def, double idx_val, + char def, double val +) { + int idx = (int)idx_val; + T_varinfo *info = NULL; + if (irdata == NULL || idx_tab < 0 || TAILLE_TAB_VARINFO <= idx_tab) return; + info = tab_varinfo[idx_tab]; + if (info == NULL || idx_def == 0 || idx < 0 || info->size <= idx) return; if (def == 0) { val = 0.0; } else { @@ -1543,35 +1834,132 @@ void ecris_varinfo_tab(T_irdata *irdata, T_varinfo *info, int idx, char def, dou } switch (info->loc_cat) { case EST_SAISIE: - irdata->def_saisie[var_idx] = def; - irdata->saisie[var_idx] = val; + irdata->def_saisie[info->idx + idx] = def; + irdata->saisie[info->idx + idx] = val; return; case EST_CALCULEE: - irdata->def_calculee[var_idx] = def; - irdata->calculee[var_idx] = val; + irdata->def_calculee[info->idx + idx] = def; + irdata->calculee[info->idx + idx] = val; return; case EST_BASE: - irdata->def_base[var_idx] = def; - irdata->base[var_idx] = val; + irdata->def_base[info->idx + idx] = def; + irdata->base[info->idx + idx] = val; + return; + case EST_TEMPORAIRE: + irdata->def_tmps[irdata->tmps_org + info->idx + idx] = def; + irdata->tmps[irdata->tmps_org + info->idx + idx] = val; return; default: return; } } +T_varinfo *lis_tabaccess_varinfo( + T_irdata *irdata, int idx_tab, + char idx_def, double idx_val +) { + T_varinfo *info = NULL; + int idx = (int)idx_val; + if (irdata == NULL || idx_tab < 0 || TAILLE_TAB_VARINFO <= idx_tab) return NULL; + info = tab_varinfo[idx_tab]; + if (idx_def == 0 || idx < 0 || info->size <= idx) return NULL; + return tab_varinfo[idx_tab + idx + 1]; +} + +char lis_tabaccess( + T_irdata *irdata, int idx_tab, + char idx_def, double idx_val, + char *res_def, double *res_val +) { + T_varinfo *info = lis_tabaccess_varinfo(irdata, idx_tab, idx_def, idx_val); + int idx = 0; + if (info == NULL) { + *res_val = 0.0; + if ( + irdata != NULL && 0 <= idx_tab && idx_tab < TAILLE_TAB_VARINFO + && idx_def == 1 && ((int)idx_val) < 0 + ) { + *res_def = 1; + } else { + *res_def = 0; + } + return *res_def; + } + lis_varinfo(irdata, info, res_def, res_val); + /* tableau originel */ + { + char res2_def; + double res2_val; + lis_varinfo_tab(irdata, idx_tab, idx_def, idx_val, &res2_def, &res2_val); + if (*res_def != res2_def || *res_val != res2_val) { + *res_def = res2_def; + *res_val = res2_val; + ecris_varinfo(irdata, info, *res_def, *res_val); + } + } + return *res_def; +} + +void ecris_tabaccess( + T_irdata *irdata, int idx_tab, + char idx_def, double idx_val, + char def, double val +) { + T_varinfo *info = lis_tabaccess_varinfo(irdata, idx_tab, idx_def, idx_val); + ecris_varinfo(irdata, info, def, val); + /* tableau originel */ + ecris_varinfo_tab(irdata, idx_tab, idx_def, idx_val, def, val); +} + +char lis_concaccess( + T_irdata *irdata, + char *nom, const char *fmt, char idx_def, double idx_val, + char *res_def, double *res_val +) { + char *vn = concat_nom_index(nom, fmt, idx_def, idx_val); + T_varinfo *info = cherche_varinfo(irdata, vn); + *res_def = lis_varinfo(irdata, info, res_def, res_val); + free(vn); + return *res_def; +} + +T_varinfo *lis_concaccess_varinfo( + T_irdata *irdata, + char *nom, const char *fmt, char idx_def, double idx_val +) { + char *vn = concat_nom_index(nom, fmt, idx_def, idx_val); + T_varinfo *info = cherche_varinfo(irdata, vn); + free(vn); + return info; +} + +void ecris_concaccess( + T_irdata *irdata, + char *nom, const char *fmt, char idx_def, double idx_val, + char def, double val +) { + char *vn = concat_nom_index(nom, fmt, idx_def, idx_val); + T_varinfo *info = cherche_varinfo(irdata, vn); + free(vn); + ecris_varinfo(irdata, info, def, val); +} + /* !!! */ void pr_var(T_print_context *pr_ctx, T_irdata *irdata, char *nom) { T_varinfo *info = NULL; + char res_def = 0; + double res_val = 0.0; if (pr_ctx == NULL) return; info = cherche_varinfo(irdata, nom); if (info == NULL) { fprintf(pr_ctx->std, "inconnu"); } else { - if (lis_varinfo_def(irdata, info) == 0) { + lis_varinfo(irdata, info, &res_def, &res_val); + if (res_def == 0) { fprintf(pr_ctx->std, "indefini"); } else { - print_double(NULL, pr_ctx, lis_varinfo_val(irdata, info), 0, 30); + print_double(NULL, pr_ctx, res_val, 0, 30); } } } @@ -1585,7 +1973,213 @@ void pr_err_var(T_irdata *irdata, char *nom) { if (irdata == NULL) return; pr_var(&(irdata->ctx_pr_err), irdata, nom); } -|} + +char est_variable(T_varinfo *info, char *nomCmp, char *res_def, double *res_val) { + *res_def = 1; + if (info == NULL || nomCmp == NULL) { + *res_val = 0.0; + return *res_def; + } + if ( + strcmp(info->name, nomCmp) == 0 + || (info->alias != NULL && strcmp(info->alias, nomCmp) == 0) + ) { + *res_val = 1.0; + return *res_def; + } + *res_val = 0.0; + return *res_def; +} + +char est_variable_tabaccess( + T_irdata *irdata, int idx_tab, + char idx_def, double idx_val, + char *nomCmp, char *res_def, double *res_val +) { + T_varinfo *info = lis_tabaccess_varinfo(irdata, idx_tab, idx_def, idx_val); + return est_variable(info, nomCmp, res_def, res_val); +} + +char est_variable_concaccess( + T_irdata *irdata, + char *nom, const char *fmt, char idx_def, double idx_val, + char *nomCmp, char *res_def, double *res_val +) { + T_varinfo *info = lis_concaccess_varinfo(irdata, nom, fmt, idx_def, idx_val); + return est_variable(info, nomCmp, res_def, res_val); +} + +#ifdef FLG_TRACE + +/* int niv_trace = 3; */ + +#ifdef FLG_API +#define TRACE_FILE fd_trace_dialog +#else +#define TRACE_FILE stderr +#endif /* FLG_API */ + +void aff1(nom) +char *nom ; +{ +#ifdef FLG_COLORS +if (niv_trace >= 1) fprintf(stderr, "\033[%d;%dm%s\033[0m", color, typo, nom) ; +#else +if (niv_trace >= 1) fprintf(stderr, "%s \n", nom) ; +#endif +} + +void aff_val( + const char *nom, const T_irdata *irdata, int indice, int niv, + const char *chaine, int is_tab, int expr, int maxi +) { + double valeur; + int def; + if (expr < 0) { + if (niv_trace >= niv) { +#ifdef FLG_COLORS + fprintf(TRACE_FILE, "\033[%d;%dm%s[%d] %s 0\033[0m\n", + color, typo, nom, expr, chaine); +#else + fprintf(TRACE_FILE, "%s[%d] %s 0m\n", nom, expr, chaine); +#endif /* FLG_COLORS */ + } + return; + } else if (expr >= maxi) { +#ifdef FLG_COLORS + fprintf(TRACE_FILE, + "\033[%d;%dmerreur: indice (%d) superieur au maximum (%d)\033[0m\n", + color, typo, expr, maxi); +#else + fprintf(TRACE_FILE, "erreur: indice (%d) superieur au maximum (%d)\n", + expr, maxi); +#endif /* FLG_COLORS */ + expr = 0; + } + switch (indice & EST_MASQUE) { + case EST_SAISIE: + valeur = irdata->saisie[(indice & INDICE_VAL) + expr]; + def = irdata->def_saisie[(indice & INDICE_VAL) + expr]; + break; + case EST_CALCULEE: + valeur = irdata->calculee[(indice & INDICE_VAL) + expr]; + def = irdata->def_calculee[(indice & INDICE_VAL) + expr]; + break; + case EST_BASE: + valeur = irdata->base[(indice & INDICE_VAL) + expr]; + def = irdata->def_base[(indice & INDICE_VAL) + expr]; + break; + case EST_TEMPORAIRE: + valeur = irdata->tmps[irdata->tmps_org - (indice & INDICE_VAL) + expr]; + def = irdata->def_tmps[irdata->tmps_org - (indice & INDICE_VAL) + expr]; + break; + } + if (is_tab) { + if (def == 0) { + if (valeur != 0) { +#ifdef FLG_COLORS + fprintf(TRACE_FILE, "\033[%d;%dm%s[%d] : erreur undef = %lf\033[0m\n", + color, typo, nom, expr, valeur); +#else + fprintf(TRACE_FILE, "%s[%d] : erreur undef = %lf\n", nom, expr, valeur); +#endif /* FLG_COLORS */ + } else if (niv_trace >= niv) { +#ifdef FLG_COLORS + fprintf(TRACE_FILE, "\033[%d;%dm%s[%d] %s undef\033[0m\n", + color, typo, nom, expr, chaine); +#else + fprintf(TRACE_FILE, "%s[%d] %s undef\n", nom, expr, chaine); +#endif /* FLG_COLORS */ + } + } else if (def != 1) { +#ifdef FLG_COLORS + fprintf(TRACE_FILE, "\033[%d;%dm%s[%d] : erreur flag def = %d\033[0m\n", + color, typo, nom, expr, def); +#else + fprintf(TRACE_FILE, "%s[%d] : erreur flag def = %d\n", nom, expr, def); +#endif /* FLG_COLORS */ + } else if (niv_trace >= niv) { +#ifdef FLG_COLORS + fprintf(TRACE_FILE, "\033[%d;%dm%s[%d] %s %lf\033[0m\n", + color, typo, nom, expr, chaine, valeur); +#else + fprintf(TRACE_FILE, "%s[%d] %s %lf\n", nom, expr, chaine, valeur); +#endif /* FLG_COLORS */ + } + } else { + if (def == 0) { + if (valeur != 0) { +#ifdef FLG_COLORS + fprintf(TRACE_FILE, "\033[%d;%dm%s : erreur undef = %lf\033[0m\n", + color, typo, nom, valeur); +#else + fprintf(TRACE_FILE, "%s : erreur undef = %lf\n", nom, valeur); +#endif /* FLG_COLORS */ + } else if (niv_trace >= niv) { +#ifdef FLG_COLORS + fprintf(TRACE_FILE, "\033[%d;%dm%s %s undef\033[0m\n", + color, typo, nom, chaine); +#else + fprintf(TRACE_FILE, "%s %s undef\n", nom, chaine); +#endif /* FLG_COLORS */ + } + } else if (def != 1) { +#ifdef FLG_COLORS + fprintf(TRACE_FILE, "\033[%d;%dm%s : erreur flag def = %d\033[0m\n", + color, typo, nom, def); +#else + fprintf(TRACE_FILE, "%s : erreur flag def = %d\n", nom, def); +#endif /* FLG_COLORS */ + } else if (niv_trace >= niv) { +#ifdef FLG_COLORS + fprintf(TRACE_FILE, "\033[%d;%dm%s %s %lf\033[0m\n", + color, typo, nom, chaine, valeur); +#else + fprintf(TRACE_FILE, "%s %s %lf\n", nom, chaine, valeur); +#endif /* FLG_COLORS */ + } + } +} + +#endif /* FLG_TRACE */ + +|}; + StrMap.iter + (fun f (ef : Com.event_field) -> + 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 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 ( + pr " info = irdata->events[idx]->field_%s_var;\n" f; + pr " lis_varinfo(irdata, info, res_def, res_val);\n") + else ( + 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 + "T_varinfo *event_field_%s_var(T_irdata *irdata, char idx_def, \ + double idx_val) {\n" + f; + 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 irdata->events[idx]->field_%s_var;\n" f; + pr "}\n\n")) + cprog.program_event_fields let generate_auxiliary_files flags (cprog : Mir.program) : unit = Dgfip_compir_files.generate_compir_files flags cprog; @@ -1605,5 +2199,5 @@ let generate_auxiliary_files flags (cprog : Mir.program) : unit = close_out oc; let oc, fmt = open_file "mlang.c" in - gen_mlang_c fmt flags; + gen_mlang_c fmt cprog flags; close_out oc diff --git a/src/mlang/backend_compilers/dgfip_varid.ml b/src/mlang/backend_compilers/dgfip_varid.ml index 4d73354d9..5f7d4f511 100644 --- a/src/mlang/backend_compilers/dgfip_varid.ml +++ b/src/mlang/backend_compilers/dgfip_varid.ml @@ -14,72 +14,97 @@ 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 (vsd : Com.variable_space) (l : Com.loc_tgv) vn = + Pp.spr "D%s(%s,%d/*%s*/)" (gen_tab l.loc_cat) (Pos.unmark vsd.vs_name) + l.loc_idx vn + +let gen_tgv_val (vsd : Com.variable_space) (l : Com.loc_tgv) vn = + Pp.spr "%s(%s,%d/*%s*/)" (gen_tab l.loc_cat) (Pos.unmark vsd.vs_name) + l.loc_idx vn + +let gen_tgv_def_ptr (vsd : Com.variable_space) (l : Com.loc_tgv) vn = + Pp.spr "&(%s)" (gen_tgv_def vsd l vn) + +let gen_tgv_val_ptr (vsd : Com.variable_space) (l : Com.loc_tgv) vn = + Pp.spr "&(%s)" (gen_tgv_val vsd l 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 (l : Com.loc_tmp) vn = Pp.spr "DT_((%d)/*%s*/)" l.loc_idx vn + +let gen_tmp_val (l : Com.loc_tmp) vn = Pp.spr "T_((%d)/*%s*/)" l.loc_idx vn + +let gen_tmp_def_ptr (l : Com.loc_tmp) vn = Pp.spr "&(%s)" (gen_tmp_def l vn) -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_tmp_val_ptr (l : Com.loc_tmp) vn = Pp.spr "&(%s)" (gen_tmp_val l vn) -let gen_tmp pre i vn off = - Printf.sprintf "irdata->%stmps[irdata->tmps_org + (%d)/*%s*/%s]" pre i vn off +let gen_tmp_info_ptr (l : Com.loc_tmp) vn = + Pp.spr "IT_((%d)/*%s*/)" l.loc_idx vn -let gen_tmp_ptr pre i vn = Printf.sprintf "&(%s)" (gen_tmp pre i vn "") +(* reference accessors *) -let gen_ref_ptr pre i vn = - Printf.sprintf "irdata->%sref[irdata->ref_org + (%d)/*%s*/]" pre i vn +let gen_ref_def_ptr i vn = Printf.sprintf "DR_((%d)/*%s*/)" i vn -let gen_ref pre i vn off = Printf.sprintf "*(%s%s)" (gen_ref_ptr pre i vn) off +let gen_ref_val_ptr i vn = Printf.sprintf "R_((%d)/*%s*/)" i vn -let gen_def (v : Com.Var.t) offset = +let gen_ref_info_ptr i vn = Printf.sprintf "IR_((%d)/*%s*/)" i vn + +let gen_ref_def i vn = Pp.spr "*(%s)" (gen_ref_def_ptr i vn) + +let gen_ref_val i vn = Pp.spr "*(%s)" (gen_ref_val_ptr i vn) + +(* generic accessors *) + +let gen_def (vsd : Com.variable_space) (v : Com.Var.t) = 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 vsd l vn + | LocTmp (_, l) -> gen_tmp_def l vn + | LocRef (_, i) -> gen_ref_def i vn -let gen_val (v : Com.Var.t) offset = +let gen_val (vsd : Com.variable_space) (v : Com.Var.t) = 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 vsd l vn + | LocTmp (_, l) -> gen_tmp_val l vn + | LocRef (_, i) -> gen_ref_val i vn 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 - | LocArg _ | LocRes _ -> "NULL" + | LocTgv (_, l) -> gen_tgv_info_ptr l vn + | LocTmp (_, l) -> gen_tmp_info_ptr l vn + | LocRef (_, i) -> gen_ref_info_ptr i vn + +let gen_def_ptr (vsd : Com.variable_space) (v : Com.Var.t) = + let vn = Pos.unmark v.name in + match v.loc with + | LocTgv (_, l) -> gen_tgv_def_ptr vsd l vn + | LocTmp (_, l) -> gen_tmp_def_ptr l vn + | LocRef (_, i) -> gen_ref_def_ptr i vn -let gen_def_ptr (v : Com.Var.t) = +let gen_val_ptr (vsd : Com.variable_space) (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_val_ptr vsd l vn + | LocTmp (_, l) -> gen_tmp_val_ptr l vn + | LocRef (_, i) -> gen_ref_val_ptr i vn -let gen_val_ptr (v : Com.Var.t) = +let gen_ref_name_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" + | LocRef (_, i) -> Printf.sprintf "NR_((%d)/*%s*/)" i vn + | _ -> assert false let gen_pos_from_start (v : Com.Var.t) = let vn = Pos.unmark v.name in @@ -92,16 +117,13 @@ 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 (_, l) -> Pp.spr "EST_TEMPORAIRE | %d" l.loc_idx | 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" 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) - | LocArg _ | LocRes _ -> "1" + | LocTgv _ | LocTmp _ -> Pp.spr "%d" (Com.Var.size v) + | LocRef (_, i) -> Pp.spr "(%s->size)" (gen_ref_info_ptr i vn) diff --git a/src/mlang/dgfip_m.ml b/src/mlang/dgfip_m.ml index a7682f8c1..9e9e6dab0 100644 --- a/src/mlang/dgfip_m.ml +++ b/src/mlang/dgfip_m.ml @@ -59,6 +59,8 @@ variable saisie penalite variable calculee : attribut primrest; + +espace_variables GLOBAL : categorie saisie, calculee, base : par_defaut; |} let rule_domains_declaration = @@ -229,6 +231,20 @@ let declarations = Format.sprintf "%s%s%s" variable_domains_declaration rule_domains_declaration verif_domains_declaration +let event_declaration = + {| +evenement +: valeur numero +: valeur rappel +: variable code +: valeur montant +: valeur sens +: valeur penalite +: valeur base_tl +: valeur date +: valeur 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 c3ea6a278..76dc993d8 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -38,6 +38,53 @@ let process_dgfip_options (backend : string option) end | _ -> Dgfip_options.default_flags +let parse_m_dgfip without_dgfip_m current_progress m_program = + if without_dgfip_m then m_program + else ( + current_progress 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 tgv_decls = internal_command Dgfip_m.declarations in + let event_decl = internal_command Dgfip_m.event_declaration in + tgv_decls :: event_decl :: m_program + with Mparser.Error -> + Errors.raise_error + (Format.sprintf "M\n syntax error in %s" Dgfip_m.internal_m)) + +let parse_m_files current_progress source_files m_program = + List.fold_left + (fun m_program source_file -> + let filebuf, input = + if source_file <> "" then + let input = open_in source_file in + (Lexing.from_channel input, input) + else failwith "You have to specify at least one file!" + in + current_progress source_file; + let filebuf = + { + filebuf with + lex_curr_p = { filebuf.lex_curr_p with pos_fname = source_file }; + } + in + try + let commands = Mparser.source_file token filebuf in + commands :: m_program + with Mparser.Error -> + close_in input; + Errors.raise_spanned_error "M syntax error" + (Parse_utils.mk_position (filebuf.lex_start_p, filebuf.lex_curr_p))) + m_program source_files + (* The legacy compiler plays a nasty trick on us, that we have to reproduce: rule 1 is modified to add assignments to APPLI_XXX variables according to the target application (OCEANS, BATCH and ILIAD). *) @@ -46,21 +93,23 @@ let patch_rule_1 (backend : string option) (dgfip_flags : Dgfip_options.flags) let open Mast in let var_exists name = List.exists - (List.exists (fun (item, _) -> - match item with - | VariableDecl (ComputedVar (cv, _)) -> - Pos.unmark cv.comp_name = name - | VariableDecl (InputVar (iv, _)) -> Pos.unmark iv.input_name = name + (List.exists (fun m_item -> + match Pos.unmark m_item with + | VariableDecl (ComputedVar m_cv) -> + Pos.unmark (Pos.unmark m_cv).comp_name = name + | VariableDecl (InputVar m_iv) -> + Pos.unmark (Pos.unmark m_iv).input_name = name | _ -> false)) program in 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 = + Pos.without (Com.VarAccess (Pos.without (Com.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 - no_pos cmd :: l + let cmd = Com.SingleFormula (VarDecl (m_access, Pos.without litt)) in + Pos.without cmd :: l else l in let oceans, batch, iliad = @@ -70,20 +119,20 @@ let patch_rule_1 (backend : string option) (dgfip_flags : Dgfip_options.flags) | _ -> (false, false, true) in List.map - (List.map (fun item -> - match Pos.unmark item with + (List.map (fun m_item -> + match Pos.unmark m_item with | Rule r when Pos.unmark r.rule_number = 1 -> let fl = List.map - (fun f -> Pos.same_pos_as (Com.Affectation f) f) + (fun f -> Pos.same (Com.Affectation f) f) ([] |> mk_assign "APPLI_OCEANS" oceans |> mk_assign "APPLI_BATCH" batch |> mk_assign "APPLI_ILIAD" iliad) in - ( Rule { r with rule_formulaes = r.rule_formulaes @ fl }, - Pos.get_position item ) - | _ -> item)) + let r' = { r with rule_formulaes = r.rule_formulaes @ fl } in + Pos.same (Rule r') m_item + | _ -> m_item)) program (** Entry function for the executable. Returns a negative number in case of @@ -147,56 +196,24 @@ let driver (files : string list) (application_names : string list) value_sort round_ops; let dgfip_flags = process_dgfip_options backend dgfip_options in try - Cli.debug_print "Reading M files..."; - 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 }; - } - in - try - let commands = Mparser.source_file token filebuf in - m_program := commands :: !m_program - with Mparser.Error -> - Errors.raise_error - (Format.sprintf "M\n syntax error in %s" Dgfip_m.internal_m)); if List.length !Cli.source_files = 0 then Errors.raise_error "please provide at least one M source file"; - List.iter - (fun source_file -> - let filebuf, input = - if source_file <> "" then - let input = open_in source_file in - (Lexing.from_channel input, input) - else failwith "You have to specify at least one file!" - in - current_progress source_file; - let filebuf = - { - filebuf with - lex_curr_p = { filebuf.lex_curr_p with pos_fname = source_file }; - } - in - try - let commands = Mparser.source_file token filebuf in - m_program := commands :: !m_program - with Mparser.Error -> - close_in input; - Errors.raise_spanned_error "M syntax error" - (Parse_utils.mk_position (filebuf.lex_start_p, filebuf.lex_curr_p))) - !Cli.source_files; - m_program := List.rev !m_program; - m_program := patch_rule_1 backend dgfip_flags !m_program; + Cli.debug_print "Reading M files..."; + let current_progress, finish = Cli.create_progress_bar "Parsing" in + let m_program = + [] + |> parse_m_dgfip without_dgfip_m current_progress + |> parse_m_files current_progress !Cli.source_files + |> List.rev + |> patch_rule_1 backend dgfip_flags + in finish "completed!"; Cli.debug_print "Elaborating..."; - let m_program = Mast_to_mir.translate !m_program mpp_function in - let m_program = Mir.expand_functions m_program in + let m_program = + m_program |> Expander.proceed + |> Validator.proceed mpp_function + |> Mast_to_mir.translate |> Mir.expand_functions + in Cli.debug_print "Creating combined program suitable for execution..."; if run_all_tests <> None then let tests : string = @@ -214,8 +231,7 @@ let driver (files : string list) (application_names : string list) let test : string = match run_test with Some s -> s | _ -> assert false in - ignore (Test_interpreter.check_test m_program test value_sort round_ops); - Cli.result_print "Test passed!" + Test_interpreter.check_one_test m_program test value_sort round_ops end else begin Cli.debug_print diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml deleted file mode 100644 index f6dcf7cdc..000000000 --- a/src/mlang/m_frontend/check_validity.ml +++ /dev/null @@ -1,2674 +0,0 @@ -(*This program is free software: you can redistribute it and/or modify it under - the terms of the GNU General Public License as published by the Free Software - Foundation, either version 3 of the License, or (at your option) any later - version. - - This program is distributed in the hope that it will be useful, but WITHOUT - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS - FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. - - You should have received a copy of the GNU General Public License along with - this program. If not, see . *) - -type rule_or_verif = Rule | Verif - -type rdom_or_chain = RuleDomain of Com.DomainId.t | Chaining of string - -module MarkedVarNames = struct - type t = string Pos.marked - - let compare a b = compare (Pos.unmark a) (Pos.unmark b) - - let pp_marked fmt elt = Format.fprintf fmt "%s" (Pos.unmark elt) - - module Set = struct - include SetExt.Make (struct - type nonrec t = t - - let compare = compare - end) - - let pp ?(sep = ", ") ?(pp_elt = pp_marked) (_ : unit) - (fmt : Format.formatter) (set : t) : unit = - pp ~sep ~pp_elt () fmt set - end - - module Map = struct - include MapExt.Make (struct - type nonrec t = t - - let compare = compare - end) - - let pp ?(sep = "; ") ?(pp_key = pp_marked) ?(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 -(* Ideally we could use Com.Var.{Set,Map} instead (which also carries pos information, and would allow us to not duplicate too many structures), - but we check some properties before translating Mast variables to Com variables *) - -module Err = struct - let rov_to_str rov = match rov with Rule -> "rule" | Verif -> "verif" - - let attribute_already_declared attr old_pos pos = - let msg = - Format.asprintf - "attribute \"%s\" declared more than once: already declared %a" attr - Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - - let var_category_already_definied cat old_pos pos = - let msg = - Format.asprintf - "Category \"%a\" defined more than once: already defined %a" - Com.CatVar.pp cat Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - - let attribute_already_defined attr old_pos pos = - let msg = - Format.asprintf - "attribute \"%s\" defined more than once: already defined %a" attr - Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - - let variable_of_unknown_category cat name_pos = - let msg = - Format.asprintf "variable with unknown category %a" Com.CatVar.pp cat - in - Errors.raise_spanned_error msg name_pos - - let attribute_is_not_defined name attr pos = - let msg = - Format.asprintf "variable \"%s\" has no attribute \"%s\"" name attr - in - Errors.raise_spanned_error msg pos - - let alias_already_declared alias old_pos pos = - let msg = - Format.asprintf - "alias \"%s\" declared more than once: already declared %a" alias - Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - - let variable_already_declared name old_pos pos = - let msg = - Format.asprintf - "variable \"%s\" declared more than once: already declared %a" name - Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - - let error_already_declared name old_pos pos = - let msg = - Format.asprintf - "error \"%s\" declared more than once: already declared %a" name - Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - - let domain_already_declared rov old_pos pos = - let msg = - Format.asprintf "%s domain declared more than once: already declared %a" - (rov_to_str rov) Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - - let default_domain_already_declared rov old_pos pos = - let msg = - Format.asprintf - "default %s domain declared more than once: already declared %a" - (rov_to_str rov) Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - - let no_default_domain rov = - let msg = - Format.asprintf "there are no default %s domain" (rov_to_str rov) - in - Errors.raise_error msg - - let loop_in_domains rov cycle = - let pp_cycle fmt cycle = - let foldCycle first id = - if first then Format.fprintf fmt "%a@;" (Com.DomainId.pp ()) id - else Format.fprintf fmt "-> %a@;" (Com.DomainId.pp ()) id; - false - in - ignore (List.fold_left foldCycle true cycle) - in - let msg = - Format.asprintf "there is a loop in the %s domain hierarchy@;@[%a@]" - (rov_to_str rov) pp_cycle cycle - in - Errors.raise_error msg - - let domain_specialize_itself rov dom_id pos = - let msg = - Format.asprintf "%s domain \"%a\" specialize itself" (rov_to_str rov) - (Com.DomainId.pp ()) dom_id - in - Errors.raise_spanned_error msg pos - - let target_already_declared name old_pos pos = - let msg = - Format.asprintf - "target \"%s\" declared more than once: already declared %a" name - Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - - let unknown_variable var_name pos = - let msg = Format.asprintf "unknown variable \"%s\"" var_name in - Errors.raise_spanned_error msg pos - - let variable_used_as_table decl_pos pos = - let msg = - Format.asprintf "variable used as a table, declared %a" - Pos.format_position decl_pos - in - Errors.raise_spanned_error msg pos - - let table_used_as_variable decl_pos pos = - let msg = - Format.asprintf "table used as a variable, declared %a" - Pos.format_position decl_pos - in - Errors.raise_spanned_error msg pos - - let unknown_attribut_for_var cat pos = - let msg = - Format.asprintf "unknown attribute for a variable of category \"%a\"" - Com.CatVar.pp cat - in - Errors.raise_spanned_error msg pos - - let tmp_vars_have_no_attrs name pos = - let msg = - Format.asprintf "temporary variable \"%s\" should have no attributes" name - in - Errors.raise_spanned_error msg pos - - let unknown_variable_category (cv : Com.CatVar.t) pos = - let msg = - Format.asprintf "unknown variable category \"%a\"" Com.CatVar.pp cv - in - Errors.raise_spanned_error msg pos - - let instruction_forbidden_in_rules pos = - Errors.raise_spanned_error "instruction forbidden in rules" pos - - let unknown_domain rov pos = - let msg = Format.asprintf "unknown %s domain" (rov_to_str rov) in - Errors.raise_spanned_error msg pos - - let unknown_chaining chaining pos = - let msg = Format.asprintf "unknown chaining \"%s\"" chaining in - Errors.raise_spanned_error msg pos - - let rule_domain_not_computable l pos = - let msg = - Format.asprintf "rule domain \"%a\" not computable" - (Format.pp_print_list (fun fmt s -> - Format.fprintf fmt "%s" (Pos.unmark s))) - l - in - Errors.raise_spanned_error msg pos - - let verif_domain_not_verifiable l pos = - let msg = - Format.asprintf "verif domain \"%a\" not verifiable" - (Format.pp_print_list (fun fmt s -> - Format.fprintf fmt "%s" (Pos.unmark s))) - l - in - Errors.raise_spanned_error msg pos - - let rov_already_defined rov rov_id old_pos pos = - let msg = - Format.asprintf "%s %d defined more than once: already defined %a" - (rov_to_str rov) rov_id Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - - let multimax_require_two_args pos = - Errors.raise_spanned_error "function multimax require two arguments" pos - - let second_arg_of_multimax pos = - Errors.raise_spanned_error - "second argument of function multimax must be a variable name" pos - - let loop_in_rules rdom_chain cycle = - let rdom_chain_str = - match rdom_chain with - | RuleDomain rdom_id -> - Format.asprintf "rule domain \"%a\"" (Com.DomainId.pp ()) rdom_id - | Chaining ch -> Format.sprintf "chaining \"%s\"" ch - in - let pp_cycle fmt cycle = - let rec aux first cycle = - match cycle with - | [] -> () - | (v, Some e) :: tl -> - if first then Format.fprintf fmt "rule %d\n" v - else Format.fprintf fmt " -(%s)-> rule %d\n" (Pos.unmark e) v; - aux false tl - | (v, None) :: tl -> - if first then Format.fprintf fmt "rule %d\n" v - else Format.fprintf fmt " -()-> rule %d\n" v; - aux false tl - in - aux true cycle - in - let msg = - Format.asprintf "there is a loop in rules of %s:\n%a" rdom_chain_str - pp_cycle cycle - in - Errors.raise_error msg - - let rule_domain_incompatible_with_chaining ch_name pos = - let msg = - Format.asprintf "rule domain incompatible with chaining \"%s\"" ch_name - in - Errors.raise_spanned_error msg pos - - let domain_already_used rov dom_pos pos = - let msg = - Format.asprintf "domain of this %s already used %a" (rov_to_str rov) - Pos.format_position dom_pos - in - Errors.raise_spanned_error msg pos - - let unknown_error err_name pos = - let msg = Format.asprintf "unknown error \"%s\"" err_name in - Errors.raise_spanned_error msg pos - - let variable_forbidden_in_filter var pos = - let msg = - Format.asprintf "variables (here, \"%s\") are forbidden in verif filters" - (Mast.get_variable_name var) - in - Errors.raise_spanned_error msg pos - - let forbidden_expresion_in_filter pos = - Errors.raise_spanned_error "forbidden expression in verif filter" pos - - let expression_only_in_filter pos = - Errors.raise_spanned_error "expression authorized only in verif filters" pos - - let wrong_interval_bounds min max pos = - let msg = - Format.asprintf "wrong interval bounds (%d should not be greater than %d)" - min max - in - Errors.raise_spanned_error msg pos - - let wrong_arity_of_function func_name arity pos = - let msg = - Format.asprintf "wrong arity: function \"%a\" expect %d argument%s" - Com.format_func func_name arity - (if arity = 1 then "" else "s") - in - Errors.raise_spanned_error msg pos - - let variable_with_forbidden_category pos = - let msg = Format.sprintf "variable with forbidden category in verif" in - Errors.raise_spanned_error msg pos - - let variable_already_specified name old_pos pos = - let msg = - Format.asprintf - "variable \"%s\" specified more than once: already specified %a" name - Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - - let main_target_not_found main_target = - Errors.raise_error - (Format.sprintf "main target \"%s\" not found" main_target) - - let unknown_target name pos = - let msg = Format.asprintf "unknown target %s" name in - Errors.raise_spanned_error msg pos - - let wrong_number_of_args nb_args pos = - let msg = - Format.asprintf "wrong number of arguments, %d required" nb_args - in - Errors.raise_spanned_error msg pos - - let target_must_not_have_a_result tn pos = - let msg = Format.sprintf "target %s must not have a result" tn in - Errors.raise_spanned_error msg pos - - let function_result_missing fn pos = - let msg = Format.sprintf "result missing in function %s" 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 - in - Errors.raise_spanned_error msg pos - - let function_does_not_exist fn pos = - let msg = Format.sprintf "function %s does not exist" fn in - Errors.raise_spanned_error msg pos - - 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 -end - -type syms = Com.DomainId.t Pos.marked Com.DomainIdMap.t - -type 'a doms = 'a Com.domain Com.DomainIdMap.t - -type chaining = { - chain_name : string Pos.marked; - chain_apps : Pos.t StrMap.t; - chain_rules : Com.rule_domain Pos.marked IntMap.t; -} - -type rule = { - rule_id : int Pos.marked; - rule_apps : Pos.t StrMap.t; - rule_domain : Com.rule_domain; - rule_chains : Pos.t StrMap.t; - rule_tmp_vars : - (MarkedVarNames.t * Mast.table_size Pos.marked option) StrMap.t; - rule_instrs : Mast.instruction Pos.marked list; - rule_in_vars : MarkedVarNames.Set.t; - rule_out_vars : MarkedVarNames.Set.t; - rule_seq : int; -} - -type verif = { - verif_id : int Pos.marked; - verif_apps : Pos.t StrMap.t; - verif_domain : Com.verif_domain; - verif_expr : Mast.expression Pos.marked; - verif_error : Mast.error_name Pos.marked; - verif_var : Mast.variable_name Pos.marked option; - verif_is_blocking : bool; - verif_cat_var_stats : int Com.CatVar.Map.t; - verif_var_stats : int StrMap.t; - verif_seq : int; -} - -type program = { - prog_prefix : string; - prog_seq : int; - prog_app : Pos.t StrMap.t; - prog_apps : Pos.t StrMap.t; - 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_errors : Com.Error.t StrMap.t; - prog_rdoms : Com.rule_domain_data doms; - prog_rdom_syms : syms; - prog_vdoms : Com.verif_domain_data doms; - prog_vdom_syms : syms; - prog_functions : Mast.target StrMap.t; - prog_rules : rule IntMap.t; - prog_rdom_calls : (int Pos.marked * Com.DomainId.t) StrMap.t; - prog_verifs : verif IntMap.t; - prog_vdom_calls : - (int Pos.marked * Com.DomainId.t * Mast.expression Pos.marked) StrMap.t; - prog_targets : Mast.target StrMap.t; - prog_main_target : string; - 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 = - try Filename.chop_extension file with Invalid_argument _ -> file - in - Format.sprintf "m_%s" file - -let safe_prefix (p : Mast.program) : string = - let target_names = - List.fold_left - (fun names source_file -> - List.fold_left - (fun names (item, _pos) -> - match item with - | Mast.Target t -> Pos.unmark t.Mast.target_name :: names - | _ -> names) - names source_file) - [] p - in - let sorted_names = - List.sort - (fun x0 x1 -> - let cmp = compare (String.length x1) (String.length x0) in - if cmp = 0 then compare x0 x1 else cmp) - target_names - in - let buf = Buffer.create 16 in - let starts_with p s = - let lp = String.length p in - let ls = String.length s in - let rec aux i = i = lp || (p.[i] = s.[i] && aux (i + 1)) in - lp <= ls && aux 0 - in - let rec make_prefix = function - | name :: tl -> - let i = Buffer.length buf in - if i >= String.length name then make_prefix [] - else ( - (if starts_with (Buffer.contents buf) name then - let c = match name.[i] with 'a' -> 'b' | _ -> 'a' in - Buffer.add_char buf c); - make_prefix tl) - | [] -> Buffer.contents buf - in - make_prefix sorted_names - -let empty_program (p : Mast.program) main_target = - let prog_app = - let fold s a = StrMap.add a Pos.no_pos s in - List.fold_left fold StrMap.empty !Cli.application_names - in - { - prog_prefix = safe_prefix p; - prog_seq = 0; - prog_app; - prog_apps = StrMap.empty; - prog_chainings = StrMap.empty; - prog_var_cats = Com.CatVar.Map.empty; - prog_vars = StrMap.empty; - prog_alias = StrMap.empty; - prog_errors = StrMap.empty; - prog_rdoms = Com.DomainIdMap.empty; - prog_rdom_syms = Com.DomainIdMap.empty; - prog_vdoms = Com.DomainIdMap.empty; - prog_vdom_syms = Com.DomainIdMap.empty; - prog_functions = StrMap.empty; - prog_rules = IntMap.empty; - prog_rdom_calls = StrMap.empty; - prog_verifs = IntMap.empty; - prog_vdom_calls = StrMap.empty; - prog_targets = StrMap.empty; - prog_main_target = main_target; - prog_stats = - { - nb_calculated = 0; - nb_base = 0; - nb_input = 0; - nb_vars = 0; - nb_all_tmps = 0; - nb_all_refs = 0; - sz_calculated = 0; - sz_base = 0; - sz_input = 0; - sz_vars = 0; - sz_all_tmps = 0; - }; - } - -let get_seq (prog : program) : int * program = - let seq = prog.prog_seq in - let prog = { prog with prog_seq = seq + 1 } in - (seq, prog) - -let check_application (name : string) (pos : Pos.t) (prog : program) : program = - (* Already checked during preprocessing *) - let prog_apps = StrMap.add name pos prog.prog_apps in - { prog with prog_apps } - -let check_chaining (name : string) (pos : Pos.t) - (m_apps : string Pos.marked list) (prog : program) : program = - (* Already checked during preprocessing *) - let chain_name = (name, pos) in - let chain_apps = - List.fold_left - (fun apps (app, app_pos) -> StrMap.add app app_pos apps) - StrMap.empty m_apps - in - let chain_rules = IntMap.empty in - let chaining = { chain_name; chain_apps; chain_rules } in - let prog_chainings = StrMap.add name chaining prog.prog_chainings in - { prog with prog_chainings } - -let get_var_cat_id_str (var_cat : Com.CatVar.t) : string = - let buf = Buffer.create 100 in - (match var_cat with - | Com.CatVar.Computed { is_base } -> - Buffer.add_string buf "calculee"; - if is_base then Buffer.add_string buf "_base" - | Com.CatVar.Input ss -> - Buffer.add_string buf "saisie"; - let add buf s = - String.iter - (function - | '_' -> Buffer.add_string buf "__" | c -> Buffer.add_char buf c) - s - in - StrSet.iter - (fun s -> - Buffer.add_char buf '_'; - add buf s) - ss); - Buffer.contents buf - -let get_var_cat_loc (var_cat : Com.CatVar.t) : Com.CatVar.loc = - match var_cat with - | Com.CatVar.Computed { is_base } -> - if is_base then Com.CatVar.LocBase else Com.CatVar.LocComputed - | Com.CatVar.Input _ -> Com.CatVar.LocInput - -let get_var_cats (cat_decl : Mast.var_category_decl) : Com.CatVar.t list = - match cat_decl.Mast.var_type with - | Mast.Input -> - let id = StrSet.from_marked_list cat_decl.Mast.var_category in - [ Com.CatVar.Input id ] - | Mast.Computed -> - [ - Com.CatVar.Computed { is_base = false }; - Com.CatVar.Computed { is_base = true }; - ] - -let check_var_category (cat_decl : Mast.var_category_decl) (decl_pos : Pos.t) - (prog : program) : program = - let attributs = - List.fold_left - (fun attributs (attr, pos) -> - match StrMap.find_opt attr attributs with - | None -> StrMap.add attr pos attributs - | Some old_pos -> Err.attribute_already_declared attr old_pos pos) - StrMap.empty cat_decl.Mast.var_attributes - in - let add_cat cats cat = - match Com.CatVar.Map.find_opt cat cats with - | Some Com.CatVar.{ pos; _ } -> - Err.var_category_already_definied cat pos decl_pos - | None -> - let data = - Com.CatVar. - { - id = cat; - id_str = get_var_cat_id_str cat; - id_int = Com.CatVar.Map.cardinal cats; - loc = get_var_cat_loc cat; - attributs; - pos = decl_pos; - } - in - Com.CatVar.Map.add cat data cats - in - let prog_var_cats = - List.fold_left add_cat prog.prog_var_cats (get_var_cats cat_decl) - in - { prog with prog_var_cats } - -let get_attributes (attr_list : Mast.variable_attribute list) : - int Pos.marked StrMap.t = - List.fold_left - (fun attributes (m_attr, m_value) -> - let attr, attr_pos = m_attr in - let value, _ = m_value in - match StrMap.find_opt attr attributes with - | Some (_, old_pos) -> Err.attribute_already_defined attr old_pos attr_pos - | None -> StrMap.add attr (value, attr_pos) attributes) - StrMap.empty attr_list - -let check_global_var (var : Com.Var.t) (prog : program) : program = - let name, name_pos = var.name in - let cat = - let cat = Com.Var.cat var in - match Com.CatVar.Map.find_opt cat prog.prog_var_cats with - | None -> Err.variable_of_unknown_category cat name_pos - | Some cat -> cat - in - StrMap.iter - (fun attr _ -> - if not (StrMap.mem attr (Com.Var.attrs var)) then - Err.attribute_is_not_defined name attr name_pos) - cat.attributs; - let prog_vars = - match StrMap.find_opt name prog.prog_vars with - | 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 - 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 - Err.alias_already_declared alias old_pos alias_pos - | None -> StrMap.add alias var prog.prog_alias) - | None -> prog.prog_alias - in - { prog with prog_vars; prog_alias } - -let check_var_decl (var_decl : Mast.variable_decl) (prog : program) : program = - match var_decl with - | Mast.ConstVar _ -> assert false - | Mast.InputVar (input_var, _decl_pos) -> - let global_category = - let input_set = - List.fold_left - (fun res (str, _pos) -> StrSet.add str res) - StrSet.empty input_var.input_category - in - Com.CatVar.Input input_set - in - let var = - Com.Var.new_tgv ~name:input_var.Mast.input_name ~is_table:None - ~is_given_back:input_var.input_is_givenback - ~alias:(Some input_var.Mast.input_alias) - ~descr:input_var.Mast.input_description - ~attrs:(get_attributes input_var.Mast.input_attributes) - ~cat:global_category - ~typ:(Option.map Pos.unmark input_var.Mast.input_typ) - in - check_global_var var prog - | Mast.ComputedVar (comp_var, _decl_pos) -> - let global_category = - let is_base = - List.fold_left - (fun res (str, _pos) -> match str with "base" -> true | _ -> res) - false comp_var.comp_category - in - Com.CatVar.Computed { is_base } - in - let global_table = - match comp_var.Mast.comp_table with - | Some (Mast.LiteralSize sz, _pos) -> Some sz - | Some _ -> assert false - | None -> None - in - let var = - Com.Var.new_tgv ~name:comp_var.Mast.comp_name ~is_table:global_table - ~is_given_back:comp_var.comp_is_givenback ~alias:None - ~descr:comp_var.Mast.comp_description - ~attrs:(get_attributes comp_var.Mast.comp_attributes) - ~cat:global_category - ~typ:(Option.map Pos.unmark comp_var.Mast.comp_typ) - in - check_global_var var prog - -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 - let sous_code = List.nth error.error_descr 2 in - let libelle = List.nth error.error_descr 3 in - let is_isf = - match List.nth_opt error.error_descr 4 with - | Some s -> s - | None -> ("", Pos.no_pos) - in - let err = - Com.Error. - { - name = error.Mast.error_name; - typ = Pos.unmark error.Mast.error_typ; - famille; - code_bo; - sous_code; - is_isf; - libelle; - } - in - let name, name_pos = err.name in - match StrMap.find_opt name prog.prog_errors with - | Some old_err -> - let old_pos = Pos.get_position old_err.name in - Err.error_already_declared name old_pos name_pos - | None -> - let prog_errors = StrMap.add name err prog.prog_errors in - { prog with prog_errors } - -let check_domain (rov : rule_or_verif) (decl : 'a Mast.domain_decl) - (dom_data : 'b) ((doms, syms) : 'b doms * syms) : 'b doms * syms = - let dom_names = - List.fold_left - (fun dom_names (sl, sl_pos) -> - let id = Com.DomainId.from_marked_list sl in - Com.DomainIdMap.add id sl_pos dom_names) - Com.DomainIdMap.empty decl.dom_names - in - let dom_id = Com.DomainIdMap.min_binding dom_names in - let domain = - Com. - { - dom_id; - dom_names; - dom_by_default = decl.dom_by_default; - dom_min = DomainIdSet.from_marked_list_list decl.dom_parents; - dom_max = DomainIdSet.empty; - dom_rov = IntSet.empty; - dom_data; - dom_used = None; - } - in - let dom_id_name, dom_id_pos = dom_id in - let syms = - Com.DomainIdMap.fold - (fun name name_pos syms -> - match Com.DomainIdMap.find_opt name syms with - | Some (_, old_pos) -> Err.domain_already_declared rov old_pos name_pos - | None -> - let value = (dom_id_name, name_pos) in - Com.DomainIdMap.add name value syms) - dom_names syms - in - let syms = - if decl.dom_by_default then - match Com.DomainIdMap.find_opt Com.DomainId.empty syms with - | Some (_, old_pos) -> - Err.default_domain_already_declared rov old_pos dom_id_pos - | None -> - let value = (dom_id_name, Pos.no_pos) in - Com.DomainIdMap.add Com.DomainId.empty value syms - else syms - in - let doms = Com.DomainIdMap.add dom_id_name domain doms in - (doms, syms) - -let check_rule_dom_decl (decl : Mast.rule_domain_decl) (prog : program) : - program = - let dom_data = Com.{ rdom_computable = decl.Mast.dom_data.rdom_computable } in - let doms_syms = (prog.prog_rdoms, prog.prog_rdom_syms) in - let doms, syms = check_domain Rule decl dom_data doms_syms in - { prog with prog_rdoms = doms; prog_rdom_syms = syms } - -let mast_to_catvars (cs : Pos.t Com.CatVar.Map.t) - (cats : Com.CatVar.data Com.CatVar.Map.t) : Pos.t Com.CatVar.Map.t = - let filter_cats pred = - Com.CatVar.Map.fold - (fun cv (cvd : Com.CatVar.data) res -> - if pred cv then Com.CatVar.Map.add cv cvd.pos res else res) - cats Com.CatVar.Map.empty - in - let fold cv pos res = - match cv with - | Com.CatVar.Input set when StrSet.mem "*" set -> - filter_cats (function Com.CatVar.Input _ -> true | _ -> false) - |> Com.CatVar.Map.union (fun _ p _ -> Some p) res - | Com.CatVar.Input _ -> - if Com.CatVar.Map.mem cv cats then Com.CatVar.Map.add cv pos res - else Err.unknown_variable_category cv pos - | _ -> Com.CatVar.Map.add cv pos res - in - Com.CatVar.Map.fold fold cs Com.CatVar.Map.empty - -let check_verif_dom_decl (decl : Mast.verif_domain_decl) (prog : program) : - program = - let vdom_auth = - let rec aux vdom_auth = function - | [] -> vdom_auth - | l :: t -> - let vcats = - mast_to_catvars - (Com.CatVar.Map.from_string_list l) - prog.prog_var_cats - in - aux (Com.CatVar.Map.union (fun _ p _ -> Some p) vcats vdom_auth) t - in - aux Com.CatVar.Map.empty decl.Mast.dom_data.vdom_auth - in - let vdom_verifiable = decl.Mast.dom_data.vdom_verifiable in - let dom_data = Com.{ vdom_auth; vdom_verifiable } in - let doms_syms = (prog.prog_vdoms, prog.prog_vdom_syms) in - 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 - let get_dom id doms = Com.DomainIdMap.find (get_id id) doms in - let module DomGraph : - TopologicalSorting.GRAPH - with type 'a t = 'a doms - and type vertex = Com.DomainId.t - and type edge = unit = struct - type 'a t = 'a doms - - type vertex = Com.DomainId.t - - type edge = unit - - type 'a vertexMap = 'a Com.DomainIdMap.t - - let vertexMapEmpty = Com.DomainIdMap.empty - - let vertexMapAdd id value map = Com.DomainIdMap.add (get_id id) value map - - let vertexMapRemove id map = Com.DomainIdMap.remove (get_id id) map - - let vertexMapFindOpt id map = Com.DomainIdMap.find_opt (get_id id) map - - let vertexMapFold fold map res = - Com.DomainIdMap.fold - (fun id edge res -> fold (get_id id) edge res) - map res - - let vertices doms = - let get_vertex id _ nds = Com.DomainIdMap.add id None nds in - Com.DomainIdMap.fold get_vertex doms Com.DomainIdMap.empty - - let edges doms id = - Com.DomainIdSet.fold - (fun id res -> Com.DomainIdMap.add id None res) - (get_dom id doms).Com.dom_min Com.DomainIdMap.empty - end in - let module DomSorting = TopologicalSorting.Make (DomGraph) in - let sorted_doms = - try DomSorting.sort doms with - | DomSorting.Cycle cycle -> Err.loop_in_domains rov (List.map fst cycle) - | DomSorting.AutoCycle (id, _) -> - let dom = get_dom id doms in - let dom_id, dom_id_pos = dom.Com.dom_id in - Err.domain_specialize_itself rov dom_id dom_id_pos - in - let doms = - let set_min doms id = - let dom = get_dom id doms in - let dom_min = - let fold parent_id res = - let parent_dom = get_dom parent_id doms in - let parent_id = Pos.unmark parent_dom.Com.dom_id in - let dom_min = Com.DomainIdSet.map get_id parent_dom.Com.dom_min in - Com.DomainIdSet.one parent_id - |> Com.DomainIdSet.union dom_min - |> Com.DomainIdSet.union res - in - Com.DomainIdSet.fold fold dom.Com.dom_min Com.DomainIdSet.empty - in - let dom = Com.{ dom with dom_min } in - Com.DomainIdMap.add id dom doms - in - List.fold_left set_min doms sorted_doms - in - let doms = - let set_max id dom doms = - let fold min_id doms = - let min_dom = Com.DomainIdMap.find min_id doms in - let dom_max = Com.DomainIdSet.add id min_dom.Com.dom_max in - let min_dom = Com.{ min_dom with dom_max } in - Com.DomainIdMap.add min_id min_dom doms - in - Com.DomainIdSet.fold fold dom.Com.dom_min doms - in - Com.DomainIdMap.fold set_max doms doms - in - let doms = - let add_sym name (id, _) doms = - Com.DomainIdMap.add name (get_dom id doms) doms - in - Com.DomainIdMap.fold add_sym syms doms - in - match Com.DomainIdMap.find_opt Com.DomainId.empty doms with - | None -> Err.no_default_domain rov - | Some _ -> doms - -let complete_rdom_decls (prog : program) : program = - let prog_rdoms = - let doms_syms = (prog.prog_rdoms, prog.prog_rdom_syms) in - let prog_rdoms = complete_dom_decls Rule doms_syms in - StrMap.fold - (fun _ (m_seq, rdom_id) prog_rdoms -> - let rdom = Com.DomainIdMap.find rdom_id prog_rdoms in - Com.DomainIdSet.fold - (fun rid prog_rdoms -> - let rd = Com.DomainIdMap.find rid prog_rdoms in - let rd = - match rd.Com.dom_used with - | Some _ -> rd - | None -> { rd with Com.dom_used = Some m_seq } - in - Com.DomainIdMap.add rid rd prog_rdoms) - (Com.DomainIdSet.add rdom_id rdom.Com.dom_min) - prog_rdoms) - prog.prog_rdom_calls prog_rdoms - in - { prog with prog_rdoms } - -let complete_vdom_decls (prog : program) : program = - let prog_vdoms = - let doms_syms = (prog.prog_vdoms, prog.prog_vdom_syms) in - let prog_vdoms = complete_dom_decls Verif doms_syms in - StrMap.fold - (fun _ (m_seq, vdom_id, _) prog_vdoms -> - let vdom = Com.DomainIdMap.find vdom_id prog_vdoms in - Com.DomainIdSet.fold - (fun vid prog_vdoms -> - let vd = Com.DomainIdMap.find vid prog_vdoms in - let vd = - match vd.Com.dom_used with - | Some _ -> vd - | None -> { vd with Com.dom_used = Some m_seq } - in - Com.DomainIdMap.add vid vd prog_vdoms) - (Com.DomainIdSet.add vdom_id vdom.Com.dom_min) - prog_vdoms) - prog.prog_vdom_calls prog_vdoms - in - { prog with prog_vdoms } - -type 'a var_mem_type = Both | OneOf of 'a option - -type var_env = { - prog : program; - tmp_vars : int option Pos.marked StrMap.t; - ref_vars : Pos.t StrMap.t; - res_var : MarkedVarNames.t option; -} - -let rec fold_var_expr - (fold_var : - Mast.variable Pos.marked -> unit var_mem_type -> var_env -> 'a -> 'a) - (is_filter : bool) (acc : 'a) (m_expr : Mast.expression Pos.marked) - (env : var_env) : 'a = - let expr, expr_pos = m_expr in - match expr with - | TestInSet (_positive, e, values) -> - let res = fold_var_expr fold_var is_filter acc e env in - 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.FloatValue _ -> res - | Com.Interval (bn, en) -> - let b, b_pos = bn and e, e_pos = en in - if b > e then - Err.wrong_interval_bounds b e - (Pos.make_position_between b_pos e_pos); - res) - res values - | Comparison (_op, e1, e2) -> - let acc = fold_var_expr fold_var is_filter acc e1 env in - fold_var_expr fold_var is_filter acc e2 env - | Binop (_op, e1, e2) -> - 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) -> - 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 - | 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 - match e3_opt with - | Some e3 -> fold_var_expr fold_var is_filter acc e3 env - | None -> acc) - | FuncCall ((func_name, fpos), args) -> ( - let check_func arity = - if arity > -1 && List.length args <> arity then - Err.wrong_arity_of_function func_name arity expr_pos; - List.fold_left - (fun acc e -> fold_var_expr fold_var is_filter acc e env) - acc args - in - match func_name with - | Com.Multimax -> ( - if is_filter then Err.forbidden_expresion_in_filter expr_pos; - match args with - | [ expr; var_expr ] -> ( - match var_expr with - | Var 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)) - | _ -> Err.multimax_require_two_args expr_pos) - | Com.SumFunc -> check_func (-1) - | Com.VerifNumber -> check_func 0 - | Com.ComplNumber -> check_func 0 - | Com.AbsFunc -> check_func 1 - | Com.MinFunc -> check_func 2 - | Com.MaxFunc -> check_func 2 - | Com.GtzFunc -> check_func 1 - | Com.GtezFunc -> check_func 1 - | Com.NullFunc -> check_func 1 - | Com.ArrFunc -> check_func 1 - | Com.InfFunc -> check_func 1 - | Com.Supzero -> check_func 1 - | Com.PresentFunc -> - if is_filter then Err.forbidden_expresion_in_filter expr_pos; - check_func 1 - | Com.Func fn -> - if is_filter then Err.forbidden_expresion_in_filter expr_pos; - let fd = - match StrMap.find_opt fn env.prog.prog_functions with - | Some fd -> fd - | None -> Err.function_does_not_exist fn fpos - in - check_func (List.length fd.target_args)) - | Literal _ -> acc - | Var var -> - if is_filter then Err.variable_forbidden_in_filter var expr_pos; - fold_var (var, expr_pos) (OneOf None) env acc - | 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 - Com.CatVar.Map.iter - (fun cat pos -> - if not (Com.CatVar.Map.mem cat env.prog.prog_var_cats) then - Err.unknown_domain Verif pos) - cats; - acc - | Attribut (v, a) -> - let name, var_pos = - match v with - | Mast.Normal name, var_pos -> (name, var_pos) - | Mast.Generic _, _ -> assert false - in - (match StrMap.find_opt name env.prog.prog_vars with - | Some var -> - let cat = Com.Var.cat var in - if not (StrMap.mem (Pos.unmark a) (Com.Var.attrs var)) then - Err.unknown_attribut_for_var cat (Pos.get_position a) - | None -> ( - match StrMap.find_opt name env.tmp_vars with - | Some _ -> Err.tmp_vars_have_no_attrs name var_pos - | None -> ())); - fold_var v Both env acc - | Size v -> fold_var v Both env acc - | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes -> - if is_filter then Err.forbidden_expresion_in_filter expr_pos; - acc - | FuncCallLoop _ | Loop _ -> assert false - -let check_variable (var : Mast.variable Pos.marked) - (idx_mem : unit var_mem_type) (env : var_env) : MarkedVarNames.t = - let var_data, var_pos = var in - let name, decl_mem, decl_pos = - match var_data with - | Normal vn -> ( - match StrMap.find_opt vn env.prog.prog_vars with - | Some v -> - (vn, OneOf (Com.Var.is_table v), Pos.get_position (Com.Var.name v)) - | None -> ( - match StrMap.find_opt vn env.tmp_vars with - | Some (decl_size, decl_pos) -> (vn, OneOf decl_size, decl_pos) - | None -> ( - match StrMap.find_opt vn env.ref_vars with - | Some decl_pos -> (vn, Both, decl_pos) - | None -> ( - match env.res_var with - | Some (vr, decl_pos) when vr = vn -> - (vn, OneOf None, decl_pos) - | Some _ | None -> Err.unknown_variable vn var_pos)))) - | Generic _ -> assert false - in - match (idx_mem, decl_mem) with - | Both, _ | _, Both -> (name, var_pos) - | OneOf idx, OneOf decl_size -> ( - match (idx, decl_size) with - | None, None -> (name, var_pos) - | None, Some _ -> Err.variable_used_as_table decl_pos var_pos - | Some _, Some _ -> (name, var_pos) - | Some _, None -> Err.table_used_as_variable decl_pos var_pos) - -let check_expression (is_filter : bool) (m_expr : Mast.expression Pos.marked) - (env : var_env) : MarkedVarNames.Set.t = - let fold_var var idx_mem env acc = - let marked_var = check_variable var idx_mem env in - MarkedVarNames.Set.add marked_var acc - in - fold_var_expr fold_var is_filter MarkedVarNames.Set.empty m_expr env - -let get_compute_id_str (instr : Mast.instruction) (prog : program) : string = - let buf = Buffer.create 100 in - Buffer.add_string buf prog.prog_prefix; - let add_sml buf sml = - let id = Com.DomainId.from_marked_list (Pos.unmark sml) in - let add s = - String.iter - (function - | '_' -> Buffer.add_string buf "__" | c -> Buffer.add_char buf c) - s - in - Com.DomainId.iter - (fun s -> - Buffer.add_char buf '_'; - add s) - id; - id - in - (match instr with - | Com.ComputeDomain l -> ( - Buffer.add_string buf "_rules"; - let id = add_sml buf l in - match Com.DomainIdMap.find_opt id prog.prog_rdom_syms with - | Some (dom_id, _) -> - let rdom = Com.DomainIdMap.find dom_id prog.prog_rdoms in - if not rdom.Com.dom_data.rdom_computable then - Err.rule_domain_not_computable (Pos.unmark l) (Pos.get_position l) - | None -> Err.unknown_domain Rule (Pos.get_position l)) - | Com.ComputeChaining (ch_name, ch_pos) -> ( - Buffer.add_string buf "_chaining_"; - Buffer.add_string buf ch_name; - match StrMap.find_opt ch_name prog.prog_chainings with - | Some _ -> () - | None -> Err.unknown_chaining ch_name ch_pos) - | Com.ComputeVerifs (l, _) -> ( - Buffer.add_string buf "_verifs"; - let id = add_sml buf l in - Buffer.add_char buf '_'; - let cpt = StrMap.cardinal prog.prog_vdom_calls in - Buffer.add_string buf (Format.sprintf "%d" cpt); - match Com.DomainIdMap.find_opt id prog.prog_vdom_syms with - | Some (dom_id, _) -> - let vdom = Com.DomainIdMap.find dom_id prog.prog_vdoms in - if not vdom.Com.dom_data.vdom_verifiable then - Err.verif_domain_not_verifiable (Pos.unmark l) (Pos.get_position l) - | None -> Err.unknown_domain Verif (Pos.get_position l)) - | _ -> assert false); - Buffer.contents buf - -let cats_variable_from_decl_list (l : Mast.var_category_id list) - (cats : Com.CatVar.data Com.CatVar.Map.t) : Pos.t Com.CatVar.Map.t = - let rec aux res = function - | [] -> res - | l :: t -> - let vcats = mast_to_catvars (Com.CatVar.Map.from_string_list l) cats in - aux (Com.CatVar.Map.union (fun _ p _ -> Some p) vcats res) t - in - aux Com.CatVar.Map.empty l - -let rec check_instructions (instrs : Mast.instruction Pos.marked list) - (is_rule : bool) (env : var_env) : - program - * Mast.instruction Pos.marked list - * MarkedVarNames.Set.t - * MarkedVarNames.Set.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 rec aux (env, res, in_vars, out_vars, def_vars) instr_list = - match instr_list with - | [] -> (env, List.rev res, in_vars, out_vars, def_vars) - | m_instr :: il -> ( - let instr, instr_pos = m_instr in - match instr with - | Com.Affectation (f, _) -> ( - match f with - | Com.SingleFormula (v, idx, e) -> - let var, vpos = v in - let vn = Mast.get_normal_var var in - let def_list = - match StrMap.find_opt vn def_vars with - | None -> [ vpos ] - | Some l -> vpos :: l - in - let def_vars = StrMap.add vn def_list def_vars in - let out_var = - let idx_mem = OneOf (Option.map (fun _ -> ()) idx) in - check_variable v idx_mem env - in - let in_vars_index = - match idx with - | Some ei -> check_expression false ei env - | None -> MarkedVarNames.Set.empty - in - let in_vars_expr = check_expression false e env in - if is_rule then - let in_vars_aff = - MarkedVarNames.Set.union in_vars_index in_vars_expr - in - let in_vars = - MarkedVarNames.Set.union in_vars - (MarkedVarNames.Set.diff in_vars_aff out_vars) - in - let out_vars = MarkedVarNames.Set.add out_var out_vars in - aux (env, m_instr :: res, in_vars, out_vars, def_vars) il - else 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.instruction_forbidden_in_rules instr_pos; *) - let in_expr = check_expression false expr env in - let prog, res_then, in_then, out_then = - check_instructions i_then is_rule env - in - let env = { env with prog } in - let prog, res_else, in_else, out_else = - check_instructions i_else is_rule env - in - let env = { env with prog } in - let res_instr = Com.IfThenElse (expr, res_then, res_else) in - let in_vars = - in_vars - |> MarkedVarNames.Set.union in_expr - |> MarkedVarNames.Set.union in_then - |> MarkedVarNames.Set.union in_else - in - let out_vars = - out_vars - |> MarkedVarNames.Set.union out_then - |> MarkedVarNames.Set.union out_else - in - 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 - | (expr, dl, pos) :: l -> - let in_expr = check_expression false expr env in - let prog, res_do, in_do, out_do = - check_instructions dl is_rule env - in - let env = { env with prog } in - let in_vars = - in_vars - |> MarkedVarNames.Set.union in_expr - |> MarkedVarNames.Set.union in_do - in - let out_vars = out_vars |> MarkedVarNames.Set.union out_do in - wde (env, (expr, res_do, pos) :: res, in_vars, out_vars) l - | [] -> - let prog, res_ed, in_ed, out_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 in_vars = in_vars |> MarkedVarNames.Set.union in_ed in - let out_vars = out_vars |> MarkedVarNames.Set.union out_ed in - (env, Com.WhenDoElse (List.rev res, ed'), in_vars, out_vars) - in - let env, wde_res, in_vars, out_vars = - wde (env, [], in_vars, out_vars) wdl - 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.instruction_forbidden_in_rules instr_pos; - let tname = get_compute_id_str instr env.prog in - let rdom_id = - let id = Com.DomainId.from_marked_list rdom_list in - Pos.unmark (Com.DomainIdMap.find id env.prog.prog_rdom_syms) - in - let seq, prog = get_seq env.prog in - let prog_rdom_calls = - let used_data = ((seq, rdom_pos), rdom_id) in - StrMap.add tname used_data prog.prog_rdom_calls - in - 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, def_vars) - il - | Com.ComputeChaining _ -> - if is_rule then Err.instruction_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, def_vars) - il - | Com.ComputeVerifs ((vdom_list, vdom_pos), expr) -> - if is_rule then Err.instruction_forbidden_in_rules instr_pos; - let tname = get_compute_id_str instr env.prog in - let vdom_id = - let id = Com.DomainId.from_marked_list vdom_list in - Pos.unmark (Com.DomainIdMap.find id env.prog.prog_vdom_syms) - in - let seq, prog = get_seq env.prog in - ignore (check_expression true expr env); - let prog_vdom_calls = - let used_data = ((seq, vdom_pos), vdom_id, expr) in - StrMap.add tname used_data prog.prog_vdom_calls - in - 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, def_vars) - il - | Com.VerifBlock instrs -> - if is_rule then Err.instruction_forbidden_in_rules instr_pos; - 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, def_vars) - il - | Com.ComputeTarget ((tn, tpos), targs) -> - if is_rule then Err.instruction_forbidden_in_rules instr_pos; - (match StrMap.find_opt tn env.prog.prog_targets with - | None -> Err.unknown_target tn tpos - | Some target -> - let nb_args = List.length target.target_args in - 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, def_vars) il - | Com.Print (_std, args) -> - List.iter - (fun arg -> - match Pos.unmark arg with - | Com.PrintString _ -> () - | Com.PrintName v | Com.PrintAlias v -> - ignore (check_variable v Both env) - | Com.PrintIndent e -> ignore (check_expression false e env) - | Com.PrintExpr (e, _min, _max) -> - ignore (check_expression false e env)) - args; - aux (env, m_instr :: res, in_vars, out_vars, def_vars) il - | Com.Iterate (var, vars, var_params, instrs) -> - if is_rule then Err.instruction_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 ref_vars = StrMap.add var_name var_pos env.ref_vars } - in - ignore - (List.fold_left - (fun seen var -> - let var_pos = Pos.get_position var in - let var_name = Mast.get_normal_var (Pos.unmark var) in - ignore (check_variable var Both env); - match StrMap.find_opt var_name seen with - | None -> StrMap.add var_name var_pos seen - | Some old_pos -> - Err.variable_already_specified var_name old_pos var_pos) - StrMap.empty vars); - List.iter - (fun (vcats, expr) -> - ignore (mast_to_catvars vcats env.prog.prog_var_cats); - ignore (check_expression false expr env')) - var_params; - 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, def_vars) - il - | Com.Restore (vars, var_params, instrs) -> - if is_rule then Err.instruction_forbidden_in_rules instr_pos; - ignore - (List.fold_left - (fun seen var -> - let var_pos = Pos.get_position var in - let var_name = Mast.get_normal_var (Pos.unmark var) in - ignore (check_variable var Both env); - match StrMap.find_opt var_name seen with - | None -> StrMap.add var_name var_pos seen - | Some old_pos -> - Err.variable_already_specified var_name old_pos var_pos) - 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 -> ()); - ignore (mast_to_catvars vcats env.prog.prog_var_cats); - let env = - { - env with - ref_vars = StrMap.add var_name var_pos env.ref_vars; - } - in - ignore (check_expression false expr env)) - var_params; - 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 - 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.instruction_forbidden_in_rules instr_pos; - let err_name, err_pos = m_err in - (match StrMap.find_opt err_name env.prog.prog_errors with - | None -> Err.unknown_error (Pos.unmark m_err) err_pos - | Some _ -> ()); - (match m_var_opt with - | Some (var_name, var_pos) -> ( - if - (not (StrMap.mem var_name env.tmp_vars)) - && not (StrMap.mem var_name env.ref_vars) - then - match StrMap.find_opt var_name env.prog.prog_vars with - | None -> Err.unknown_variable var_name var_pos - | Some _ -> ()) - | None -> ()); - aux (env, m_instr :: res, in_vars, out_vars, def_vars) il - | Com.CleanErrors | Com.ExportErrors | Com.FinalizeErrors -> - if is_rule then Err.instruction_forbidden_in_rules instr_pos; - aux (env, m_instr :: res, in_vars, out_vars, def_vars) il) - in - let env, res, in_vars, out_vars, def_vars = - aux - (env, [], MarkedVarNames.Set.empty, MarkedVarNames.Set.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.fold - (fun vn posd s -> MarkedVarNames.Set.add (vn, Pos.get_position posd) s) - env.tmp_vars MarkedVarNames.Set.empty - in - let in_vars = MarkedVarNames.Set.diff in_vars tmp_vars in - let out_vars = MarkedVarNames.Set.diff out_vars tmp_vars in - (env.prog, res, in_vars, out_vars) - -let check_target (is_function : bool) (t : Mast.target) (prog : program) : - program = - let target_name = t.target_name in - let tname, tpos = target_name in - if Com.Func tname <> Pos.unmark (Parse_utils.parse_function_name target_name) - then Err.is_base_function tname tpos; - (match StrMap.find_opt tname prog.prog_targets with - | Some { target_name = _, old_pos; _ } -> - Err.target_already_declared tname old_pos tpos - | None -> ()); - let target_file = Some (get_target_file tpos) in - let target_apps = - (* Already checked during preprocessing *) - t.target_apps - in - let target, prog = - let target_args = t.target_args in - List.iter - (fun (vn, vpos) -> - match StrMap.find_opt vn prog.prog_vars with - | Some Com.Var.{ name = _, old_pos; _ } -> - Err.variable_already_declared vn old_pos vpos - | None -> ()) - target_args; - let target_tmp_vars = t.target_tmp_vars in - StrMap.iter - (fun _ ((vn, vpos), _) -> - match StrMap.find_opt vn prog.prog_vars with - | Some Com.Var.{ name = _, old_pos; _ } -> - Err.variable_already_declared vn old_pos vpos - | None -> ()) - target_tmp_vars; - List.iter - (fun (vn, vpos) -> - match StrMap.find_opt vn target_tmp_vars with - | Some ((_, old_pos), _) -> - Err.variable_already_declared vn old_pos vpos - | None -> ()) - target_args; - let target_result = t.target_result in - (match target_result with - | Some (vn, vpos) -> ( - if not is_function then Err.target_must_not_have_a_result tname tpos; - (match StrMap.find_opt vn prog.prog_vars with - | Some { name = _, old_pos; _ } -> - Err.variable_already_declared vn old_pos vpos - | None -> ()); - (match List.find_opt (fun (va, _) -> vn = va) target_args with - | Some (_, old_pos) -> Err.variable_already_declared vn old_pos vpos - | None -> ()); - match StrMap.find_opt vn target_tmp_vars with - | Some ((_, old_pos), _) -> - Err.variable_already_declared vn old_pos vpos - | None -> ()) - | None -> if is_function then Err.function_result_missing tname tpos); - let tmp_vars = - StrMap.map - (fun (var, size) -> - let vpos = Pos.get_position var in - let sz = - match size with - | None -> None - | Some (Mast.LiteralSize i, _) -> Some i - | Some (Mast.SymbolSize _, _) -> assert false - in - (sz, vpos)) - target_tmp_vars - in - let ref_vars = - List.fold_left - (fun res (vn, vpos) -> StrMap.add vn vpos res) - StrMap.empty target_args - in - 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 = - check_instructions t.target_prog is_function env - in - (if is_function then - let vr = Option.get target_result in - let bad_out_vars = MarkedVarNames.Set.remove vr out_vars in - if MarkedVarNames.Set.card bad_out_vars > 0 then - let var_pos = MarkedVarNames.Set.min_elt bad_out_vars in - Err.forbidden_out_var_in_function (Pos.unmark var_pos) tname tpos); - (prog, target_prog) - in - let target = - { - t with - target_name; - target_file; - target_apps; - target_args; - target_result; - target_tmp_vars; - target_prog; - } - in - (target, prog) - in - if is_function then - let prog_functions = StrMap.add tname target prog.prog_functions in - { prog with prog_functions } - else - let prog_targets = StrMap.add tname target prog.prog_targets in - { prog with prog_targets } - -let check_rule (r : Mast.rule) (prog : program) : program = - let id, id_pos = r.Mast.rule_number in - let rule_id = (id, id_pos) in - let rule_apps = - (* Already checked during preprocessing *) - StrMap.map (function _, pos -> pos) r.Mast.rule_apps - in - let rdom_id = - Com.DomainId.from_marked_list (Pos.unmark r.Mast.rule_tag_names) - in - let rule_domain, rule_domain_pos = - let rid, rid_pos = - match Com.DomainIdMap.find_opt rdom_id prog.prog_rdom_syms with - | Some m_rid -> m_rid - | None -> Err.unknown_domain Rule (Pos.get_position r.Mast.rule_tag_names) - in - let rule_domain = Com.DomainIdMap.find rid prog.prog_rdoms in - (rule_domain, rid_pos) - in - let rule_chains, prog_chainings = - let fold _ (ch, chpos) (rule_chains, prog_chainings) = - (* Already checked during preprocessing *) - let chain = StrMap.find ch prog.prog_chainings in - let chain_rules = - IntMap.add id (rule_domain, rule_domain_pos) chain.chain_rules - in - let chain = { chain with chain_rules } in - let rule_chains = StrMap.add ch chpos rule_chains in - let prog_chainings = StrMap.add ch chain prog_chainings in - (rule_chains, prog_chainings) - in - StrMap.fold fold r.rule_chainings (StrMap.empty, prog.prog_chainings) - in - let rule_tmp_vars = r.Mast.rule_tmp_vars in - StrMap.iter - (fun _ ((vn, vpos), _) -> - match StrMap.find_opt vn prog.prog_vars with - | Some Com.Var.{ name = _, old_pos; _ } -> - Err.variable_already_declared vn old_pos vpos - | None -> ()) - rule_tmp_vars; - let tmp_vars = - StrMap.map - (fun (var, size) -> - let vpos = Pos.get_position var in - let sz = - match size with - | None -> None - | Some (Mast.LiteralSize i, _) -> Some i - | Some (Mast.SymbolSize _, _) -> assert false - in - (sz, vpos)) - rule_tmp_vars - in - let rule_instrs = r.Mast.rule_formulaes in - 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 - let rule_seq, prog = get_seq prog in - let rule = - { - rule_id; - rule_apps; - rule_domain; - rule_chains; - rule_tmp_vars; - rule_instrs; - rule_in_vars; - rule_out_vars; - rule_seq; - } - in - (match IntMap.find_opt id prog.prog_rules with - | Some r -> - let rule_pos = Pos.get_position r.rule_id in - Err.rov_already_defined Rule id rule_pos id_pos - | None -> ()); - let prog_rules = IntMap.add id rule prog.prog_rules in - { prog with prog_rules; prog_chainings } - -let convert_rules (prog : program) : program = - let prog_targets = - IntMap.fold - (fun id rule prog_targets -> - let tname = Format.sprintf "%s_regle_%d" prog.prog_prefix id in - let target_file = - Some (get_target_file (Pos.get_position rule.rule_id)) - in - let target = - Mast. - { - target_name = (tname, Pos.no_pos); - target_file; - target_apps = StrMap.mapi (fun a p -> (a, p)) prog.prog_app; - target_args = []; - target_result = None; - target_tmp_vars = rule.rule_tmp_vars; - target_prog = rule.rule_instrs; - target_nb_tmps = 0; - target_sz_tmps = 0; - target_nb_refs = 0; - } - in - StrMap.add tname target prog_targets) - prog.prog_rules prog.prog_targets - in - { prog with prog_targets } - -let create_rule_graph (in_vars_from : rule -> MarkedVarNames.Set.t) - (out_vars_from : rule -> MarkedVarNames.Set.t) (rules : 'a IntMap.t) : - MarkedVarNames.t IntMap.t option IntMap.t = - let in_vars_of_rules = - IntMap.fold - (fun id rule var_map -> - MarkedVarNames.Set.fold - (fun var var_map -> - if is_vartmp (Pos.unmark var) then var_map - else - MarkedVarNames.Map.update var - (function - | None -> Some (IntSet.one id) - | Some set -> Some (IntSet.add id set)) - var_map) - (in_vars_from rule) var_map) - rules MarkedVarNames.Map.empty - in - IntMap.map - (fun rule -> - let edges = - MarkedVarNames.Set.fold - (fun out_var edges -> - if is_vartmp (Pos.unmark out_var) then edges - else - match MarkedVarNames.Map.find_opt out_var in_vars_of_rules with - | Some out_rules -> - IntSet.fold - (fun out_id edges -> IntMap.add out_id out_var edges) - out_rules edges - | None -> edges) - (out_vars_from rule) IntMap.empty - in - Some edges) - rules - -let rule_graph_to_instrs (rdom_chain : rdom_or_chain) (prog : program) - (rule_graph : MarkedVarNames.t IntMap.t option IntMap.t) : - Mast.instruction Pos.marked list = - let module RuleGraph : - TopologicalSorting.GRAPH - with type 'a t = MarkedVarNames.t IntMap.t option IntMap.t - and type vertex = int - and type edge = MarkedVarNames.t = struct - type 'a t = MarkedVarNames.t IntMap.t option IntMap.t - - type vertex = int - - type edge = MarkedVarNames.t - - type 'a vertexMap = 'a IntMap.t - - let vertexMapEmpty = IntMap.empty - - let vertexMapAdd id value map = IntMap.add id value map - - let vertexMapRemove id map = IntMap.remove id map - - let vertexMapFindOpt id map = IntMap.find_opt id map - - let vertexMapFold fold map res = IntMap.fold fold map res - - let vertices rules = - IntMap.fold (fun id _ res -> IntMap.add id None res) rules IntMap.empty - - let edges rules id = - let es = Option.get (IntMap.find id rules) in - IntMap.map (fun var -> Some var) es - end in - let module RulesSorting = TopologicalSorting.Make (RuleGraph) in - let auto_cycle = - Some - (function - | id, (var_name, var_pos) -> - Errors.print_spanned_warning - (Format.asprintf - "Rule %d needs variable %s as both input and output" id var_name) - var_pos) - in - let sorted_rules = - try RulesSorting.sort ~auto_cycle rule_graph with - | RulesSorting.Cycle cycle -> Err.loop_in_rules rdom_chain cycle - | RulesSorting.AutoCycle _ -> assert false - in - List.map - (fun id -> - let name = Format.sprintf "%s_regle_%d" prog.prog_prefix id in - (Com.ComputeTarget ((name, Pos.no_pos), []), Pos.no_pos)) - sorted_rules - -let rdom_rule_filter (rdom : Com.rule_domain_data Com.domain) (rule : rule) : - bool = - (match rdom.Com.dom_used with - | Some (rdom_seq, seq_pos) -> - if rdom_seq <= rule.rule_seq then - Err.domain_already_used Rule seq_pos (Pos.get_position rule.rule_id) - | None -> ()); - let rdom_id = Pos.unmark rdom.dom_id in - let rule_rdom_id = Pos.unmark rule.rule_domain.dom_id in - 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 - MarkedVarNames.Set.fold - (fun var rule_defined -> - let tail = - match MarkedVarNames.Map.find_opt var rule_defined with - | Some tl -> tl - | None -> [] - in - MarkedVarNames.Map.add var - (Pos.get_position var :: tail) - rule_defined) - out rule_defined) - rdom_rules MarkedVarNames.Map.empty - in - MarkedVarNames.Map.iter - (fun var pos_list -> - let var_name = Pos.unmark var in - 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 ( - 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) - rdom_rules - in - let target_prog = - rule_graph_to_instrs (RuleDomain rdom_id) prog rule_graph - in - let tname = - let spl = - Com.DomainId.fold (fun s l -> (s, Pos.no_pos) :: l) rdom_id [] - in - get_compute_id_str (Com.ComputeDomain (spl, Pos.no_pos)) prog - in - let target = - Mast. - { - target_name = (tname, Pos.no_pos); - target_file = None; - target_apps = StrMap.mapi (fun a p -> (a, p)) prog.prog_app; - target_args = []; - target_result = None; - target_tmp_vars = StrMap.empty; - target_prog; - target_nb_tmps = 0; - target_sz_tmps = 0; - target_nb_refs = 0; - } - in - StrMap.add tname target prog_targets) - else prog_targets) - prog.prog_rdoms prog.prog_targets - in - { prog with prog_targets } - -let rdom_id_rule_filter (prog : program) (rdom_id : Com.DomainId.t) - (rule : rule) : bool = - let rdom = Com.DomainIdMap.find rdom_id prog.prog_rdoms in - rdom_rule_filter rdom rule - -let rdom_ids_rule_filter (prog : program) (rdom_ids : Com.DomainIdSet.t) - (rule : rule) : bool = - Com.DomainIdSet.exists - (fun rdom_id -> rdom_id_rule_filter prog rdom_id rule) - rdom_ids - -let complete_chainings (prog : program) : program = - let prog_targets = - StrMap.fold - (fun ch_name chain prog_targets -> - let all_ids = - Com.DomainIdMap.fold - (fun _ rdom ids -> - let uid = Pos.unmark rdom.Com.dom_id in - Com.DomainIdSet.add uid ids) - prog.prog_rdoms Com.DomainIdSet.empty - in - let sup_ids = - IntMap.fold - (fun _ (rdom, id_pos) sup_ids -> - let uid = Pos.unmark rdom.Com.dom_id in - let rdom_supeq = Com.DomainIdSet.add uid rdom.Com.dom_max in - let sup_ids = Com.DomainIdSet.inter sup_ids rdom_supeq in - if Com.DomainIdSet.cardinal sup_ids = 0 then - Err.rule_domain_incompatible_with_chaining ch_name id_pos - else sup_ids) - chain.chain_rules all_ids - in - let min_ids = - Com.DomainIdSet.filter - (fun id -> - let rdom = Com.DomainIdMap.find id prog.prog_rdoms in - let min_sups = Com.DomainIdSet.inter sup_ids rdom.Com.dom_min in - Com.DomainIdSet.is_empty min_sups) - sup_ids - in - let rdom_rules = - IntMap.filter - (fun _ rule -> rdom_ids_rule_filter prog min_ids rule) - prog.prog_rules - in - let inverted_rule_graph = - create_rule_graph - (fun r -> r.rule_out_vars) - (fun r -> r.rule_in_vars) - rdom_rules - in - let rules = - let rec add_connected_rules rid rules = - if IntMap.mem rid rules then rules - else - let edges = Option.get (IntMap.find rid inverted_rule_graph) in - let rules = IntMap.add rid (IntMap.find rid rdom_rules) rules in - IntMap.fold - (fun rid _ rules -> add_connected_rules rid rules) - edges rules - in - IntMap.fold - (fun rid _ rules -> add_connected_rules rid rules) - chain.chain_rules IntMap.empty - in - let rule_graph = - create_rule_graph - (fun r -> r.rule_in_vars) - (fun r -> r.rule_out_vars) - rules - in - let target_prog = - rule_graph_to_instrs (Chaining ch_name) prog rule_graph - in - let tname = - get_compute_id_str (Com.ComputeChaining (ch_name, Pos.no_pos)) prog - in - let target = - Mast. - { - target_name = (tname, Pos.no_pos); - target_file = None; - target_apps = StrMap.mapi (fun a p -> (a, p)) prog.prog_app; - target_args = []; - target_result = None; - target_tmp_vars = StrMap.empty; - target_prog; - target_nb_tmps = 0; - target_sz_tmps = 0; - target_nb_refs = 0; - } - in - StrMap.add tname target prog_targets) - prog.prog_chainings prog.prog_targets - in - { prog with prog_targets } - -let check_verif (v : Mast.verification) (prog : program) : program = - let verif_apps = - (* Already checked during preprocessing *) - StrMap.map (function _, pos -> pos) v.Mast.verif_apps - in - let vdom_id = - Com.DomainId.from_marked_list (Pos.unmark v.Mast.verif_tag_names) - in - let verif_domain = - let vid = - match Com.DomainIdMap.find_opt vdom_id prog.prog_vdom_syms with - | Some (vid, _) -> vid - | None -> - Err.unknown_domain Verif (Pos.get_position v.Mast.verif_tag_names) - in - Com.DomainIdMap.find vid prog.prog_vdoms - in - let prog_verifs, prog, _ = - List.fold_left - (fun (prog_verifs, prog, num) (cond, cond_pos) -> - let id, id_pos = v.Mast.verif_number in - let id = id + num in - let verif_id = (id, id_pos) in - let verif_expr = cond.Mast.verif_cond_expr in - let verif_error, verif_var = cond.Mast.verif_cond_error in - let err_name, err_pos = verif_error in - let verif_is_blocking = - match StrMap.find_opt err_name prog.prog_errors with - | None -> Err.unknown_error err_name err_pos - | Some err -> ( - match err.typ with Com.Error.Anomaly -> true | _ -> false) - in - (match verif_var with - | Some (var_name, var_pos) -> ( - match StrMap.find_opt var_name prog.prog_vars with - | None -> Err.unknown_variable var_name var_pos - | Some _ -> ()) - | None -> ()); - let verif_cat_var_stats, verif_var_stats = - let fold_var var idx_mem env (vdom_sts, var_sts) = - let name = Pos.unmark (check_variable var idx_mem env) in - let var_data = StrMap.find name env.prog.prog_vars in - let cat = Com.Var.cat var_data in - if not (Com.CatVar.Map.mem cat verif_domain.dom_data.vdom_auth) then - Err.variable_with_forbidden_category (Pos.get_position var); - let incr = function None -> Some 1 | Some i -> Some (i + 1) in - let vdom_sts = Com.CatVar.Map.update cat incr vdom_sts in - let var_sts = StrMap.update name incr var_sts in - (vdom_sts, var_sts) - in - let init = (Com.CatVar.Map.empty, StrMap.empty) in - let env = - { - prog; - tmp_vars = StrMap.empty; - ref_vars = StrMap.empty; - res_var = None; - } - in - fold_var_expr fold_var false init verif_expr env - in - let verif_seq, prog = get_seq prog in - let verif = - { - verif_id; - verif_apps; - verif_domain; - verif_expr; - verif_error; - verif_var; - verif_is_blocking; - verif_cat_var_stats; - verif_var_stats; - verif_seq; - } - in - (match IntMap.find_opt id prog.prog_verifs with - | Some v -> - let verif_pos = Pos.get_position v.verif_id in - Err.rov_already_defined Verif id verif_pos cond_pos - | None -> ()); - let prog_verifs = IntMap.add id verif prog_verifs in - (prog_verifs, prog, num + 1)) - (prog.prog_verifs, prog, 0) - v.Mast.verif_conditions - in - { prog with prog_verifs } - -let convert_verifs (prog : program) : program = - let prog_targets = - IntMap.fold - (fun id verif prog_targets -> - let tname = Format.sprintf "%s_verif_%d" prog.prog_prefix id in - let target_file = - Some (get_target_file (Pos.get_position verif.verif_id)) - in - let target_prog = - [ - ( Com.IfThenElse - ( verif.verif_expr, - [ - ( Com.RaiseError (verif.verif_error, verif.verif_var), - Pos.no_pos ); - ], - [] ), - Pos.no_pos ); - ] - in - let target = - Mast. - { - target_name = (tname, Pos.no_pos); - target_file; - target_apps = StrMap.mapi (fun a p -> (a, p)) prog.prog_app; - target_args = []; - target_result = None; - target_tmp_vars = StrMap.empty; - target_prog; - target_nb_tmps = 0; - target_sz_tmps = 0; - target_nb_refs = 0; - } - in - StrMap.add tname target prog_targets) - prog.prog_verifs prog.prog_targets - in - { prog with prog_targets } - -let eval_expr_verif (prog : program) (verif : verif) - (expr : Mast.expression Pos.marked) : float option = - let my_floor a = floor (a +. 0.000001) in - let _my_ceil a = ceil (a -. 0.000001) in - let my_arr a = - let my_var1 = floor a in - let my_var2 = ((a -. my_var1) *. 100000.0) +. 0.5 in - let my_var2 = floor my_var2 /. 100000.0 in - let my_var2 = my_var1 +. my_var2 +. 0.5 in - floor my_var2 - in - let rec aux expr = - match Pos.unmark expr with - | Com.Literal (Com.Float f) -> Some f - | Literal Com.Undefined -> None - | Var var -> Err.variable_forbidden_in_filter var (Pos.get_position expr) - | Attribut (m_var, m_attr) -> - let var = - match Pos.unmark m_var 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 - match Com.Var.is_table (StrMap.find var prog.prog_vars) with - | Some sz -> Some (float sz) - | None -> Some 1.0) - | NbCategory cs -> - let cats = mast_to_catvars cs prog.prog_var_cats in - let sum = - Com.CatVar.Map.fold - (fun cat _ sum -> - match Com.CatVar.Map.find_opt cat verif.verif_cat_var_stats with - | Some i -> sum + i - | None -> sum) - cats 0 - in - Some (float sum) - | Unop (op, e0) -> ( - match aux e0 with - | None -> None - | Some f -> ( - match op with Com.Not -> Some (1.0 -. f) | Com.Minus -> Some ~-.f)) - | FuncCall (func, args) -> ( - let rl = List.map aux args in - let unFunc f = - match rl with - | [ None ] -> None - | [ Some x ] -> Some (f x) - | _ -> assert false - in - let biFunc f = - match rl with - | [ None; None ] -> None - | [ None; r ] | [ r; None ] -> r - | [ Some x0; Some x1 ] -> Some (f x0 x1) - | _ -> assert false - in - match Pos.unmark func with - | Com.VerifNumber -> Some (float (Pos.unmark verif.verif_id)) - | Com.ComplNumber -> assert false - | Com.SumFunc -> - List.fold_left - (fun res r -> - match r with - | None -> res - | Some f -> ( - match res with None -> r | Some fr -> Some (f +. fr))) - None rl - | Com.AbsFunc -> unFunc abs_float - | Com.MinFunc -> biFunc min - | Com.MaxFunc -> biFunc max - | Com.GtzFunc -> unFunc (fun x -> if x > 0.0 then 1.0 else 0.0) - | Com.GtezFunc -> unFunc (fun x -> if x >= 0.0 then 1.0 else 0.0) - | Com.NullFunc -> unFunc (fun x -> if x = 0.0 then 1.0 else 0.0) - | Com.ArrFunc -> unFunc my_arr - | Com.InfFunc -> unFunc my_floor - | Com.Supzero -> ( - match rl with - | [ None ] -> None - | [ Some f ] when f = 0.0 -> None - | [ r ] -> r - | _ -> assert false) - | Com.PresentFunc | Com.Multimax | Com.Func _ -> assert false) - | Comparison (op, e0, e1) -> ( - match (aux e0, aux e1) with - | None, _ | _, None -> None - | Some f0, Some f1 -> ( - let open Com in - match Pos.unmark op with - | Gt -> Some (if f0 > f1 then 1.0 else 0.0) - | Gte -> Some (if f0 >= f1 then 1.0 else 0.0) - | Lt -> Some (if f0 < f1 then 1.0 else 0.0) - | Lte -> Some (if f0 <= f1 then 1.0 else 0.0) - | Eq -> Some (if f0 = f1 then 1.0 else 0.0) - | Neq -> Some (if f0 <> f1 then 1.0 else 0.0))) - | Binop (op, e0, e1) -> ( - let r0 = aux e0 in - let r1 = aux e1 in - match Pos.unmark op with - | Com.And -> ( - match r0 with - | None -> None - | Some f0 -> if f0 = 0.0 then r0 else r1) - | Com.Or -> ( - match r0 with None -> r1 | Some f0 -> if f0 = 0.0 then r1 else r0) - | Com.Add -> ( - match (r0, r1) with - | None, None -> None - | None, Some _ -> r1 - | Some _, None -> r0 - | Some f0, Some f1 -> Some (f0 +. f1)) - | Com.Sub -> ( - match (r0, r1) with - | None, None -> None - | None, Some _ -> r1 - | Some _, None -> r0 - | Some f0, Some f1 -> Some (f0 +. f1)) - | Com.Mul -> ( - match (r0, r1) with - | None, _ | _, None -> None - | Some f0, Some f1 -> Some (f0 *. f1)) - | Com.Div -> ( - match (r0, r1) with - | None, _ | _, None -> None - | Some f0, Some f1 -> if f1 = 0.0 then r1 else Some (f0 /. f1))) - | Conditional (e0, e1, e2) -> ( - let r0 = aux e0 in - let r1 = aux e1 in - let r2 = match e2 with Some e -> aux e | None -> None in - match r0 with None -> None | Some f -> if f = 1.0 then r1 else r2) - | TestInSet (positive, e, values) -> ( - match aux e with - | None -> None - | Some v -> - let res = - List.fold_left - (fun res set_value -> - match set_value with - | Com.VarValue _ -> assert false - | Com.FloatValue (f, _) -> res || f = v - | Com.Interval ((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 _ -> - assert false - in - aux expr - -let vdom_rule_filter (prog : program) (vdom : Com.verif_domain_data Com.domain) - (expr : Mast.expression Pos.marked) (verif : verif) : bool = - (match vdom.Com.dom_used with - | Some (vdom_seq, seq_pos) -> - if vdom_seq <= verif.verif_seq then - Err.domain_already_used Verif seq_pos (Pos.get_position verif.verif_id) - | None -> ()); - let filter_expr = - match eval_expr_verif prog verif expr with Some 1.0 -> true | _ -> false - in - let vdom_id = Pos.unmark vdom.dom_id in - let verif_vdom_id = Pos.unmark verif.verif_domain.dom_id in - filter_expr - && (Com.DomainId.equal vdom_id verif_vdom_id - || Com.DomainIdSet.mem verif_vdom_id vdom.Com.dom_min) - -module OrdVerif = struct - type t = int * int * int - - let make v = - let iBlock = if v.verif_is_blocking then 0 else 1 in - (iBlock, -v.verif_seq, Pos.unmark v.verif_id) - - let get_id (_, _, id) = id - - let compare x y = compare x y -end - -module OrdVerifSet = struct - include SetExt.Make (OrdVerif) - - let _pp ?(sep = " ") - ?(pp_elt = - fun fmt (i, j, k) -> Format.fprintf fmt "(%d, %d, %d)" i (-j) k) - (_ : unit) (fmt : Format.formatter) (set : t) : unit = - pp ~sep ~pp_elt () fmt set -end - -module OrdVerifSetMap = struct - include MapExt.Make (OrdVerifSet) - - let _pp ?(sep = ", ") ?(pp_key = OrdVerifSet.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 - -let complete_verif_calls (prog : program) : program = - let prog_targets, _ = - StrMap.fold - (fun tname (_, vdom_id, expr) (prog_targets, verif_calls) -> - let verif_set = - IntMap.fold - (fun _verif_id verif verif_set -> - let vdom = Com.DomainIdMap.find vdom_id prog.prog_vdoms in - if vdom_rule_filter prog vdom expr verif then - OrdVerifSet.add (OrdVerif.make verif) verif_set - else verif_set) - prog.prog_verifs OrdVerifSet.empty - in - match OrdVerifSetMap.find_opt verif_set verif_calls with - | Some tn -> - let target_prog = - [ (Com.ComputeTarget ((tn, Pos.no_pos), []), Pos.no_pos) ] - in - let target = - Mast. - { - target_name = (tname, Pos.no_pos); - target_file = None; - target_apps = StrMap.mapi (fun a p -> (a, p)) prog.prog_app; - target_args = []; - target_result = None; - target_tmp_vars = StrMap.empty; - target_prog; - target_nb_tmps = 0; - target_sz_tmps = 0; - target_nb_refs = 0; - } - in - let prog_targets = StrMap.add tname target prog_targets in - (prog_targets, verif_calls) - | None -> - let instrs = - let instrs = - OrdVerifSet.fold - (fun ord_verif target_prog -> - let verif_id = OrdVerif.get_id ord_verif in - let verif_tn = - Format.sprintf "%s_verif_%d" prog.prog_prefix verif_id - in - (Com.ComputeTarget ((verif_tn, Pos.no_pos), []), Pos.no_pos) - :: target_prog) - verif_set [] - in - List.rev instrs - in - let target_prog = [ (Com.VerifBlock instrs, Pos.no_pos) ] in - let target = - Mast. - { - target_name = (tname, Pos.no_pos); - target_file = None; - target_apps = StrMap.mapi (fun a p -> (a, p)) prog.prog_app; - target_args = []; - target_result = None; - target_tmp_vars = StrMap.empty; - target_prog; - target_nb_tmps = 0; - target_sz_tmps = 0; - target_nb_refs = 0; - } - in - let prog_targets = StrMap.add tname target prog_targets in - let verif_calls = OrdVerifSetMap.add verif_set tname verif_calls in - (prog_targets, verif_calls)) - prog.prog_vdom_calls - (prog.prog_targets, OrdVerifSetMap.empty) - in - { prog with prog_targets } - -let proceed (p : Mast.program) (main_target : string) : program = - (* à paramétrer *) - let prog = - List.fold_left - (fun prog source_file -> - List.fold_left - (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.Error error -> check_error error prog - | Mast.Func -> prog (* unused *) - | Mast.Output _ -> prog (* unused *) - | Mast.RuleDomDecl decl -> check_rule_dom_decl decl prog - | Mast.VerifDomDecl decl -> check_verif_dom_decl decl prog - | Mast.Function f -> check_target true f prog - | Mast.Target t -> check_target false t prog - | Mast.Rule r -> check_rule r prog - | Mast.Verification v -> check_verif v prog) - prog source_file) - (empty_program p main_target) - p - in - prog |> complete_rdom_decls |> complete_vdom_decls |> convert_rules - |> complete_rule_domains |> complete_chainings |> convert_verifs - |> complete_verif_calls |> complete_vars diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expander.ml similarity index 63% rename from src/mlang/m_frontend/expand_macros.ml rename to src/mlang/m_frontend/expander.ml index 5b00c523e..a91bbb551 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expander.ml @@ -14,13 +14,19 @@ module Err = struct let constant_already_defined old_pos pos = Errors.raise_spanned_error - (Format.asprintf "constant already defined %a" Pos.format_position old_pos) + (Format.asprintf "constant already defined %a" Pos.format old_pos) pos let unknown_constant pos = Errors.raise_spanned_error "unknown constant" pos + let table_size_must_be_int pos = + Errors.raise_spanned_error "table size must be an integer" pos + let table_size_must_be_positive pos = - Errors.raise_spanned_error "table size must be a positive integer" pos + Errors.raise_spanned_error "table size must be positive" pos + + let table_cannot_be_empty pos = + Errors.raise_spanned_error "table cannot be empty" pos let unbounded_parameter_in_variable_name p pos = Errors.raise_spanned_error @@ -69,6 +75,9 @@ module Err = struct let constant_cannot_have_a_size pos = Errors.raise_spanned_error "constant cannot have a size" pos + let constant_cannot_have_a_name pos = + Errors.raise_spanned_error "constant cannot have a name" pos + let constant_forbidden_as_lvalue pos = Errors.raise_spanned_error "constant forbidden as lvalue" pos @@ -85,15 +94,13 @@ module Err = struct let application_already_defined app old_pos pos = let msg = - Format.asprintf "application %s already defined %a" app - Pos.format_position old_pos + Format.asprintf "application %s already defined %a" app Pos.format old_pos in Errors.raise_spanned_error msg pos let chaining_already_defined ch old_pos pos = let msg = - Format.asprintf "chaining %s already defined %a" ch Pos.format_position - old_pos + Format.asprintf "chaining %s already defined %a" ch Pos.format old_pos in Errors.raise_spanned_error msg pos @@ -120,9 +127,9 @@ let empty_apps_env (cli_apps : string list) : apps_env = let get_selected_apps (apps_env : apps_env) (apps : Mast.application Pos.marked StrMap.t) : Mast.application Pos.marked StrMap.t = - let sel_app _ (a, apos) apps = + let sel_app _ (Pos.Mark (a, apos)) apps = match StrMap.find_opt a apps_env.apps with - | Some (b, _) -> if b then StrMap.add a (a, apos) apps else apps + | Some (b, _) -> if b then StrMap.add a (Pos.mark a apos) apps else apps | None -> Err.unknown_application a apos in StrMap.fold sel_app apps StrMap.empty @@ -130,9 +137,9 @@ let get_selected_apps (apps_env : apps_env) let get_selected_apps_list (apps_env : apps_env) (apps : Mast.application Pos.marked list) : Mast.application Pos.marked list = - let sel_app apps (a, apos) = + let sel_app apps (Pos.Mark (a, apos)) = match StrMap.find_opt a apps_env.apps with - | Some (b, _) -> if b then (a, apos) :: apps else apps + | Some (b, _) -> if b then Pos.mark a apos :: apps else apps | None -> Err.unknown_application a apos in List.rev (List.fold_left sel_app [] apps) @@ -140,9 +147,10 @@ let get_selected_apps_list (apps_env : apps_env) let get_selected_chains (apps_env : apps_env) (chains : Mast.chaining Pos.marked StrMap.t) : Mast.chaining Pos.marked StrMap.t = - let sel_chain _ (ch, chpos) chains = + let sel_chain _ (Pos.Mark (ch, chpos)) chains = match StrMap.find_opt ch apps_env.chains with - | Some (b, _) -> if b then StrMap.add ch (ch, chpos) chains else chains + | Some (b, _) -> + if b then StrMap.add ch (Pos.mark ch chpos) chains else chains | None -> Err.unknown_chaining ch chpos in StrMap.fold sel_chain chains StrMap.empty @@ -162,10 +170,9 @@ let elim_unselected_apps (p : Mast.program) : Mast.program = (fun (apps_env, prog) source_file -> let apps_env, prog_file = List.fold_left - (fun (apps_env, prog_file) source_item -> - let item, pos_item = source_item in - match item with - | Mast.Application (app, pos) -> ( + (fun (apps_env, prog_file) m_item -> + match Pos.unmark m_item with + | Mast.Application (Pos.Mark (app, pos)) -> ( match StrMap.find_opt app apps_env.apps with | Some (_, old_pos) -> Err.application_already_defined app old_pos pos @@ -174,11 +181,11 @@ let elim_unselected_apps (p : Mast.program) : Mast.program = let apps = StrMap.add app (is_sel, pos) apps_env.apps in let apps_env = { apps_env with apps } in let prog_file = - if is_sel then source_item :: prog_file else prog_file + if is_sel then m_item :: prog_file else prog_file in (apps_env, prog_file)) - | Mast.Chaining (mch, mal) -> ( - let ch, pos = mch in + | Mast.Chaining (m_ch, mal) -> ( + let ch, pos = Pos.to_couple m_ch in match StrMap.find_opt ch apps_env.chains with | Some (_, old_pos) -> Err.chaining_already_defined ch old_pos pos @@ -192,7 +199,7 @@ let elim_unselected_apps (p : Mast.program) : Mast.program = let prog_file = if is_sel then let new_item = - (Mast.Chaining (mch, sel_apps), pos_item) + Pos.same (Mast.Chaining (m_ch, sel_apps)) m_item in new_item :: prog_file else prog_file @@ -208,7 +215,9 @@ let elim_unselected_apps (p : Mast.program) : Mast.program = let rule = { rule with Mast.rule_apps; Mast.rule_chainings } in - let prog_file = (Mast.Rule rule, pos_item) :: prog_file in + let prog_file = + Pos.same (Mast.Rule rule) m_item :: prog_file + in (apps_env, prog_file) | Mast.Verification verif -> let verif_apps = @@ -216,9 +225,9 @@ let elim_unselected_apps (p : Mast.program) : Mast.program = in if StrMap.is_empty verif_apps then (apps_env, prog_file) else - let verif = { verif with Mast.verif_apps } in + let verif = Mast.{ verif with verif_apps } in let prog_file = - (Mast.Verification verif, pos_item) :: prog_file + Pos.same (Mast.Verification verif) m_item :: prog_file in (apps_env, prog_file) | Mast.Target target -> @@ -227,9 +236,9 @@ let elim_unselected_apps (p : Mast.program) : Mast.program = in if StrMap.is_empty target_apps then (apps_env, prog_file) else - let target = { target with Mast.target_apps } in + let target = Mast.{ target with target_apps } in let prog_file = - (Mast.Target target, pos_item) :: prog_file + Pos.same (Mast.Target target) m_item :: prog_file in (apps_env, prog_file) | Mast.Function target -> @@ -238,14 +247,15 @@ let elim_unselected_apps (p : Mast.program) : Mast.program = in if StrMap.is_empty target_apps then (apps_env, prog_file) else - let target = { target with Mast.target_apps } in + let target = Mast.{ target with target_apps } in let prog_file = - (Mast.Function target, pos_item) :: prog_file + Pos.same (Mast.Function target) m_item :: prog_file in (apps_env, prog_file) - | VariableDecl _ | Error _ | Output _ | Func | VarCatDecl _ - | RuleDomDecl _ | VerifDomDecl _ -> - (apps_env, source_item :: prog_file)) + | VariableDecl _ | EventDecl _ | Error _ | Output _ | Func + | VarCatDecl _ | RuleDomDecl _ | VerifDomDecl _ + | VariableSpaceDecl _ -> + (apps_env, m_item :: prog_file)) (apps_env, []) source_file in (apps_env, List.rev prog_file :: prog)) @@ -268,7 +278,7 @@ module ParamsMap = struct pp ~sep ~pp_key ~assoc pp_val fmt map end -type loop_param_value = VarName of Mast.variable_name | RangeInt of int +type loop_param_value = VarName of string | RangeInt of int type loop_context = (loop_param_value * int) ParamsMap.t @@ -285,43 +295,48 @@ let format_loop_context fmt (ld : loop_context) = let format_loop_domain fmt (ld : loop_domain) = ParamsMap.pp (Pp.list_comma format_loop_param_value) fmt ld -let add_const (name, name_pos) (cval, cval_pos) const_map = +let add_const (Pos.Mark (name, name_pos)) (Pos.Mark (cval, cval_pos)) const_map + = match ConstMap.find_opt name const_map with - | Some (_, old_pos) -> Err.constant_already_defined old_pos name_pos + | Some (Pos.Mark (_, old_pos)) -> + Err.constant_already_defined old_pos name_pos | None -> ( match cval with | Com.AtomLiteral (Com.Float f) -> - ConstMap.add name (f, name_pos) const_map - | Com.AtomVar (Mast.Normal const) -> ( + ConstMap.add name (Pos.mark f name_pos) const_map + | Com.AtomVar (Pos.Mark (Com.Normal const, _)) -> ( match ConstMap.find_opt const const_map with - | Some (value, _) -> ConstMap.add name (value, name_pos) const_map + | Some (Pos.Mark (value, _)) -> + ConstMap.add name (Pos.mark value name_pos) const_map | None -> Err.unknown_constant cval_pos) | _ -> assert false) let expand_table_size (const_map : const_context) table_size = match table_size with - | Some (Mast.SymbolSize c, size_pos) -> ( + | Some (Pos.Mark (Mast.SymbolSize c, size_pos)) -> ( match ConstMap.find_opt c const_map with - | Some (f, _) -> + | Some (Pos.Mark (f, _)) -> let i = int_of_float f in - if f = float i && i >= 0 then Some (Mast.LiteralSize i, size_pos) - else Err.table_size_must_be_positive size_pos + if f <> float i then Err.table_size_must_be_int size_pos + else if i < 0 then Err.table_size_must_be_positive size_pos + else if i = 0 then Err.table_cannot_be_empty size_pos + else Some (Pos.mark (Mast.LiteralSize i) size_pos) | None -> Err.unknown_constant size_pos) | _ -> table_size let rec expand_variable (const_map : const_context) (loop_map : loop_context) - (m_var : Mast.variable Pos.marked) : Mast.expression Pos.marked = - let var, var_pos = m_var in - match var with - | Mast.Normal name -> ( + (m_var : Com.m_var_name) : Com.m_var_name Com.atom Pos.marked = + match Pos.unmark m_var with + | Com.Normal name -> ( match ConstMap.find_opt name const_map with - | Some (f, _) -> (Com.Literal (Float f), var_pos) - | None -> (Com.Var var, var_pos)) - | Mast.Generic gen_name -> - if List.length gen_name.Mast.parameters == 0 then + | Some (Pos.Mark (f, _)) -> Pos.same (Com.AtomLiteral (Float f)) m_var + | None -> Pos.same (Com.AtomVar m_var) m_var) + | Com.Generic gen_name -> + if List.length gen_name.Com.parameters == 0 then expand_variable const_map loop_map - (Mast.Normal gen_name.Mast.base, var_pos) - else instantiate_params const_map loop_map gen_name.Mast.base var_pos + (Pos.same (Com.Normal gen_name.Com.base) m_var) + else + instantiate_params const_map loop_map gen_name.Com.base (Pos.get m_var) and check_var_name (var_name : string) (var_pos : Pos.t) : unit = for i = String.length var_name - 1 downto 0 do @@ -334,11 +349,11 @@ 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) : Com.m_var_name Com.atom Pos.marked = match ParamsMap.choose_opt loop_map with | None -> check_var_name var_name pos; - expand_variable const_map loop_map (Mast.Normal var_name, pos) + expand_variable const_map loop_map (Pos.mark (Com.Normal var_name) pos) | Some (param, (value, size)) -> let new_var_name = match value with @@ -386,7 +401,7 @@ let merge_loop_context (loop_map : loop_context) (lmap : loop_context) In thes example above, [Xi] will become [X5] because there are no string or integer above 9 in the list of possible values. *) -type var_or_int_index = VarIndex of Mast.variable | IntIndex of int +type var_or_int_index = VarIndex of Com.var_name | IntIndex of int (** The M language added a new feature in its 2017 edition : you can specify loop variable ranges bounds with constant variables. Because we need the @@ -394,22 +409,21 @@ type var_or_int_index = VarIndex of Mast.variable | IntIndex of int const value in the context if needed. Otherwise, it might be a dynamic index. *) let var_or_int_value (const_map : const_context) - (m_atom : Mast.variable Com.atom Pos.marked) : var_or_int_index = + (m_atom : Com.m_var_name Com.atom Pos.marked) : var_or_int_index = match Pos.unmark m_atom with - | Com.AtomVar v -> ( - let name = Mast.get_variable_name v in + | Com.AtomVar m_v -> ( + let name = Com.get_var_name (Pos.unmark m_v) in match ConstMap.find_opt name const_map with - | Some (fvalue, _) -> IntIndex (int_of_float fvalue) - | None -> VarIndex v) + | Some (Pos.Mark (fvalue, _)) -> IntIndex (int_of_float fvalue) + | None -> VarIndex (Pos.unmark m_v)) | Com.AtomLiteral (Com.Float f) -> IntIndex (int_of_float f) | Com.AtomLiteral Com.Undefined -> assert false -let var_or_int (m_atom : Mast.variable Com.atom Pos.marked) = - let atom, atom_pos = m_atom in - match atom with - | Com.AtomVar (Normal v) -> VarName v - | Com.AtomVar (Generic _) -> - Err.generic_variable_not_allowed_in_left_part_of_loop atom_pos +let var_or_int (m_atom : Com.m_var_name Com.atom Pos.marked) = + match Pos.unmark m_atom with + | Com.AtomVar (Pos.Mark (Normal v, _)) -> VarName v + | Com.AtomVar (Pos.Mark (Generic _, _)) -> + Err.generic_variable_not_allowed_in_left_part_of_loop (Pos.get m_atom) | Com.AtomLiteral (Com.Float f) -> RangeInt (int_of_float f) | Com.AtomLiteral Com.Undefined -> assert false @@ -448,18 +462,18 @@ let make_var_range_list (v1 : string) (v2 : string) : loop_param_value list = in aux (Char.code v1.[0]) (Char.code v2.[0]) -let make_range_list (l1 : Mast.variable Com.atom Pos.marked) - (l2 : Mast.variable Com.atom Pos.marked) : loop_param_value list = +let make_range_list (l1 : Com.m_var_name Com.atom Pos.marked) + (l2 : Com.m_var_name Com.atom Pos.marked) : loop_param_value list = let length_err p = Err.non_numeric_range_bounds_must_be_a_single_character p in match (var_or_int l1, var_or_int l2) with | RangeInt i1, RangeInt i2 -> make_int_range_list i1 i2 | VarName v1, VarName v2 -> - if String.length v1 <> 1 then length_err (Pos.get_position l1); - if String.length v2 <> 1 then length_err (Pos.get_position l2); + if String.length v1 <> 1 then length_err (Pos.get l1); + if String.length v2 <> 1 then length_err (Pos.get l2); make_var_range_list v1 v2 - | _ -> Err.range_bounds_must_be_of_the_same_type (Pos.get_position l2) + | _ -> Err.range_bounds_must_be_of_the_same_type (Pos.get l2) (** From a loop domain of varying loop parameters, builds by cartesian product the list of all iterations that the loop will take, each time assigining a @@ -498,9 +512,9 @@ let rec iterate_all_combinations (ld : loop_domain) : loop_context list = merge_loop_ctx} inside [...] before translating the loop body. [lc] is the loop context, [i] the loop sequence index and [ctx] the translation context. *) -let expand_loop_variables (lvs : Mast.variable Com.loop_variables Pos.marked) +let expand_loop_variables (lvs : Com.m_var_name Com.loop_variables Pos.marked) (const_map : const_context) : (loop_context -> 'a) -> 'a list = - let pos = Pos.get_position lvs in + let pos = Pos.get lvs in match Pos.unmark lvs with | Com.ValueSets lvs | Com.Ranges lvs -> let varying_domain = @@ -519,7 +533,7 @@ let expand_loop_variables (lvs : Mast.variable Com.loop_variables Pos.marked) match (lb, ub) with | VarIndex v, _ | _, VarIndex v -> Err.variable_is_not_an_integer_constant - (Mast.get_variable_name v) pos + (Com.get_var_name v) pos | IntIndex lb, IntIndex ub -> make_int_range_list lb ub )) values) @@ -532,46 +546,82 @@ let expand_loop_variables (lvs : Mast.variable Com.loop_variables Pos.marked) let loop_map_list = iterate_all_combinations varying_domain in fun translator -> List.map translator loop_map_list -let rec expand_expression (const_map : const_context) (loop_map : loop_context) +type 'v access_or_literal = + | ExpAccess of 'v Com.m_access + | ExpLiteral of Com.literal + +let rec expand_access (const_map : const_context) (loop_map : loop_context) + (Pos.Mark (a, a_pos) : Com.m_var_name Com.m_access) : + Com.m_var_name access_or_literal = + match a with + | VarAccess m_v -> ( + match expand_variable const_map loop_map m_v with + | Pos.Mark (AtomLiteral lit, _) -> ExpLiteral lit + | Pos.Mark (AtomVar m_v, var_pos) -> + ExpAccess (Pos.mark (Com.VarAccess m_v) var_pos)) + | TabAccess (m_v, m_i) -> ( + match expand_variable const_map loop_map m_v with + | Pos.Mark (AtomLiteral _, v_pos) -> Err.constant_forbidden_as_table v_pos + | Pos.Mark (AtomVar m_v, v_pos) -> + let m_i' = expand_expression const_map loop_map m_i in + ExpAccess (Pos.mark (Com.TabAccess (m_v, m_i')) v_pos)) + | ConcAccess (m_v, m_if, i) -> ( + match expand_variable const_map loop_map m_v with + | Pos.Mark (AtomLiteral _, v_pos) -> Err.constant_forbidden_as_arg v_pos + | Pos.Mark (AtomVar m_v, v_pos) -> ( + match expand_expression const_map loop_map i with + | Pos.Mark (Com.Literal Undefined, i_pos) -> + Err.constant_forbidden_as_arg i_pos + | Pos.Mark (Com.Literal (Float f), i_pos) -> + let fi = int_of_float f in + if fi < 0 then Err.constant_forbidden_as_arg i_pos; + let m_v' = + match Pos.unmark m_v with + | Com.Normal n -> + let n' = Strings.concat_int n (Pos.unmark m_if) fi in + Pos.mark (Com.Normal n') v_pos + | _ -> assert false + in + ExpAccess (Pos.mark (Com.VarAccess m_v') a_pos) + | i' -> + ExpAccess + (Pos.mark + (Com.ConcAccess (Pos.mark (Pos.unmark m_v) v_pos, m_if, i')) + a_pos))) + | FieldAccess (e, f, i_f) -> + let e' = expand_expression const_map loop_map e in + ExpAccess (Pos.mark (Com.FieldAccess (e', f, i_f)) a_pos) + +and expand_expression (const_map : const_context) (loop_map : loop_context) (m_expr : Mast.expression Pos.marked) : Mast.expression Pos.marked = let open Com in - let expr, expr_pos = m_expr in - match expr with + match Pos.unmark m_expr with | TestInSet (positive, e, values) -> let e' = expand_expression const_map loop_map e in let values' = List.map (fun set_value -> 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) + | VarValue (Pos.Mark (a, a_pos)) -> ( + match expand_access const_map loop_map (Pos.mark a a_pos) with + | ExpLiteral (Float f) -> FloatValue (Pos.mark f a_pos) + | ExpAccess m_a -> VarValue m_a | _ -> assert false) - | FloatValue _ | Interval _ -> set_value) + | FloatValue _ | IntervalValue _ -> set_value) values in - (TestInSet (positive, e', values'), expr_pos) + Pos.same (TestInSet (positive, e', values')) m_expr | Comparison (op, e1, e2) -> let e1' = expand_expression const_map loop_map e1 in let e2' = expand_expression const_map loop_map e2 in - (Comparison (op, e1', e2'), expr_pos) + Pos.same (Comparison (op, e1', e2')) m_expr | Binop (op, e1, e2) -> let e1' = expand_expression const_map loop_map e1 in let e2' = expand_expression const_map loop_map e2 in - (Binop (op, e1', e2'), expr_pos) + Pos.same (Binop (op, e1', e2')) m_expr | 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 - | Var v, v_pos -> (v, v_pos) - | Literal (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) + Pos.same (Unop (op, e')) m_expr | 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 @@ -580,82 +630,102 @@ let rec expand_expression (const_map : const_context) (loop_map : loop_context) | Some e3 -> Some (expand_expression const_map loop_map e3) | None -> None in - (Conditional (e1', e2', e3_opt'), expr_pos) + Pos.same (Conditional (e1', e2', e3_opt')) m_expr | FuncCall (f_name, args) -> let args' = List.map (fun arg -> expand_expression const_map loop_map arg) args in - (FuncCall (f_name, args'), expr_pos) + Pos.same (FuncCall (f_name, args')) m_expr | FuncCallLoop (f_name, lvs, e) -> let loop_context_provider = expand_loop_variables lvs const_map in let translator lmap = - let loop_map = - merge_loop_context loop_map lmap (Pos.get_position lvs) - in + let loop_map = merge_loop_context loop_map lmap (Pos.get lvs) in expand_expression const_map loop_map e in let args' = loop_context_provider translator in - (FuncCall (f_name, args'), expr_pos) + Pos.same (FuncCall (f_name, args')) m_expr | Literal _ -> m_expr - | Var v -> expand_variable const_map loop_map (v, expr_pos) + | Var a -> ( + match expand_access const_map loop_map (Pos.same a m_expr) with + | ExpLiteral l -> Pos.same (Literal l) m_expr + | ExpAccess (Pos.Mark (a', _)) -> Pos.same (Var a') m_expr) | Loop (lvs, e) -> let loop_context_provider = expand_loop_variables lvs const_map in let translator lmap = - let loop_map = - merge_loop_context loop_map lmap (Pos.get_position lvs) - in + let loop_map = merge_loop_context loop_map lmap (Pos.get lvs) in expand_expression const_map loop_map e in let loop_exprs = loop_context_provider translator in List.fold_left (fun res loop_expr -> - (Binop ((Or, expr_pos), res, loop_expr), expr_pos)) - (Literal (Float 0.0), expr_pos) + Pos.same (Binop (Pos.same Or m_expr, res, loop_expr)) m_expr) + (Pos.same (Literal (Float 0.0)) m_expr) 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 - | _ -> assert false) - | 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 - | _ -> assert false) + | Attribut (Pos.Mark (a, a_pos), attr) -> ( + match expand_access const_map loop_map (Pos.same a m_expr) with + | ExpLiteral _ -> Err.constant_cannot_have_an_attribut a_pos + | ExpAccess m_a -> Pos.same (Attribut (m_a, attr)) m_expr) + | Size (Pos.Mark (a, a_pos)) -> ( + match expand_access const_map loop_map (Pos.same a m_expr) with + | ExpLiteral _ -> Err.constant_cannot_have_a_size a_pos + | ExpAccess m_a -> Pos.same (Size m_a) m_expr) + | IsVariable (Pos.Mark (a, a_pos), name) -> ( + match expand_access const_map loop_map (Pos.same a m_expr) with + | ExpLiteral _ -> Err.constant_cannot_have_a_name a_pos + | ExpAccess m_a -> Pos.same (IsVariable (m_a, name)) m_expr) | NbCategory _ | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes -> m_expr let expand_formula (const_map : const_context) - (prev : Mast.variable Com.formula Pos.marked list) - (m_form : Mast.variable Com.formula Pos.marked) : - Mast.variable Com.formula Pos.marked list = - let form, form_pos = m_form in - match form with - | Com.SingleFormula (v, idx, e) -> + (prev : Com.m_var_name Com.formula Pos.marked list) + (m_form : Com.m_var_name Com.formula Pos.marked) : + Com.m_var_name Com.formula Pos.marked list = + match Pos.unmark m_form with + | Com.SingleFormula (VarDecl (m_access, e)) -> + let m_access' = + match expand_access const_map ParamsMap.empty m_access with + | ExpLiteral _ -> Err.constant_forbidden_as_lvalue (Pos.get m_access) + | ExpAccess m_a -> m_a + in + let e' = expand_expression const_map ParamsMap.empty e in + Pos.same (Com.SingleFormula (VarDecl (m_access', e'))) m_form :: 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 -> + | Pos.Mark (AtomVar m_v, v_pos) -> Pos.mark (Pos.unmark m_v) v_pos + | Pos.Mark (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 - let e' = expand_expression const_map ParamsMap.empty e in - (Com.SingleFormula (v', idx', e'), form_pos) :: prev - | Com.MultipleFormulaes (lvs, (v, idx, e)) -> + let form = Com.SingleFormula (EventFieldRef (idx', f, i, v')) in + Pos.same form m_form :: prev + | Com.MultipleFormulaes (lvs, VarDecl (m_access, e)) -> + let loop_context_provider = expand_loop_variables lvs const_map in + let translator loop_map = + let m_access' = + match expand_access const_map loop_map m_access with + | ExpLiteral _ -> Err.constant_forbidden_as_lvalue (Pos.get m_access) + | ExpAccess m_a -> m_a + in + let e' = expand_expression const_map loop_map e in + Pos.same (Com.SingleFormula (VarDecl (m_access', e'))) m_form + 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 -> + | Pos.Mark (AtomVar m_v, v_pos) -> Pos.mark (Pos.unmark m_v) v_pos + | Pos.Mark (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 (v', idx', e'), form_pos) + Pos.same (Com.SingleFormula (EventFieldRef (idx', f, i, v'))) m_form in let res = loop_context_provider translator in List.rev res @ prev @@ -663,18 +733,17 @@ let expand_formula (const_map : const_context) let rec expand_instruction (const_map : const_context) (prev : Mast.instruction Pos.marked list) (m_instr : Mast.instruction Pos.marked) : Mast.instruction Pos.marked list = - let instr, instr_pos = m_instr in - match instr with + match Pos.unmark m_instr with | Com.Affectation m_form -> let m_forms = expand_formula const_map [] m_form in List.fold_left - (fun res f -> (Com.Affectation f, instr_pos) :: res) + (fun res f -> Pos.same (Com.Affectation f) m_instr :: res) prev m_forms | Com.IfThenElse (expr, ithen, ielse) -> let expr' = expand_expression const_map ParamsMap.empty expr in let ithen' = expand_instructions const_map ithen in let ielse' = expand_instructions const_map ielse in - (Com.IfThenElse (expr', ithen', ielse'), instr_pos) :: prev + Pos.same (Com.IfThenElse (expr', ithen', ielse')) m_instr :: prev | Com.WhenDoElse (wdl, ed) -> let map (expr, dl, pos) = let expr' = expand_expression const_map ParamsMap.empty expr in @@ -682,23 +751,29 @@ let rec expand_instruction (const_map : const_context) (expr', dl', pos) in let wdl' = List.map map wdl in - let ed' = Pos.map_under_mark (expand_instructions const_map) ed in - (Com.WhenDoElse (wdl', ed'), instr_pos) :: prev + let ed' = Pos.map (expand_instructions const_map) ed in + Pos.same (Com.WhenDoElse (wdl', ed')) m_instr :: prev | Com.Print (std, pr_args) -> let pr_args' = List.map (fun arg -> match Pos.unmark arg with + | Com.PrintAccess (info, m_a) -> ( + match expand_access const_map ParamsMap.empty m_a with + | ExpLiteral _ -> Err.constant_forbidden_as_arg (Pos.get m_a) + | ExpAccess (Pos.Mark (a', _)) -> + let arg' = Com.PrintAccess (info, Pos.same a' m_a) in + Pos.same arg' arg) | Com.PrintIndent expr -> let expr' = expand_expression const_map ParamsMap.empty expr in - (Com.PrintIndent expr', Pos.get_position arg) + Pos.same (Com.PrintIndent expr') arg | Com.PrintExpr (expr, mi, ma) -> let expr' = expand_expression const_map ParamsMap.empty expr in - (Com.PrintExpr (expr', mi, ma), Pos.get_position arg) - | Com.PrintString _ | Com.PrintName _ | Com.PrintAlias _ -> arg) + Pos.same (Com.PrintExpr (expr', mi, ma)) arg + | Com.PrintString _ -> arg) pr_args in - (Com.Print (std, pr_args'), instr_pos) :: prev + Pos.same (Com.Print (std, pr_args')) m_instr :: prev | Com.Iterate (name, vars, var_params, instrs) -> let var_params' = List.map @@ -708,27 +783,81 @@ let rec expand_instruction (const_map : const_context) var_params in let instrs' = expand_instructions const_map instrs in - (Com.Iterate (name, vars, var_params', instrs'), instr_pos) :: prev - | Com.Restore (vars, var_params, instrs) -> + Pos.same (Com.Iterate (name, vars, var_params', instrs')) m_instr :: prev + | Com.Iterate_values (name, var_intervals, instrs) -> + let var_intervals' = + List.map + (fun (e0, e1, step) -> + let e0' = expand_expression const_map ParamsMap.empty e0 in + let e1' = expand_expression const_map ParamsMap.empty e1 in + let step' = expand_expression const_map ParamsMap.empty step in + (e0', e1', step')) + var_intervals + in let instrs' = expand_instructions const_map instrs in - (Com.Restore (vars, var_params, instrs'), instr_pos) :: prev + let instr' = Com.Iterate_values (name, var_intervals', instrs') in + Pos.same instr' m_instr :: prev + | Com.Restore (vars, var_params, evts, evtfs, 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 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 + let instr' = Com.Restore (vars, var_params', evts', evtfs', instrs') in + Pos.same instr' m_instr :: prev + | Com.ArrangeEvents (sort, filter, add, 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 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 + let instr' = Com.ArrangeEvents (sort', filter', add', instrs') in + Pos.same instr' m_instr :: prev | Com.VerifBlock instrs -> let instrs' = expand_instructions const_map instrs in - (Com.VerifBlock instrs', instr_pos) :: prev + Pos.same (Com.VerifBlock instrs') m_instr :: prev | 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 -> + | Pos.Mark (AtomVar m_v, v_pos) -> Pos.mark (Pos.unmark m_v) v_pos + | Pos.Mark (AtomLiteral (Float _), v_pos) -> Err.constant_forbidden_as_arg v_pos | _ -> assert false in let targs' = List.map map targs in - (Com.ComputeTarget (tn, targs'), instr_pos) :: prev + Pos.same (Com.ComputeTarget (tn, targs')) m_instr :: prev | Com.ComputeVerifs _ | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.RaiseError _ | Com.CleanErrors | Com.ExportErrors | Com.FinalizeErrors -> - (instr, instr_pos) :: prev + m_instr :: prev and expand_instructions (const_map : const_context) (instrs : Mast.instruction Pos.marked list) : @@ -741,30 +870,30 @@ let elim_constants_and_loops (p : Mast.program) : Mast.program = (fun (const_map, prog) source_file -> let const_map, prog_file = List.fold_left - (fun (const_map, prog_file) source_item -> - let item, pos_item = source_item in - match item with + (fun (const_map, prog_file) m_item -> + match Pos.unmark m_item with | Mast.VariableDecl var_decl -> ( match var_decl with | Mast.ConstVar (m_name, m_cval) -> let const_map = add_const m_name m_cval const_map in (const_map, prog_file) - | Mast.ComputedVar (cvar, pos_cvar) -> + | Mast.ComputedVar (Pos.Mark (cvar, pos_cvar)) -> let comp_table = expand_table_size const_map cvar.Mast.comp_table in let var_decl' = Mast.ComputedVar - ({ cvar with Mast.comp_table }, pos_cvar) + (Pos.mark { cvar with Mast.comp_table } pos_cvar) in let prog_file = - (Mast.VariableDecl var_decl', pos_item) :: prog_file + Pos.same (Mast.VariableDecl var_decl') m_item + :: prog_file in (const_map, prog_file) - | _ -> (const_map, source_item :: prog_file)) + | _ -> (const_map, m_item :: prog_file)) | Mast.Rule rule -> let rule_tmp_vars = - StrMap.map + List.map (fun (name, tsz) -> (name, expand_table_size const_map tsz)) rule.Mast.rule_tmp_vars @@ -775,27 +904,29 @@ let elim_constants_and_loops (p : Mast.program) : Mast.program = let rule' = { rule with Mast.rule_tmp_vars; Mast.rule_formulaes } in - let prog_file = (Mast.Rule rule', pos_item) :: prog_file in + let prog_file = + Pos.same (Mast.Rule rule') m_item :: prog_file + in (const_map, prog_file) | Mast.Verification verif -> let verif_conditions = List.map - (fun (cond, cond_pos) -> + (fun (Pos.Mark (cond, cond_pos)) -> let verif_cond_expr = expand_expression const_map ParamsMap.empty cond.Mast.verif_cond_expr in - ({ cond with Mast.verif_cond_expr }, cond_pos)) + Pos.mark { cond with Mast.verif_cond_expr } cond_pos) verif.Mast.verif_conditions in let verif' = { verif with Mast.verif_conditions } in let prog_file = - (Mast.Verification verif', pos_item) :: prog_file + Pos.same (Mast.Verification verif') m_item :: prog_file in (const_map, prog_file) | Mast.Target target -> let target_tmp_vars = - StrMap.map + List.map (fun (name, tsz) -> (name, expand_table_size const_map tsz)) target.Mast.target_tmp_vars @@ -804,15 +935,15 @@ let elim_constants_and_loops (p : Mast.program) : Mast.program = expand_instructions const_map target.Mast.target_prog in let target' = - { target with Mast.target_tmp_vars; Mast.target_prog } + Mast.{ target with target_tmp_vars; target_prog } in let prog_file = - (Mast.Target target', pos_item) :: prog_file + Pos.same (Mast.Target target') m_item :: prog_file in (const_map, prog_file) | Mast.Function target -> let target_tmp_vars = - StrMap.map + List.map (fun (name, tsz) -> (name, expand_table_size const_map tsz)) target.Mast.target_tmp_vars @@ -821,13 +952,13 @@ let elim_constants_and_loops (p : Mast.program) : Mast.program = expand_instructions const_map target.Mast.target_prog in let target' = - { target with Mast.target_tmp_vars; Mast.target_prog } + Mast.{ target with target_tmp_vars; target_prog } in let prog_file = - (Mast.Function target', pos_item) :: prog_file + Pos.same (Mast.Function target') m_item :: prog_file in (const_map, prog_file) - | _ -> (const_map, source_item :: prog_file)) + | _ -> (const_map, m_item :: prog_file)) (const_map, []) source_file in (const_map, List.rev prog_file :: prog)) diff --git a/src/mlang/m_frontend/expand_macros.mli b/src/mlang/m_frontend/expander.mli similarity index 100% rename from src/mlang/m_frontend/expand_macros.mli rename to src/mlang/m_frontend/expander.mli diff --git a/src/mlang/m_frontend/format_mast.ml b/src/mlang/m_frontend/format_mast.ml index bac84679b..2103d14a8 100644 --- a/src/mlang/m_frontend/format_mast.ml +++ b/src/mlang/m_frontend/format_mast.ml @@ -22,15 +22,15 @@ let format_application fmt (app : application) = Format.fprintf fmt "%s" app let format_chaining fmt (c : chaining) = Format.fprintf fmt "%s" c -let format_variable_name fmt (v : variable_name) = Format.fprintf fmt "%s" v +let format_variable_name fmt (v : string) = Format.fprintf fmt "%s" v -let format_variable_generic_name fmt (v : variable_generic_name) = +let format_variable_generic_name fmt (v : Com.var_name_generic) = Format.fprintf fmt "%s" v.base -let format_variable fmt (v : variable) = - match v with - | Normal v -> format_variable_name fmt v - | Generic v -> format_variable_generic_name fmt v +let format_variable fmt (v : Com.m_var_name) = + match Pos.unmark v with + | Com.Normal v -> format_variable_name fmt v + | Com.Generic v -> format_variable_generic_name fmt v let format_error_name fmt (e : error_name) = Format.fprintf fmt "%s" e @@ -38,13 +38,20 @@ let format_expression = Com.format_expression format_variable let format_var_category_id fmt (vd : var_category_id) = match Pos.unmark vd with - | ("saisie", _) :: l -> + | Pos.Mark ("saisie", _) :: l -> Format.fprintf fmt "saisie %a" (Pp.list_space (Pp.unmark Pp.string)) l - | ("calculee", _) :: l -> + | Pos.Mark ("calculee", _) :: l -> Format.fprintf fmt "calculee %a" (Pp.list_space (Pp.unmark Pp.string)) l - | [ ("*", _) ] -> Format.fprintf fmt "*" + | [ Pos.Mark ("*", _) ] -> 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 @@ -58,21 +65,20 @@ let format_rule fmt (r : rule) = r.rule_apps format_instruction_list r.rule_formulaes let format_table_size fmt = function - | Some (Mast.LiteralSize i, _) -> Format.fprintf fmt "[%d]" i - | Some (Mast.SymbolSize s, _) -> Format.fprintf fmt "[%s]" s + | Some (Pos.Mark (Mast.LiteralSize i, _)) -> Format.fprintf fmt "[%d]" i + | Some (Pos.Mark (Mast.SymbolSize s, _)) -> Format.fprintf fmt "[%s]" s | None -> () let format_target fmt (t : target) = let format_tmp_var fmt (name, size) = - let name = Pos.unmark name in - Format.fprintf fmt "%s%a" name format_table_size size + Format.fprintf fmt "%s%a" (Pos.unmark name) format_table_size size in Format.fprintf fmt "cible %s:\napplication %a\n: variables temporaires %a;\n%a;\n" (Pos.unmark t.target_name) (StrMap.pp ~pp_key:Pp.nil ~sep:"," (Pp.unmark Pp.string)) t.target_apps - (StrMap.pp ~pp_key:Pp.nil ~sep:"," format_tmp_var) + (Pp.list "," format_tmp_var) t.target_tmp_vars format_instruction_list t.target_prog let format_input_attribute fmt ((n, v) : variable_attribute) = @@ -182,6 +188,12 @@ let format_verif_domain fmt (vd : verif_domain_decl) = in format_domain pp_data fmt vd +let format_variable_space fmt (vsd : Com.variable_space) = + Format.fprintf fmt "%s : categorie %a%s;\n" (Pos.unmark vsd.vs_name) + (Com.CatVar.LocMap.pp ~pp_key:Pp.nil ~sep:"," (Pp.unmark Com.CatVar.pp_loc)) + vsd.vs_cats + (if vsd.vs_by_default then " : par_defaut" else "") + let format_source_file_item fmt (i : source_file_item) = match i with | Application app -> @@ -191,6 +203,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 @@ -205,6 +218,8 @@ let format_source_file_item fmt (i : source_file_item) = | RuleDomDecl rd -> Format.fprintf fmt "rule domain %a;" format_rule_domain rd | VerifDomDecl vd -> Format.fprintf fmt "verif domain %a;" format_verif_domain vd + | VariableSpaceDecl vsd -> + Format.fprintf fmt "espace_variables %a;" format_variable_space vsd let format_source_file fmt (f : source_file) = Pp.list_endline (Pp.unmark format_source_file_item) fmt f diff --git a/src/mlang/m_frontend/format_mast.mli b/src/mlang/m_frontend/format_mast.mli index 2a53ac174..4062b0c65 100644 --- a/src/mlang/m_frontend/format_mast.mli +++ b/src/mlang/m_frontend/format_mast.mli @@ -16,7 +16,7 @@ val format_var_type : Mast.var_type -> string -val format_variable : Pp.t -> Mast.variable -> unit +val format_variable : Pp.t -> Com.m_var_name -> unit val format_rule_domain : Pp.t -> Mast.rule_domain_decl -> unit diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index c0d56d79c..a8fec03fa 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -34,25 +34,14 @@ type application = string type chaining = string (** "enchaineur" in the M source code, utility unknown *) -type variable_name = string -(** Variables are just strings *) - type func_name = string (** Func names are just string for the moment *) -type variable_generic_name = { base : string; parameters : char list } -(** For generic variables, we record the list of their lowercase parameters *) - type error_name = string (** Ununsed for now *) (**{2 Literals}*) -(** A variable is either generic (with loop parameters) or normal *) -type variable = Normal of variable_name | Generic of variable_generic_name - -let get_normal_var = function Normal name -> name | Generic _ -> assert false - type table_size = LiteralSize of int | SymbolSize of string let get_table_size = function @@ -60,17 +49,17 @@ let get_table_size = function | SymbolSize _ -> assert false let get_table_size_opt = function - | Some (LiteralSize i, pos) -> Some (i, pos) + | Some (Pos.Mark (LiteralSize i, pos)) -> Some (Pos.mark i pos) | None -> None - | Some (SymbolSize _, _) -> assert false + | Some (Pos.Mark (SymbolSize _, _)) -> assert false (**{2 Expressions}*) type var_category_id = string Pos.marked list Pos.marked -type set_value = variable Com.set_value +type set_value = Com.m_var_name Com.set_value -type expression = variable Com.expression +type expression = Com.m_var_name Com.expression type m_expression = expression Pos.marked @@ -81,7 +70,7 @@ type m_expression = expression Pos.marked (** The rule is the main feature of the M language. It defines the expression of one or several variables. *) -type instruction = (variable, error_name) Com.instruction +type instruction = (Com.m_var_name, error_name) Com.instruction type m_instruction = instruction Pos.marked @@ -90,7 +79,7 @@ type rule = { rule_tag_names : string Pos.marked list Pos.marked; rule_apps : application Pos.marked StrMap.t; rule_chainings : chaining Pos.marked StrMap.t; - rule_tmp_vars : (string Pos.marked * table_size Pos.marked option) StrMap.t; + rule_tmp_vars : (string Pos.marked * table_size Pos.marked option) list; rule_formulaes : instruction Pos.marked list; (** A rule can contain many variable definitions *) } @@ -98,14 +87,11 @@ type rule = { type target = { target_name : string Pos.marked; target_file : string option; - target_apps : application Pos.marked StrMap.t; + target_apps : string Pos.marked StrMap.t; target_args : string Pos.marked list; target_result : string Pos.marked option; - target_tmp_vars : (string Pos.marked * table_size Pos.marked option) StrMap.t; - target_nb_tmps : int; - target_sz_tmps : int; - target_nb_refs : int; - target_prog : instruction Pos.marked list; + target_tmp_vars : (string Pos.marked * table_size Pos.marked option) list; + target_prog : m_instruction list; } type 'a domain_decl = { @@ -132,17 +118,17 @@ type rule_domain_decl = rule_domain_data domain_decl type variable_attribute = string Pos.marked * int Pos.marked type input_variable = { - input_name : variable_name Pos.marked; + input_name : string Pos.marked; input_category : string Pos.marked list; input_attributes : variable_attribute list; - input_alias : variable_name Pos.marked; (** Unused for now *) + input_alias : string Pos.marked; (** Unused for now *) input_is_givenback : bool; input_description : string Pos.marked; input_typ : Com.value_typ Pos.marked option; } type computed_variable = { - comp_name : variable_name Pos.marked; + comp_name : string Pos.marked; comp_table : table_size Pos.marked option; (** size of the table, [None] for non-table variables *) comp_attributes : variable_attribute list; @@ -154,7 +140,7 @@ type computed_variable = { type variable_decl = | ComputedVar of computed_variable Pos.marked - | ConstVar of variable_name Pos.marked * variable Com.atom Pos.marked + | ConstVar of string Pos.marked * Com.m_var_name Com.atom Pos.marked (** The literal is the constant value *) | InputVar of input_variable Pos.marked @@ -182,7 +168,7 @@ let givenback_category = "restituee" type verification_condition = { verif_cond_expr : expression Pos.marked; - verif_cond_error : error_name Pos.marked * variable_name Pos.marked option; + verif_cond_error : error_name Pos.marked * string Pos.marked option; (** A verification condition error can ba associated to a variable *) } @@ -213,24 +199,21 @@ 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 | Verification of verification | Error of error_ (** Declares an error *) - | Output of variable_name Pos.marked (** Declares an output variable *) + | Output of string Pos.marked (** Declares an output variable *) | Func (** Declares a function, unused *) | VarCatDecl of var_category_decl Pos.marked | RuleDomDecl of rule_domain_decl | VerifDomDecl of verif_domain_decl + | VariableSpaceDecl of Com.variable_space (* TODO: parse something here *) type source_file = source_file_item Pos.marked list type program = source_file list - -(** {1 Helper functions} *) - -let get_variable_name (v : variable) : string = - match v with Normal s -> s | Generic s -> s.base diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 1d5b5f0f6..969603812 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -16,73 +16,582 @@ (** {!module: Mast} to {!module: Mir} translation of M programs. *) -(** {1 Translation context} *) - -(** {2 Variable declarations}*) - -(** {2 General translation context} *) +let complete_vars_stack (prog : Validator.program) : Validator.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 (Pos.Mark (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.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) + | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> + assert false + in + let map (t : Validator.target) = + let nbRef, nbIt = aux_instrs t.target_prog in + let is_f = Com.target_is_function t in + let nb_args = List.length t.target_args in + let target_nb_tmps = + StrMap.cardinal t.target_tmp_vars + + nbIt + + if is_f then 1 + nb_args else 0 + in + let target_sz_tmps = + let fold _ m_id sz = + let var = IntMap.find (Pos.unmark m_id) prog.prog_dict in + match Com.Var.get_table var with + | None -> sz + 1 + | Some tab -> sz + Array.length tab + in + StrMap.fold fold t.target_tmp_vars + (nbIt + if is_f then 1 + nb_args else 0) + in + let target_nb_refs = nbRef + if is_f then 0 else nb_args in + { t with target_nb_tmps; target_sz_tmps; target_nb_refs } + in + (StrMap.map map prog.prog_functions, StrMap.map map prog.prog_targets) + in + { prog with prog_functions; prog_targets } -let get_var_from_name (var_data : Com.Var.t StrMap.t) - (name : Mast.variable_name Pos.marked) : Com.Var.t = - try StrMap.find (Pos.unmark name) var_data - with Not_found -> - Errors.raise_spanned_error - (Format.asprintf "variable %s has not been declared" (Pos.unmark name)) - (Pos.get_position name) +let complete_vars (prog : Validator.program) : Validator.program * Mir.stats = + let tgv_dict = + let fold _ v set = + if Com.Var.is_tgv v then Com.Var.Set.add v set else set + in + IntMap.fold fold prog.prog_dict Com.Var.Set.empty + in + let tgv_dict = + 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 + fst + @@ Com.Var.Set.fold + (fun (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 var = Com.Var.set_loc_tgv_idx var dcat i in + let res = Com.Var.Set.add var res in + (res, cpt)) + tgv_dict + (Com.Var.Set.empty, cat_cpt) + in + let module CatLoc = struct + type t = Com.CatVar.loc -(**{1 Translation}*) + let compare x y = compare x y + end in + let module CatLocMap = MapExt.Make (CatLoc) in + let loc_vars, sz_loc_vars, sz_vars = + let fold (var : Com.Var.t) (loc_vars, sz_loc_vars, n) = + if Com.Var.is_tgv var then + 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) + else (loc_vars, sz_loc_vars, n) + in + Com.Var.Set.fold fold tgv_dict (CatLocMap.empty, CatLocMap.empty, 0) + in + let update_loc (var : Com.Var.t) (vars, n) = + let var = Com.Var.set_loc_idx var n in + let vars = Com.Var.Set.add var vars in + (vars, n + Com.Var.size var) + in + let tgv_dict = + CatLocMap.fold + (fun _loc_cat vars dict -> + (dict, 0) |> Com.Var.Set.fold update_loc vars |> fst) + loc_vars Com.Var.Set.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_dict = + let fold (v : Com.Var.t) res = IntMap.add v.id v res in + Com.Var.Set.fold fold tgv_dict prog.prog_dict + in + let prog_dict = + let fold id v (prog_dict, n) = + if Com.Var.is_temp v then + let v = Com.Var.set_loc_tmp_idx v n in + let prog_dict = IntMap.add id v prog_dict in + (prog_dict, n + 1) + else (prog_dict, n) + in + fst @@ IntMap.fold fold prog_dict (prog_dict, 0) + in + let prog = { prog with prog_dict } in + let stats = + Mir. + { + nb_computed = nb_loc Com.CatVar.LocComputed; + nb_input = nb_loc Com.CatVar.LocInput; + nb_base = nb_loc Com.CatVar.LocBase; + nb_vars = StrMap.cardinal prog.prog_vars; + sz_computed = sz_loc Com.CatVar.LocComputed; + sz_input = sz_loc Com.CatVar.LocInput; + sz_base = sz_loc Com.CatVar.LocBase; + sz_vars; + nb_all_tmps = 0; + nb_all_refs = 0; + sz_all_tmps = 0; + nb_all_tables = 0; + sz_all_tables = 0; + max_nb_args = 0; + table_map = IntMap.empty; + } + in + (prog, stats) -(**{2 Variables}*) +let complete_target_vars ((prog : Validator.program), (stats : Mir.stats)) : + Validator.program * Mir.stats = + let fold _ (t : Validator.target) (prog_dict, max_nb_args) = + let is_f = Com.target_is_function t in + let prog_dict = + match t.target_result with + | Some m_id -> + let var = IntMap.find (Pos.unmark m_id) prog_dict in + let var = Com.Var.set_loc_idx var (-t.target_sz_tmps) in + IntMap.add var.id var prog_dict + | None -> prog_dict + in + let prog_dict, _ = + let idx_init = + if is_f then -t.target_sz_tmps + 1 else -t.target_nb_refs + in + List.fold_left + (fun (prog_dict, n) m_id -> + let var = IntMap.find (Pos.unmark m_id) prog_dict in + let var = Com.Var.set_loc_idx var n in + let prog_dict = IntMap.add var.id var prog_dict in + (prog_dict, n + 1)) + (prog_dict, idx_init) t.target_args + in + let prog_dict, _ = + let idx_init = + let tmp_sz = + StrMap.fold + (fun _ m_id n -> + let var = IntMap.find (Pos.unmark m_id) prog_dict in + n + Com.Var.size var) + t.target_tmp_vars 0 + in + -tmp_sz + in + StrMap.fold + (fun _name m_id (prog_dict, n) -> + let var = IntMap.find (Pos.unmark m_id) prog_dict in + let var = Com.Var.set_loc_idx var n in + let prog_dict = IntMap.add var.id var prog_dict in + (prog_dict, n + Com.Var.size var)) + t.target_tmp_vars (prog_dict, idx_init) + in + let prog_dict = + StrMap.fold + (fun _name m_id prog_dict -> + let var = IntMap.find (Pos.unmark m_id) prog_dict in + match Com.Var.get_table var with + | Some tab -> + let table = + let map (v : Com.Var.t) = IntMap.find v.id prog_dict in + Some (Array.map map tab) + in + let var = Com.Var.set_table var table in + IntMap.add var.id var prog_dict + | None -> prog_dict) + t.target_tmp_vars prog_dict + in + let max_nb_args = + if Com.target_is_function t then + max max_nb_args (List.length t.target_args) + else max_nb_args + in + (prog_dict, max_nb_args) + in + let prog_dict, max_nb_args = + (prog.prog_dict, 0) + |> StrMap.fold fold prog.prog_targets + |> StrMap.fold fold prog.prog_functions + in + let prog = { prog with prog_dict } in + let stats = { stats with max_nb_args } in + (prog, stats) -(** 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 complete_tabs ((prog : Validator.program), (stats : Mir.stats)) : + Validator.program * Mir.stats = + let prog_dict, table_map, nb_all_tables, sz_all_tables = + let map_add var map = IntMap.add (IntMap.cardinal map) var map in + let fold_vars id v (prog_dict, map, nb_all, sz_all) = + match Com.Var.get_table v with + | None -> (prog_dict, map, nb_all, sz_all) + | Some tab -> + let nb_all = nb_all + 1 in + let vsz = Com.Var.size v in + let v = Com.Var.set_loc_tab_idx v (IntMap.cardinal map) in + let map = map_add v map in + let map, tab = + let rec loop map tab i = + if i = vsz then (map, tab) + else + let iVar = IntMap.find tab.(i).Com.Var.id prog_dict in + let map = map_add iVar map in + tab.(i) <- iVar; + loop map tab (i + 1) + in + loop map tab 0 + in + let v = Com.Var.set_table v (Some tab) in + let prog_dict = IntMap.add id v prog_dict in + let sz_all = sz_all + vsz in + (prog_dict, map, nb_all, sz_all) + in + IntMap.fold fold_vars prog.prog_dict (prog.prog_dict, IntMap.empty, 0, 0) + in + let prog = { prog with prog_dict } in + let stats = { stats with nb_all_tables; sz_all_tables; table_map } in + (prog, stats) -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) +let complete_stats ((prog : Validator.program), (stats : Mir.stats)) : + Validator.program * Mir.stats = + 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 : Validator.target) = + let nb, sz, nbRef = + (t.target_nb_tmps, t.target_sz_tmps, t.target_nb_refs) + 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.prog_functions with + | Some t -> eval_call t + | None -> eval_call (StrMap.find name prog.prog_targets)) + and aux_access tdata m_a = + match Pos.unmark m_a with + | Com.VarAccess _ -> (0, 0, 0, tdata) + | Com.TabAccess (_, mi) + | Com.ConcAccess (_, _, mi) + | Com.FieldAccess (mi, _, _) -> + aux_expr tdata mi + and aux_instr tdata (Pos.Mark (instr, _pos)) = + match instr with + | Com.Affectation mf -> ( + match Pos.unmark mf with + | SingleFormula (VarDecl (m_a, mev)) -> + let nb, sz, nbRef, tdata = aux_expr tdata mev in + let nbA, szA, nbRefA, tdata = aux_access tdata m_a in + (max nbA nb, max szA sz, max nbRefA nbRef, 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) -> + 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) (Pos.Mark (a, _pos)) = + match a with + | Com.PrintAccess (_, m_a) -> + let nbA, szA, nbRefA, tdata = aux_access tdata m_a in + (max nbA nb, max szA sz, max nbRefA nbRef, tdata) + | Com.PrintString _ -> (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, mstep) = + 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 + (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 (_, 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 + (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 = + 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' @@ max nb'' nb''' in + let sz = max sz @@ max sz' @@ max sz'' sz''' in + (* ??? *) + let nbRef = 1 + (max nbRef @@ max nbRef' @@ max nbRef'' nbRef''') in + (nb, sz, nbRef, tdata) + | Com.ArrangeEvents (sort, filter, add, 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 = + 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' @@ 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 -> + (0, 0, 0, tdata) + | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> + assert false + and aux_expr tdata (Pos.Mark (expr, _pos)) = + match expr with + | Com.TestInSet (_, me, values) -> + let fold (nb, sz, nbRef, tdata) = function + | Com.VarValue (Pos.Mark (TabAccess (_, mei), _)) + | Com.VarValue (Pos.Mark (ConcAccess (_, _, mei), _)) + | Com.VarValue (Pos.Mark (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.Var (TabAccess (_, me)) + | Com.Var (ConcAccess (_, _, me)) + | Com.Var (FieldAccess (me, _, _)) + | Com.Size (Pos.Mark (TabAccess (_, me), _)) + | Com.Size (Pos.Mark (ConcAccess (_, _, me), _)) + | Com.Size (Pos.Mark (FieldAccess (me, _, _), _)) + | Com.Attribut (Pos.Mark (TabAccess (_, me), _), _) + | Com.Attribut (Pos.Mark (ConcAccess (_, _, me), _), _) + | Com.Attribut (Pos.Mark (FieldAccess (me, _, _), _), _) + | Com.IsVariable (Pos.Mark (TabAccess (_, me), _), _) + | Com.IsVariable (Pos.Mark (ConcAccess (_, _, me), _), _) + | Com.IsVariable (Pos.Mark (FieldAccess (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 (VarAccess _) + | Com.NbCategory _ | Com.Attribut _ | Com.Size _ | Com.IsVariable _ + | Com.NbAnomalies | Com.NbDiscordances | Com.NbInformatives + | Com.NbBloquantes -> + (0, 0, 0, tdata) + | Com.FuncCallLoop _ | Com.Loop _ -> assert false + in + let nb, sz, nbRef, _ = + 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 + (0, 0, 0, StrMap.empty) + |> StrMap.fold fold prog.prog_functions + |> StrMap.fold fold prog.prog_targets + in + (nb, sz, nbRef) + in + (prog, { stats with nb_all_tmps; sz_all_tmps; nb_all_refs }) -(**{2 Preliminary passes}*) +(** {1 Translation } *) -(**{2 SSA construction}*) +(** {2 General translation context} *) -let translate_variable (var_data : Com.Var.t StrMap.t) - (var : Mast.variable Pos.marked) : Mir.expression 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 - | Mast.Generic _ -> assert false +let get_var (dict : Com.Var.t IntMap.t) (m_id : int Pos.marked) : Com.Var.t = + IntMap.find (Pos.unmark m_id) dict -(** {2 Translation of expressions}*) +(** {2 Translation of expressions} *) -let rec translate_expression (cats : Com.CatVar.data Com.CatVar.Map.t) - (var_data : Com.Var.t StrMap.t) (f : Mast.expression Pos.marked) : - Mir.expression Pos.marked = +let rec translate_expression (p : Validator.program) (dict : Com.Var.t IntMap.t) + (f : int Pos.marked Com.m_expression) : Mir.m_expression = 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 + | TestInSet (positive, m_e, values) -> + let new_e = translate_expression p dict m_e in let new_set_values = List.map (function | FloatValue f -> FloatValue f - | VarValue (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) - | Interval (bv, ev) -> Interval (bv, ev)) - values + | VarValue (Pos.Mark (access, pos)) -> + let access' = translate_access p dict access in + VarValue (Pos.mark access' pos) + | IntervalValue (bv, ev) -> IntervalValue (bv, ev)) + (values : int Pos.marked set_value list) 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 dict e1 in + let new_e2 = translate_expression p dict e2 in Comparison (op, new_e1, new_e2) | Binop (op, e1, e2) -> (* if @@ -93,127 +602,157 @@ let rec translate_expression (cats : Com.CatVar.data Com.CatVar.Map.t) (* It is difficult to do a broader or deeper analysis because of 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 + "Nullifying constant multiplication found." (Pos.get f);*) + let new_e1 = translate_expression p dict e1 in + let new_e2 = translate_expression p dict 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 dict 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 - 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 dict e1 in + let new_e2 = translate_expression p dict e2 in + let new_e3 = Option.map (translate_expression p dict) 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 dict 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) - | Attribut (v, a) -> ( - if - CatVar.Map.fold - (fun _ CatVar.{ attributs; _ } res -> - res - && StrMap.fold - (fun attr _ res -> res && attr <> Pos.unmark a) - attributs true) - cats true - then Errors.raise_spanned_error "unknown attribut" (Pos.get_position a); - let v_name = - match Pos.unmark 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) + | Var access -> Var (translate_access p dict access) + | NbCategory cs -> NbCategory (Validator.mast_to_catvars cs p.prog_var_cats) + | Attribut (Pos.Mark (access, pos), a) -> ( + match access with + | VarAccess m_id -> ( + let var = get_var dict m_id in + if Com.Var.is_ref var then + Attribut (Pos.same (VarAccess var) m_id, 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) + | TabAccess (m_id, _) -> ( + let var = get_var dict m_id in + match StrMap.find_opt (Pos.unmark a) (Com.Var.attrs var) with + | Some l -> Literal (Float (float (Pos.unmark l))) + | None -> Literal Undefined) + | ConcAccess (m_vn, m_if, i) -> + let i' = translate_expression p dict i in + Attribut (Pos.mark (ConcAccess (m_vn, m_if, i')) pos, a) + | FieldAccess (e, f, _) -> + let e' = translate_expression p dict e in + let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in + Attribut (Pos.mark (FieldAccess (e', f, i)) pos, a)) + | Size (Pos.Mark (access, pos)) -> ( + match access with + | VarAccess m_id -> + let var = get_var dict m_id in + if Com.Var.is_ref var then Size (Pos.same (VarAccess var) m_id) + else Literal (Float (float @@ Com.Var.size var)) + | TabAccess _ -> Literal (Float 1.0) + | ConcAccess (m_vn, m_if, i) -> + let i' = translate_expression p dict i in + Size (Pos.mark (ConcAccess (m_vn, m_if, i')) pos) + | FieldAccess (e, f, _) -> + let e' = translate_expression p dict e in + let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in + Size (Pos.mark (FieldAccess (e', f, i)) pos)) + | IsVariable (Pos.Mark (access, pos), m_name) -> ( + match access with + | VarAccess m_id -> ( + let var = get_var dict m_id in + if Com.Var.is_ref var then + IsVariable (Pos.same (VarAccess var) m_id, m_name) + else + let name = Pos.unmark m_name in + if Com.Var.name_str var = name then Literal (Float 1.0) + else + match Com.Var.alias var with + | Some m_a when Pos.unmark m_a = name -> Literal (Float 1.0) + | _ -> Literal (Float 0.0)) | _ -> - let msg = Format.sprintf "unknown variable %s" v_name in - Errors.raise_spanned_error msg (Pos.get_position v)) - | Size v -> ( - let v_name = - match Pos.unmark 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) - else - match Com.Var.is_table var with - | Some i -> Literal (Float (float_of_int i)) - | None -> Literal (Float 1.0)) + let access' = translate_access p dict access in + IsVariable (Pos.mark access' pos, m_name)) | NbAnomalies -> NbAnomalies | NbDiscordances -> NbDiscordances | NbInformatives -> NbInformatives | NbBloquantes -> NbBloquantes | FuncCallLoop _ | Loop _ -> assert false in - Pos.same_pos_as expr f + Pos.same expr f -(** {2 Translation of source file items}*) +and translate_access (p : Validator.program) (dict : Com.Var.t IntMap.t) + (access : int Pos.marked Com.access) : Com.Var.t Com.access = + match access with + | VarAccess m_v -> + let v' = get_var dict m_v in + Com.VarAccess v' + | TabAccess (m_v, m_i) -> + let v' = get_var dict m_v in + let m_i' = translate_expression p dict m_i in + Com.TabAccess (v', m_i') + | ConcAccess (m_vn, m_if, i) -> + let i' = translate_expression p dict i in + Com.ConcAccess (m_vn, m_if, i') + | FieldAccess (i, f, _) -> + let i' = translate_expression p dict i in + let ef = StrMap.find (Pos.unmark f) p.prog_event_fields in + Com.FieldAccess (i', f, ef.index) -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 = - 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 *) - 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 - aux ((Com.Affectation m_form, pos) :: res) il - | (Com.Affectation _, _) :: _ -> assert false - | (Com.IfThenElse (e, ilt, ile), pos) :: il -> - let expr = translate_expression cats 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 dl' = aux [] dl in - (expr', dl', pos) +(** {2 Translation of instructions} *) + +let rec translate_prog (p : Validator.program) (dict : Com.Var.t IntMap.t) + (it_depth : int) (itval_depth : int) prog = + let rev_fst (l, d) = (List.rev l, d) in + let rec aux (res, dict) = function + | [] -> (List.rev res, dict) + | Pos.Mark (Com.Affectation (Pos.Mark (SingleFormula decl, _)), pos) :: il + -> + let decl' = + match decl with + | VarDecl (m_access, e) -> + let access' = translate_access p dict (Pos.unmark m_access) in + let m_access' = Pos.same access' m_access in + let e' = translate_expression p dict e in + Com.VarDecl (m_access', e') + | EventFieldRef (idx, f, _, m_v) -> + let idx' = translate_expression p dict idx in + let i = (StrMap.find (Pos.unmark f) p.prog_event_fields).index in + let v' = get_var dict m_v in + Com.EventFieldRef (idx', f, i, v') in - let wdl' = List.map map_wdl wdl in - 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 *) + let m_form = Pos.mark (Com.SingleFormula decl') pos in + aux (Pos.mark (Com.Affectation m_form) pos :: res, dict) il + | Pos.Mark (Com.Affectation (Pos.Mark (MultipleFormulaes _, _)), _) :: _ -> + assert false + | Pos.Mark (Com.IfThenElse (e, ilt, ile), pos) :: il -> + let expr = translate_expression p dict e in + let prog_then, dict = aux ([], dict) ilt in + let prog_else, dict = aux ([], dict) ile in + let instr' = Com.IfThenElse (expr, prog_then, prog_else) in + aux (Pos.mark instr' pos :: res, dict) il + | Pos.Mark (Com.WhenDoElse (wdl, ed), pos) :: il -> + let wdl', dict = + rev_fst + @@ List.fold_left + (fun (res, dict) (expr, dl, pos) -> + let expr' = translate_expression p dict expr in + let dl', dict = aux ([], dict) dl in + ((expr', dl', pos) :: res, dict)) + ([], dict) wdl in + let ed', dict = aux ([], dict) (Pos.unmark ed) in + let ed' = Pos.same ed' ed in + aux (Pos.mark (Com.WhenDoElse (wdl', ed')) pos :: res, dict) il + | Pos.Mark (Com.ComputeTarget (tn, targs), pos) :: il -> + let map v = get_var dict v in let targs' = List.map map targs in - aux ((Com.ComputeTarget (tn, targs'), pos) :: res) il - | (Com.VerifBlock instrs, pos) :: il -> - let instrs' = aux [] instrs in - aux ((Com.VerifBlock instrs', pos) :: res) il - | (Com.Print (std, args), pos) :: il -> + aux (Pos.mark (Com.ComputeTarget (tn, targs')) pos :: res, dict) il + | Pos.Mark (Com.VerifBlock instrs, pos) :: il -> + let instrs', dict = aux ([], dict) instrs in + aux (Pos.mark (Com.VerifBlock instrs') pos :: res, dict) il + | Pos.Mark (Com.Print (std, args), pos) :: il -> let mir_args = List.rev (List.fold_left @@ -221,199 +760,172 @@ let rec translate_prog (error_decls : Com.Error.t StrMap.t) let mir_arg = match Pos.unmark arg with | Com.PrintString s -> Com.PrintString s - | Com.PrintName v -> ( - let name = - match Pos.unmark v with - | Mast.Normal name -> name - | Mast.Generic _ -> assert false - in - match StrMap.find_opt name var_data with - | Some var -> - if Com.Var.is_ref var then - Com.PrintName (Pos.same_pos_as var v) - else Com.PrintString (Pos.unmark var.name) - | _ -> - let msg = - Format.sprintf "unknown variable %s" name - in - Errors.raise_spanned_error msg (Pos.get_position v)) - | Com.PrintAlias v -> ( - let name = - match Pos.unmark v with - | Mast.Normal name -> name - | Mast.Generic _ -> assert false - in - match StrMap.find_opt name var_data with - | Some var -> - if Com.Var.is_ref var then - Com.PrintAlias (Pos.same_pos_as var v) - else Com.PrintString (Com.Var.alias_str var) - | _ -> - let msg = - Format.sprintf "unknown variable %s" name - in - Errors.raise_spanned_error msg (Pos.get_position v)) + | Com.PrintAccess (info, m_a) -> + let a' = translate_access p dict (Pos.unmark m_a) in + let m_a' = Pos.same a' m_a in + Com.PrintAccess (info, m_a') | Com.PrintIndent e -> - Com.PrintIndent (translate_expression cats var_data e) + Com.PrintIndent (translate_expression p dict e) | Com.PrintExpr (e, min, max) -> - Com.PrintExpr - (translate_expression cats var_data e, min, max) + Com.PrintExpr (translate_expression p dict e, min, max) in - Pos.same_pos_as mir_arg arg :: res) + Pos.same mir_arg arg :: res) [] args) in - 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 - (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_ref ~name:(var_name, var_pos) ~loc_int:it_depth in - let var_data = StrMap.add var_name var var_data in - let vars' = - List.map - (fun vn -> - Pos.same_pos_as - (StrMap.find (Mast.get_normal_var (Pos.unmark vn)) var_data) - vn) - vars - in + aux (Pos.mark (Com.Print (std, mir_args)) pos :: res, dict) il + | Pos.Mark (Com.Iterate (m_id, vars, var_params, instrs), pos) :: il -> + let var = get_var dict m_id in + let var = Com.Var.set_loc_idx var it_depth in + let dict = IntMap.add var.id var dict in + let vars' = List.map (get_var dict) vars in 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 = Validator.mast_to_catvars vcats p.prog_var_cats in + let mir_expr = translate_expression p dict expr in (catSet, mir_expr)) var_params in - let prog_it = - translate_prog error_decls cats var_data (it_depth + 1) instrs + let prog_it, dict = + translate_prog p dict (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.Restore (vars, var_params, instrs), pos) :: il -> - let vars' = + let instr = Com.Iterate (var, vars', var_params', prog_it) in + aux (Pos.mark instr pos :: res, dict) il + | Pos.Mark (Com.Iterate_values (m_id, var_intervals, instrs), pos) :: il -> + let var = get_var dict m_id in + let var = Com.Var.set_loc_idx var itval_depth in + let dict = IntMap.add var.id var dict in + let var_intervals' = List.map - (fun vn -> - Pos.same_pos_as - (StrMap.find (Mast.get_normal_var (Pos.unmark vn)) var_data) - vn) - vars + (fun (e0, e1, step) -> + let e0' = translate_expression p dict e0 in + let e1' = translate_expression p dict e1 in + let step' = translate_expression p dict step in + (e0', e1', step')) + var_intervals in - let var_params' = - List.map - (fun (vn, vcats, 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_ref ~name:(var_name, var_pos) ~loc_int:it_depth + let prog_it, dict = + translate_prog p dict it_depth (itval_depth + 1) instrs + in + let instr = Com.Iterate_values (var, var_intervals', prog_it) in + aux (Pos.mark instr pos :: res, dict) il + | Pos.Mark (Com.Restore (vars, var_params, evts, evtfs, instrs), pos) :: il + -> + let vars' = List.map (get_var dict) vars in + let var_params', dict = + let var_params', dict = + List.fold_left + (fun (res, dict) (m_id, vcats, expr) -> + let var = get_var dict m_id in + let var = Com.Var.set_loc_idx var it_depth in + let dict = IntMap.add var.id var dict in + let catSet = Validator.mast_to_catvars vcats p.prog_var_cats in + let mir_expr = translate_expression p dict expr in + ((var, catSet, mir_expr) :: res, dict)) + ([], dict) var_params + in + (List.rev var_params', dict) + in + let evts' = List.map (translate_expression p dict) evts in + let evtfs', dict = + rev_fst + @@ List.fold_left + (fun (res, dict) (m_id, expr) -> + let var = get_var dict m_id in + let var = Com.Var.set_loc_idx var itval_depth in + let dict = IntMap.add var.id var dict in + let mir_expr = translate_expression p dict expr in + ((var, mir_expr) :: res, dict)) + ([], dict) evtfs + in + let prog_rest, dict = + translate_prog p dict it_depth itval_depth instrs + in + let instr = + Com.Restore (vars', var_params', evts', evtfs', prog_rest) + in + aux (Pos.mark instr pos :: res, dict) il + | Pos.Mark (Com.ArrangeEvents (sort, filter, add, instrs), pos) :: il -> + let sort', itval_depth', dict = + match sort with + | Some (m_id0, m_id1, expr) -> + let var0 = get_var dict m_id0 in + let var0' = Com.Var.set_loc_idx var0 itval_depth in + let var1 = get_var dict m_id1 in + let var1' = Com.Var.set_loc_idx var1 (itval_depth + 1) in + let dict = + dict |> IntMap.add var0.id var0' |> IntMap.add var1.id var1' 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 - (Pos.mark var_pos var, catSet, mir_expr)) - var_params + let expr' = translate_expression p dict expr in + (Some (var0', var1', expr'), itval_depth + 2, dict) + | None -> (None, itval_depth, dict) + in + let filter', itval_depth', dict = + match filter with + | Some (m_id, expr) -> + let var = get_var dict m_id in + let var' = Com.Var.set_loc_idx var itval_depth in + let dict = IntMap.add var.id var' dict in + let expr' = translate_expression p dict expr in + (Some (var', expr'), max itval_depth' (itval_depth + 1), dict) + | None -> (None, itval_depth', dict) in - let prog_rest = - translate_prog error_decls cats var_data it_depth instrs + let add' = Option.map (translate_expression p dict) add in + let instrs', dict = + translate_prog p dict 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 -> - let err_decl = StrMap.find (Pos.unmark err_name) error_decls 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 - | (Com.ExportErrors, pos) :: il -> aux ((Com.ExportErrors, pos) :: res) il - | (Com.FinalizeErrors, pos) :: il -> - aux ((Com.FinalizeErrors, pos) :: res) il - | (Com.ComputeDomain _, _) :: _ - | (Com.ComputeChaining _, _) :: _ - | (Com.ComputeVerifs (_, _), _) :: _ -> + let instr = Com.ArrangeEvents (sort', filter', add', instrs') in + aux (Pos.mark instr pos :: res, dict) il + | Pos.Mark (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 err_decl err_name in + let instr' = Com.RaiseError (m_err_decl, var_opt) in + aux (Pos.mark instr' pos :: res, dict) il + | Pos.Mark (Com.CleanErrors, pos) :: il -> + aux (Pos.mark Com.CleanErrors pos :: res, dict) il + | Pos.Mark (Com.ExportErrors, pos) :: il -> + aux (Pos.mark Com.ExportErrors pos :: res, dict) il + | Pos.Mark (Com.FinalizeErrors, pos) :: il -> + aux (Pos.mark Com.FinalizeErrors pos :: res, dict) il + | Pos.Mark (Com.ComputeDomain _, _) :: _ + | Pos.Mark (Com.ComputeChaining _, _) :: _ + | Pos.Mark (Com.ComputeVerifs (_, _), _) :: _ -> assert false in - aux [] prog + aux ([], dict) 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 (p : Validator.program) (dict : Com.Var.t IntMap.t) + (ts : Validator.target StrMap.t) : Mir.target StrMap.t * Com.Var.t IntMap.t + = StrMap.fold - (fun _ (t : Mast.target) targets -> + (fun _ (t : Validator.target) (targets, dict) -> + let is_f = Com.target_is_function t in let target_name = t.target_name in let target_file = t.target_file in let target_apps = t.target_apps in + let target_nb_tmps = t.target_nb_tmps in let target_nb_refs = t.target_nb_refs in - let tmp_var_data, _ = - if is_function then - List.fold_left - (fun (tmp_var_data, n) (name, pos) -> - let var = Com.Var.new_arg ~name:(name, pos) ~loc_int:n in - let tmp_var_data = StrMap.add name var tmp_var_data in - (tmp_var_data, n + 1)) - (var_data, 0) t.target_args - else - List.fold_left - (fun (tmp_var_data, n) (name, pos) -> - let var = Com.Var.new_ref ~name:(name, pos) ~loc_int:n in - let tmp_var_data = StrMap.add name var tmp_var_data in - (tmp_var_data, n + 1)) - (var_data, -target_nb_refs) - t.target_args + let target_args = + let map m_id = IntMap.find (Pos.unmark m_id) dict in + List.map map t.target_args in let target_sz_tmps = t.target_sz_tmps in - let tmp_var_data, _ = - StrMap.fold - (fun name ((_, pos), size) (tmp_var_data, n) -> - let size' = Pos.unmark_option (Mast.get_table_size_opt size) in - let var = - Com.Var.new_temp ~name:(name, pos) ~is_table:size' ~loc_int:n - in - let tmp_var_data = StrMap.add name var tmp_var_data in - (tmp_var_data, n + Com.Var.size var)) - t.target_tmp_vars - (tmp_var_data, -target_sz_tmps) - in - let tmp_var_data = - if is_function then - let vn, vpos = Option.get t.target_result in - let var = Com.Var.new_res ~name:(vn, vpos) in - StrMap.add vn var tmp_var_data - else tmp_var_data - in - let target_args = - List.map - (fun (vn, pos) -> (StrMap.find vn tmp_var_data, pos)) - t.target_args + let target_result = + let map m_id = IntMap.find (Pos.unmark m_id) dict in + Option.map map t.target_result in let target_tmp_vars = - StrMap.mapi - (fun vn ((_, pos), size) -> - let var = StrMap.find vn tmp_var_data in - let size' = Pos.unmark_option (Mast.get_table_size_opt size) in - (var, pos, size')) - t.target_tmp_vars - in - let target_result = - match t.target_result with - | Some (vn, vpos) -> Some (StrMap.find vn tmp_var_data, vpos) - | None -> None + let map m_id = IntMap.find (Pos.unmark m_id) dict in + StrMap.map map t.target_tmp_vars in - let target_prog = - translate_prog error_decls cats tmp_var_data - (List.length target_args - target_nb_refs) - t.target_prog + let nb_args = List.length target_args in + let ref_depth = -target_nb_refs + if is_f then 0 else nb_args in + let itval_depth = -target_sz_tmps + if is_f then 1 + nb_args else 0 in + let target_prog, dict = + translate_prog p dict ref_depth itval_depth t.target_prog in - let target_data = - Mir. + let target = + Com. { target_name; target_file; @@ -422,61 +934,73 @@ let get_targets (is_function : bool) (error_decls : Com.Error.t StrMap.t) target_result; target_tmp_vars; target_prog; - target_nb_tmps = t.target_nb_tmps; + target_nb_tmps; target_sz_tmps; target_nb_refs; } in - Com.TargetMap.add (Pos.unmark target_name) target_data targets) - ts Com.TargetMap.empty + (StrMap.add (Pos.unmark target_name) target targets, dict)) + ts (StrMap.empty, dict) -let translate (p : Mast.program) (main_target : string) : Mir.program = - let p = Expand_macros.proceed p in - let prog = Check_validity.proceed p main_target in - let prog_functions = prog.prog_functions in - let prog_targets = prog.prog_targets in - let var_category_map = prog.prog_var_cats in - let var_data = prog.prog_vars in - let rules = - let map_rule (rule : Check_validity.rule) = +let translate (p : Validator.program) : Mir.program = + let p, program_stats = + p |> complete_vars_stack |> complete_vars |> complete_target_vars + |> complete_stats |> complete_tabs + in + let program_vars, program_alias = + let map id = IntMap.find id p.prog_dict in + (StrMap.map map p.prog_vars, StrMap.map map p.prog_alias) + in + let program_rules = + let map_rule (rule : Validator.rule) = let id = Pos.unmark rule.rule_id in - Format.sprintf "%s_regle_%d" prog.prog_prefix id + Format.sprintf "%s_regle_%d" p.prog_prefix id in - IntMap.map map_rule prog.prog_rules + IntMap.map map_rule p.prog_rules in - let verifs = - let map_verif (verif : Check_validity.verif) = + let program_verifs = + let map_verif (verif : Validator.verif) = let id = Pos.unmark verif.verif_id in - Format.sprintf "%s_verif_%d" prog.prog_prefix id + Format.sprintf "%s_verif_%d" p.prog_prefix id in - IntMap.map map_verif prog.prog_verifs + IntMap.map map_verif p.prog_verifs in - let chainings = - let map_chainings (chaining : Check_validity.chaining) = + let program_chainings = + let map_chainings (chaining : Validator.chaining) = let name = Pos.unmark chaining.chain_name in - Format.sprintf "%s_chaining_%s" prog.prog_prefix name + Format.sprintf "%s_chaining_%s" p.prog_prefix name in - StrMap.map map_chainings prog.prog_chainings + StrMap.map map_chainings p.prog_chainings in - let errs = prog.prog_errors in - let functions = - get_targets true errs var_category_map var_data prog_functions + let dict = p.prog_dict in + let program_functions, dict = get_targets p dict p.prog_functions in + let program_targets, dict = get_targets p dict p.prog_targets in + let program_dict = dict in + let program_var_space_def = + let id = StrMap.find "" p.prog_var_spaces in + IntMap.find id p.prog_var_spaces_idx in - let targets = get_targets false errs var_category_map var_data prog_targets in Mir. { - program_safe_prefix = prog.prog_prefix; - program_applications = prog.prog_apps; - program_var_categories = var_category_map; - program_rule_domains = prog.prog_rdoms; - program_verif_domains = prog.prog_vdoms; - program_vars = var_data; - program_rules = rules; - program_verifs = verifs; - program_chainings = chainings; - program_errors = errs; - program_functions = functions; - program_targets = targets; - program_main_target = prog.prog_main_target; - program_stats = prog.prog_stats; + program_safe_prefix = p.prog_prefix; + program_applications = p.prog_apps; + program_var_categories = p.prog_var_cats; + program_rule_domains = p.prog_rdoms; + program_verif_domains = p.prog_vdoms; + program_dict; + program_vars; + program_alias; + program_var_spaces = p.prog_var_spaces; + program_var_spaces_idx = p.prog_var_spaces_idx; + program_var_space_def; + program_event_fields = p.prog_event_fields; + program_event_field_idxs = p.prog_event_field_idxs; + program_rules; + program_verifs; + program_chainings; + program_errors = p.prog_errors; + program_functions; + program_targets; + program_main_target = p.prog_main_target; + program_stats; } diff --git a/src/mlang/m_frontend/mast_to_mir.mli b/src/mlang/m_frontend/mast_to_mir.mli index a7b0cc6cf..12d5eece4 100644 --- a/src/mlang/m_frontend/mast_to_mir.mli +++ b/src/mlang/m_frontend/mast_to_mir.mli @@ -16,31 +16,4 @@ (** {!module: Mast} to {!module: Mir} translation of M programs. *) -(** {1 Translation helpers} *) - -val get_var_from_name : - Com.Var.t StrMap.t -> - (* name of the variable to query *) string Pos.marked -> - Com.Var.t -(** Queries a [type: Mir.variable.t] from an [type:idmap] mapping, the name of a - variable and the rule number from which the variable is requested. Returns - the variable with the same name and highest rule number that is below the - current rule number from where this variable is requested *) - -(** {1 Main translation function}*) - -val translate : Mast.program -> string -> Mir.program -(** Main translation function from the M AST to the M Variable Graph. This - function performs 6 linear passes on the input code: - - - [get_constants] gets the value of all constant variables, the values of - which are needed to compute certain loop bounds; - - [get_variables_decl] retrieves the declarations of all other variables and - errors; - - [get_var_redefinitions] incorporates into [idmap] all definitions inside - rules along with their execution number; - - [get_var_data] is the workhorse pass that translates all the expressions - corresponding to the definitions; - - [add_dummy_definition_for_variable_declaration] adds [Undefined] - definitions placeholder for all variables declarations; - - [get_errors_conds] parses the verification conditions definitions. *) +val translate : Validator.program -> Mir.program diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index e48162414..e7f7ac847 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 } @@ -62,12 +63,14 @@ rule token = parse | "REEL" -> REAL | "afficher" -> PRINT | "afficher_erreur" -> PRINT_ERR + | "ajouter" -> ADD | "alias" -> ALIAS | "alors" -> THEN | "anomalie" -> ANOMALY | "application" -> APPLICATION | "apres" -> AFTER - | "argument" -> INPUT_ARG + | "arguments" -> INPUT_ARGS + | "arranger_evenements" -> ARRANGE_EVENTS | "attribut" -> ATTRIBUT | "autorise" -> AUTHORIZE | "avec" -> WITH @@ -76,6 +79,7 @@ rule token = parse | "calculee" -> COMPUTED | "calculer" -> COMPUTE | "categorie" -> CATEGORY + | "champ_evenement" -> EVENT_FIELD | "cible" -> TARGET | "const" -> CONST | "dans" -> IN @@ -83,13 +87,19 @@ rule token = parse | "domaine" -> DOMAIN | "enchaineur" -> CHAINING | "erreur" -> ERROR + | "espace_variables" -> VARIABLE_SPACE + | "est_variable" -> IS_VARIABLE | "et" -> AND + | "evenement" -> EVENT + | "evenements" -> EVENTS | "exporte_erreurs" -> EXPORT_ERRORS | "faire" -> DO + | "filtrer" -> FILTER | "finalise_erreurs" -> FINALIZE_ERRORS | "finquand" -> ENDWHEN | "finsi" -> ENDIF | "fonction" -> FONCTION + | "increment" -> STEP | "indefini" -> UNDEFINED | "indenter" -> INDENT | "informative" -> INFORMATIVE @@ -111,6 +121,7 @@ rule token = parse | "pour" -> FOR | "puis_quand" -> THEN_WHEN | "quand" -> WHEN + | "reference" -> REFERENCE | "regle" -> RULE | "restaurer" -> RESTORE | "restituee" -> GIVEN_BACK @@ -124,10 +135,12 @@ rule token = parse | "specialise" -> SPECIALIZE | "tableau" -> TABLE | "taille" -> SIZE - | "temporaire" -> TEMPORARY + | "trier" -> SORT | "type" -> TYPE | "un" -> ONE + | "valeur" -> VALUE | "variable" -> VARIABLE + | "variables_temporaires" -> TEMP_VARS | "verif" -> VERIFICATION | "verifiable" -> VERIFIABLE | "verifier" -> VERIFY diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 34968f67f..2f99e3ab7 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -25,9 +25,9 @@ along with this program. If not, see . | CompSubTyp of string Pos.marked | Attr of variable_attribute - let parse_to_atom (v: parse_val) : variable Com.atom = + let parse_to_atom (v: parse_val) (pos : Pos.t) : Com.m_var_name Com.atom = match v with - | ParseVar v -> AtomVar v + | ParseVar v -> AtomVar (Pos.mark v pos) | ParseInt v -> AtomLiteral (Float (float_of_int v)) (** Module generated automaticcaly by Menhir, the parser generator *) @@ -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 @@ -47,7 +47,7 @@ along with this program. If not, see . %token BOOLEAN DATE_YEAR DATE_DAY_MONTH_YEAR DATE_MONTH INTEGER REAL %token ONE IN APPLICATION CHAINING TYPE TABLE %token COMPUTED CONST ALIAS INPUT FOR -%token RULE VERIFICATION TARGET INPUT_ARG TEMPORARY SIZE RESULT +%token RULE VERIFICATION TARGET INPUT_ARGS TEMP_VARS SIZE RESULT %token IF THEN ELSEIF ELSE ENDIF PRINT PRINT_ERR NAME INDENT %token WHEN DO THEN_WHEN ELSE_DO ENDWHEN NOTHING %token COMPUTE VERIFY WITH VERIF_NUMBER COMPL_NUMBER NB_CATEGORY @@ -57,7 +57,9 @@ along with this program. If not, see . %token ERROR ANOMALY DISCORDANCE %token INFORMATIVE OUTPUT FONCTION VARIABLE ATTRIBUT %token BASE GIVEN_BACK COMPUTABLE BY_DEFAULT -%token DOMAIN SPECIALIZE AUTHORIZE VERIFIABLE +%token DOMAIN SPECIALIZE AUTHORIZE VERIFIABLE EVENT EVENTS VALUE STEP +%token EVENT_FIELD ARRANGE_EVENTS SORT FILTER ADD REFERENCE +%token IS_VARIABLE VARIABLE_SPACE %token EOF @@ -74,7 +76,7 @@ along with this program. If not, see . %% %inline with_pos(X): -| x = X { (x, mk_position $sloc) } +| x = X { Pos.mark x (mk_position $sloc) } symbol_with_pos: | s = with_pos(SYMBOL) { s } @@ -103,8 +105,10 @@ 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 } +| vsl = variable_space_decl_etc { vsl } | ol = output_etc { ol } | rl = rule_etc { rl } | vl = verification_etc { vl } @@ -117,7 +121,7 @@ var_typ: var_category_decl_etc: | c = with_pos(var_category_decl) l = with_pos(symbol_colon_etc)* { - Pos.same_pos_as (VarCatDecl c) c :: l + Pos.same (VarCatDecl c) c :: l } var_category_decl: @@ -127,6 +131,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 (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 } @@ -135,19 +151,19 @@ rule_domain_decl: SEMICOLON { let err msg pos = Errors.raise_spanned_error msg pos in let fold (dno, dso, dco, dpdo) = function - | (Some dn, _, _, _), pos -> + | Pos.Mark ((Some dn, _, _, _), pos) -> if dno = None then Some dn, dso, dco, dpdo else err "rule domain names are already defined" pos - | (_, Some ds, _, _), pos -> + | Pos.Mark ((_, Some ds, _, _), pos) -> if dso = None then dno, Some ds, dco, dpdo else err "rule domain specialization is already specified" pos - | (_, _, Some dc, _), pos -> + | Pos.Mark ((_, _, Some dc, _), pos) -> if dco = None then dno, dso, Some dc, dpdo else err "rule domain is already calculated" pos - | (_, _, _, Some dpd), pos -> + | Pos.Mark ((_, _, _, Some dpd), pos) -> if dpdo = None then dno, dso, dco, Some dpd else err "rule domain is already defined by defaut" pos - | (_, _, _, _), _ -> assert false + | Pos.Mark ((_, _, _, _), _) -> assert false in let init = None, None, None, None in let dno, dso, dco, dpdo = List.fold_left fold init rdom_params in @@ -183,22 +199,22 @@ verif_domain_decl: SEMICOLON { let err msg pos = Errors.raise_spanned_error msg pos in let fold (dno, dso, dvo, dpdo, dco) = function - | (Some dn, _, _, _, _), pos -> + | Pos.Mark ((Some dn, _, _, _, _), pos) -> if dno = None then Some dn, dso, dvo, dpdo, dco else err "verif domain names are already defined" pos - | (_, Some ds, _, _, _), pos -> + | Pos.Mark ((_, Some ds, _, _, _), pos) -> if dso = None then dno, Some ds, dvo, dpdo, dco else err "verif domain specialization is already specified" pos - | (_, _, Some dv, _, _), pos -> + | Pos.Mark ((_, _, Some dv, _, _), pos) -> if dvo = None then dno, dso, Some dv, dpdo, dco else err "verif domain authorization is already specified" pos - | (_, _, _, Some dpd, _), pos -> + | Pos.Mark ((_, _, _, Some dpd, _), pos) -> if dpdo = None then dno, dso, dvo, Some dpd, dco else err "verif domain is already defined by defaut" pos - | (_, _, _, _, Some dcd), pos -> + | Pos.Mark ((_, _, _, _, Some dcd), pos) -> if dco = None then dno, dso, dvo, dpdo, Some dcd else err "verif domain is already verifiable" pos - | (_, _, _, _, _), _ -> assert false + | Pos.Mark ((_, _, _, _, _), _) -> assert false in let init = None, None, None, None, None in let dno, dso, dvo, dpdo, dco = List.fold_left fold init vdom_params in @@ -221,12 +237,12 @@ verif_domain_decl: } var_category_id: -| INPUT TIMES { ["saisie", Pos.no_pos; "*", Pos.no_pos] } -| INPUT l = symbol_with_pos+ { ("saisie", Pos.no_pos) :: l } -| COMPUTED TIMES { ["calculee", Pos.no_pos; "*", Pos.no_pos] } -| COMPUTED BASE { ["calculee", Pos.no_pos; "*", Pos.no_pos] } -| COMPUTED { ["calculee", Pos.no_pos] } -| TIMES { ["*", Pos.no_pos] } +| INPUT TIMES { [Pos.without "saisie"; Pos.without "*"] } +| INPUT l = symbol_with_pos+ { (Pos.without "saisie") :: l } +| COMPUTED TIMES { [Pos.without "calculee"; Pos.without "*"] } +| COMPUTED BASE { [Pos.without "calculee"; Pos.without "*"] } +| COMPUTED { [Pos.without "calculee"] } +| TIMES { [Pos.without "*"] } vdom_param: | vdom_names = separated_nonempty_list(COMMA, symbol_list_with_pos) @@ -304,12 +320,12 @@ comp_variable: in let comp_category = subtyp - |> List.filter (function CompSubTyp ("base", _) -> true | _ -> false) + |> List.filter (function CompSubTyp (Pos.Mark ("base", _)) -> true | _ -> false) |> List.map (function CompSubTyp x -> x | _ -> assert false) in let comp_is_givenback = subtyp - |> List.exists (function CompSubTyp ("restituee", _) -> true | _ -> false) + |> List.exists (function CompSubTyp (Pos.Mark ("restituee", _)) -> true | _ -> false) in { comp_name; @@ -382,6 +398,62 @@ input_variable: } } +variable_space_decl_etc: +| vs = with_pos(variable_space_decl) l = with_pos(symbol_colon_etc)* { vs :: l } + +variable_space_decl: +| VARIABLE_SPACE m_name = symbol_with_pos COLON + vs_params = separated_nonempty_list(COLON, with_pos(vs_param)) SEMICOLON { + let err msg pos = Errors.raise_spanned_error msg pos in + let fold (co, pdo) = function + | Pos.Mark ((Some cats, _), pos) -> + if co = None then Some cats, pdo + else err "variable space categories are already specified" pos + | Pos.Mark ((_, Some ()), pos) -> + if pdo = None then co, Some () + else err "by_default is already calculated" pos + | Pos.Mark ((_, _), _) -> assert false + in + let init = None, None in + let co, pdo = List.fold_left fold init vs_params in + let decl = Com.{ + vs_id = -1; + vs_name = m_name; + vs_cats = ( + match co with + | None -> + let msg = Pp.spr "a category must be specified" in + Errors.raise_spanned_error msg (Pos.get m_name) + | Some cats -> cats + ); + vs_by_default = (match pdo with None -> false | _ -> true); + } in + VariableSpaceDecl decl + } + +vs_cat: +| INPUT { Com.CatVar.LocInput } +| COMPUTED { Com.CatVar.LocComputed } +| BASE { Com.CatVar.LocBase } + +vs_param: +| CATEGORY vs_cats = separated_nonempty_list(COMMA, with_pos(vs_cat)) { + let rec check map = function + | (Pos.Mark (lct, pos) as m_lct) :: l -> + if Com.CatVar.LocMap.mem lct map then ( + let msg = + Pp.spr "category \"%a\" already specified" Com.CatVar.pp_loc lct + in + Errors.raise_spanned_error msg pos + ); + check (Com.CatVar.LocMap.add lct m_lct map) l + | [] -> map + in + let cats = check Com.CatVar.LocMap.empty vs_cats in + Some cats, None + } +| BY_DEFAULT { None, Some () } + rule_etc: | RULE name = symbol_list_with_pos COLON header = nonempty_list(with_pos(rule_header_elt)) @@ -391,28 +463,28 @@ rule_etc: let uname = Pos.unmark name in let begPos = match uname with - | h :: _ -> Pos.get_position h + | h :: _ -> Pos.get h | [] -> assert false in let rec aux tags endPos = function | [num] -> - let pos = Pos.make_position_between begPos endPos in - num, (tags, pos) - | h :: t -> aux (h :: tags) (Pos.get_position h) t + let pos = Pos.make_between begPos endPos in + num, (Pos.mark tags pos) + | h :: t -> aux (h :: tags) (Pos.get h) t | [] -> assert false in aux [] begPos uname in let rule_number = - try Pos.map_under_mark int_of_string num + try Pos.map int_of_string num with _ -> Errors.raise_spanned_error "this rule doesn't have an execution number" - (Pos.get_position num) + (Pos.get num) in let rule_apps, rule_chainings, rule_tmp_vars = let rec aux apps_opt chs_opt vars_opt = function - | (`Applications apps', pos) :: h -> + | Pos.Mark (`Applications apps', pos) :: h -> let apps_opt' = match apps_opt with | None -> Some (apps', pos) @@ -420,11 +492,11 @@ rule_etc: Errors.raise_spanned_error (Format.asprintf "application list already declared %a" - Pos.format_position old_pos) + Pos.format old_pos) pos in aux apps_opt' chs_opt vars_opt h - | (`Chainings chs', pos) :: h -> + | Pos.Mark (`Chainings chs', pos) :: h -> let chs_opt' = match chs_opt with | None -> Some (chs', pos) @@ -432,11 +504,11 @@ rule_etc: Errors.raise_spanned_error (Format.asprintf "chaining list already declared %a" - Pos.format_position old_pos) + Pos.format old_pos) pos in aux apps_opt chs_opt' vars_opt h - | (`TmpVars vars', pos) :: h -> + | Pos.Mark (`TmpVars vars', pos) :: h -> let vars_opt' = match vars_opt with | None -> Some (vars', pos) @@ -444,7 +516,7 @@ rule_etc: Errors.raise_spanned_error (Format.asprintf "temporary variables already declared %a" - Pos.format_position old_pos) + Pos.format old_pos) pos in aux apps_opt chs_opt vars_opt' h @@ -453,58 +525,42 @@ rule_etc: match apps_opt with | Some (apps, _) -> List.fold_left - (fun res (app, pos) -> + (fun res (Pos.Mark (app, pos)) -> match StrMap.find_opt app res with - | Some (_, old_pos) -> + | Some (Pos.Mark (_, old_pos)) -> let msg = Format.asprintf "application %s already declared %a" app - Pos.format_position old_pos + Pos.format old_pos in Errors.raise_spanned_error msg pos - | None -> StrMap.add app (app, pos) res) + | None -> StrMap.add app (Pos.mark app pos) res) StrMap.empty apps | None -> Errors.raise_spanned_error "this rule doesn't belong to an application" - (Pos.get_position num) + (Pos.get num) in let chs = match chs_opt with | Some (chs, _) -> List.fold_left - (fun res (ch, pos) -> + (fun res (Pos.Mark (ch, pos)) -> match StrMap.find_opt ch res with - | Some (_, old_pos) -> + | Some (Pos.Mark (_, old_pos)) -> let msg = Format.asprintf "chaining %s already declared %a" ch - Pos.format_position old_pos + Pos.format old_pos in Errors.raise_spanned_error msg pos - | None -> StrMap.add ch (ch, pos) res) + | None -> StrMap.add ch (Pos.mark ch pos) res) StrMap.empty chs | None -> StrMap.empty in - let vars = - List.fold_left - (fun res (vnm, vt) -> - let vn, pos = vnm in - match StrMap.find_opt vn res with - | Some ((_, old_pos), _) -> - let msg = - Format.asprintf - "temporary variable %s already declared %a" - vn - Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - | None -> StrMap.add vn (vnm, vt) res) - StrMap.empty - (match vars_opt with None -> [] | Some (l, _) -> l) - in + let vars = match vars_opt with None -> [] | Some (l, _) -> l in apps, chs, vars in aux None None None header @@ -518,13 +574,13 @@ rule_etc: rule_tmp_vars; rule_formulaes; } in - Pos.same_pos_as (Rule rule) name :: l + Pos.same (Rule rule) name :: l } rule_header_elt: | APPLICATION COLON apps = symbol_enumeration SEMICOLON { `Applications apps } | CHAINING COLON chs = symbol_enumeration SEMICOLON { `Chainings chs } -| VARIABLE TEMPORARY COLON +| TEMP_VARS COLON tmp_vars = separated_nonempty_list(COMMA, temporary_variable_name) SEMICOLON { `TmpVars tmp_vars } @@ -544,22 +600,21 @@ target_etc: target_args; target_result = None; target_tmp_vars; - target_nb_tmps = -1; - target_sz_tmps = -1; - target_nb_refs = -1; target_prog; } in - Pos.same_pos_as (Target target) name :: l + Pos.same (Target target) name :: l } target_header_elt: | APPLICATION COLON apps = symbol_enumeration SEMICOLON { Target_apps apps } -| INPUT_ARG COLON - inputs = separated_nonempty_list(COMMA, with_pos(variable_name)) SEMICOLON - { Target_input_arg inputs } -| VARIABLE TEMPORARY COLON - tmp_vars = separated_nonempty_list(COMMA, temporary_variable_name) SEMICOLON - { Target_tmp_vars tmp_vars } +| INPUT_ARGS COLON + inputs = separated_nonempty_list(COMMA, with_pos(variable_name)) SEMICOLON { + Target_input_arg inputs + } +| TEMP_VARS COLON + tmp_vars = separated_nonempty_list(COMMA, temporary_variable_name) SEMICOLON { + Target_tmp_vars tmp_vars + } function_etc: | FONCTION name = symbol_with_pos COLON @@ -577,54 +632,55 @@ function_etc: target_args; target_result; target_tmp_vars; - target_nb_tmps = -1; - target_sz_tmps = -1; - target_nb_refs = -1; target_prog; } in - Pos.same_pos_as (Function target) name :: l + Pos.same (Function target) name :: l } function_header_elt: | APPLICATION COLON apps = symbol_enumeration SEMICOLON { Target_apps apps } -| INPUT_ARG COLON - inputs = separated_nonempty_list(COMMA, with_pos(variable_name)) SEMICOLON - { Target_input_arg inputs } -| VARIABLE TEMPORARY COLON - tmp_vars = separated_nonempty_list(COMMA, temporary_variable_name) SEMICOLON - { Target_tmp_vars tmp_vars } -| RESULT COLON res = with_pos(variable_name) SEMICOLON { Function_result res } +| INPUT_ARGS COLON + inputs = separated_nonempty_list(COMMA, with_pos(variable_name)) SEMICOLON { + Target_input_arg inputs + } +| TEMP_VARS COLON + tmp_vars = separated_nonempty_list(COMMA, temporary_variable_name) SEMICOLON { + Target_tmp_vars tmp_vars + } +| RESULT COLON res = with_pos(variable_name) SEMICOLON { + Function_result res + } temporary_variable_name: | name = symbol_with_pos size = with_pos(comp_variable_table)? { - let name_str, name_pos = name in - (parse_variable_name $sloc name_str, name_pos), size + let name_str, name_pos = Pos.to_couple name in + (Pos.mark (parse_variable_name $sloc name_str) name_pos), size } instruction_list_etc: | i_opt = with_pos(instruction) l = with_pos(symbol_colon_etc)* { match Pos.unmark i_opt with | None -> [], l - | Some i -> [Pos.same_pos_as i i_opt], l + | Some i -> [Pos.same i i_opt], l } | i_opt = with_pos(instruction) il_etc = instruction_list_etc { match Pos.unmark i_opt with | None -> il_etc | Some i -> let il, l = il_etc in - (Pos.same_pos_as i i_opt) :: il, l + (Pos.same i i_opt) :: il, l } instruction_list_rev: | i_opt = with_pos(instruction) { match Pos.unmark i_opt with | None -> [] - | Some i -> [Pos.same_pos_as i i_opt] + | Some i -> [Pos.same i i_opt] } | il = instruction_list_rev i_opt = with_pos(instruction) { match Pos.unmark i_opt with | None -> il - | Some i -> (Pos.same_pos_as i i_opt) :: il + | Some i -> (Pos.same i i_opt) :: il } instruction: @@ -649,7 +705,7 @@ instruction: Some (ComputeTarget (target, args_list)) } | VERIFY DOMAIN dom = symbol_list_with_pos SEMICOLON { - let expr = Com.Literal (Com.Float 1.0), Pos.no_pos in + let expr = Pos.without (Com.Literal (Com.Float 1.0)) in Some (ComputeVerifs (dom, expr)) } | VERIFY DOMAIN dom = symbol_list_with_pos COLON @@ -664,28 +720,98 @@ 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)) + let var = Pos.same (Com.Normal (Pos.unmark vn)) vn in + match it_params with + | Pos.Mark (`VarInterval _, _) :: _ -> + let var_intervals = + let fold var_intervals = function + | Pos.Mark (`VarInterval (e0, e1, step), _) -> (e0, e1, step) :: var_intervals + | Pos.Mark (`VarList _, pos) | Pos.Mark (`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 + | Pos.Mark (`VarList vl, _) -> (List.rev vl) @ var_list, var_cats + | Pos.Mark (`VarCatsIt vc, _) -> var_list, vc :: var_cats + | Pos.Mark (`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 { - 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, 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 instrs)) + Some ( + Restore ( + List.rev var_list, + List.rev var_cats, + List.rev event_list, + List.rev event_filter, + 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, add = + let fold (sort, sort_pos, filter, filter_pos, add, add_pos) = function + | Pos.Mark (`ArrangeEventsSort (v0, v1, e), pos) when sort = None -> + (Some (v0, v1, e), pos, filter, filter_pos, add, add_pos) + | Pos.Mark (`ArrangeEventsFilter (v, e), pos) when filter = None -> + (sort, sort_pos, Some (v, e), pos, add, add_pos) + | Pos.Mark (`ArrangeEventsAdd e, pos) when add = None -> + (sort, sort_pos, filter, filter_pos, Some e, pos) + | Pos.Mark (`ArrangeEventsSort _, pos) -> + let msg = + Format.asprintf + "event sorting already specified at %a" + Pos.format sort_pos + in + Errors.raise_spanned_error msg pos + | Pos.Mark (`ArrangeEventsFilter _, pos) -> + let msg = + Format.asprintf + "event filter already specified at %a" + Pos.format sort_pos + in + Errors.raise_spanned_error msg pos + | Pos.Mark (`ArrangeEventsAdd _, pos) -> + let msg = + Format.asprintf + "event creation already specified at %a" + Pos.format add_pos + in + Errors.raise_spanned_error msg pos + in + let sort, _, filter, _, add, _ = + List.fold_left fold + (None, Pos.none, None, Pos.none, None, Pos.none) + arr_params + 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, add + in + 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)) @@ -698,7 +824,7 @@ target_args: | COLON WITH args = separated_nonempty_list(COMMA, arg_variable) { args } arg_variable: -| s = with_pos(SYMBOL) { parse_variable $sloc (fst s), snd s } +| s = with_pos(SYMBOL) { Pos.same (parse_variable $sloc (Pos.unmark s)) s } instruction_else_branch: | ELSEIF e = with_pos(expression) @@ -719,26 +845,24 @@ instruction_then_when_branch: ((e, List.rev ild, mk_position $sloc) :: iltwl, ed) } | ELSE_DO il = instruction_list_rev ENDWHEN { - ([], (List.rev il, mk_position $sloc)) + ([], (Pos.mark (List.rev il) (mk_position $sloc))) } -| ENDWHEN { ([], ([], Pos.no_pos)) } +| ENDWHEN { ([], (Pos.without [])) } 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 m_a = with_pos(var_access) RPAREN { + match Pos.unmark f with + | "nom" -> Com.PrintAccess (Com.Name, m_a) + | "alias" -> Com.PrintAccess (Com.Alias, m_a) + | _ -> 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" } @@ -747,7 +871,7 @@ print_function: print_precision: | COLON min = symbol_with_pos { - let min_str, min_pos = min in + let min_str, min_pos = Pos.to_couple min in let min_val = try int_of_string min_str with | Failure _ -> Errors.raise_spanned_error "should be an integer" min_pos @@ -758,14 +882,14 @@ print_precision: } | COLON min = symbol_with_pos RANGE max = symbol_with_pos { - let min_str, min_pos = min in + let min_str, min_pos = Pos.to_couple min in let min_val = try int_of_string min_str with | Failure _ -> Errors.raise_spanned_error "should be an integer" min_pos in (if min_val < 0 then Errors.raise_spanned_error "precision must be positive" min_pos); - let max_str, max_pos = max in + let max_str, max_pos = Pos.to_couple max in let max_val = try int_of_string max_str with | Failure _ -> Errors.raise_spanned_error "should be an integer" max_pos @@ -782,7 +906,7 @@ print_precision: it_param: | 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 + List.map (fun vn -> Pos.same (Com.Normal (Pos.unmark vn)) vn) vars in `VarList vl } @@ -798,10 +922,14 @@ it_param: let expr = match expr_opt with | Some expr -> expr - | None -> Com.Literal (Com.Float 1.0), Pos.no_pos + | None -> Pos.without (Com.Literal (Com.Float 1.0)) in `VarCatsIt (vcats, expr) } +| expr0 = with_pos(expression) RANGE expr1 = with_pos(expression) + STEP step = with_pos(expression) COLON { + `VarInterval (expr0, expr1, step) + } it_param_with_expr: | WITH expr = with_pos(expression) COLON { expr } @@ -809,16 +937,23 @@ it_param_with_expr: rest_param: | 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 + List.map (fun vn -> Pos.same (Com.Normal (Pos.unmark vn)) vn) vars in `VarList vl } | VARIABLE vn = symbol_with_pos COLON vparams = nonempty_list(rest_param_category) { - let var = Pos.same_pos_as (Normal (Pos.unmark vn)) vn in + let var = Pos.same (Com.Normal (Pos.unmark vn)) vn in 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 + } +| EVENT vn = symbol_with_pos COLON WITH expr = with_pos(expression) COLON { + let var = Pos.same (Com.Normal (Pos.unmark vn)) vn in + `EventFilter (var, expr) + } rest_param_category: | CATEGORY vcat_list = separated_nonempty_list(COMMA, with_pos(var_category_id)) @@ -833,7 +968,7 @@ rest_param_category: let expr = match expr_opt with | Some expr -> expr - | None -> Com.Literal (Com.Float 1.0), Pos.no_pos + | None -> Pos.without (Com.Literal (Com.Float 1.0)) in (vcats, expr) } @@ -841,6 +976,21 @@ 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 (Com.Normal (Pos.unmark v0)) v0 in + let var1 = Pos.same (Com.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 (Com.Normal (Pos.unmark v)) v in + `ArrangeEventsFilter (var, expr) + } +| ADD expr = with_pos(expression) COLON { + `ArrangeEventsAdd (expr) + } + formula_kind: | f = formula { SingleFormula f } | fs = for_formula { let (lv, ft) = fs in MultipleFormulaes (lv, ft) } @@ -848,16 +998,32 @@ 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)? { (s, i) } +var_access: +| s = symbol_with_pos m_i_opt = with_pos(brackets)? { + let m_v = Pos.map (parse_variable $sloc) s in + match m_i_opt with + | None -> Com.VarAccess m_v + | Some m_i -> Com.TabAccess (m_v, m_i) + } +| v = symbol_with_pos LBRACKET idxFmt = symbol_with_pos + COLON idx = with_pos(sum_expression) RBRACKET { + let m_v = Pos.same (parse_variable $sloc (Pos.unmark v)) v in + let idxFmt = parse_index_format idxFmt in + Com.ConcAccess (m_v, idxFmt, idx) + } +| EVENT_FIELD LPAREN idx = with_pos(expression) + COMMA f = symbol_with_pos RPAREN { + Com.FieldAccess (idx, f, -1) + } formula: -| lvalue = lvalue EQUALS e = with_pos(expression) { - let v, idx = lvalue in - (v, idx, e) +| access = with_pos(var_access) EQUALS e = with_pos(expression) { + VarDecl (access, e) + } +| EVENT_FIELD LPAREN idx = with_pos(expression) + COMMA f = symbol_with_pos RPAREN REFERENCE v = symbol_with_pos { + let var = Pos.same (parse_variable $sloc (Pos.unmark v)) v in + EventFieldRef (idx, f, -1, var) } verification_etc: @@ -871,43 +1037,43 @@ verification: let uname = Pos.unmark name in let begPos = match uname with - | h :: _ -> Pos.get_position h + | h :: _ -> Pos.get h | [] -> assert false in let rec aux tags endPos = function | [num] -> - let pos = Pos.make_position_between begPos endPos in - num, (tags, pos) - | h :: t -> aux (h :: tags) (Pos.get_position h) t + let pos = Pos.make_between begPos endPos in + num, (Pos.mark tags pos) + | h :: t -> aux (h :: tags) (Pos.get h) t | [] -> assert false in aux [] begPos uname in let verif_number = - try Pos.map_under_mark int_of_string num + try Pos.map int_of_string num with _ -> Errors.raise_spanned_error "this verification doesn't have an execution number" - (Pos.get_position num) + (Pos.get num) in let verif_apps = match apps with | [] -> Errors.raise_spanned_error "this verification doesn't belong to an application" - (Pos.get_position verif_number) + (Pos.get verif_number) | _ -> List.fold_left - (fun res (app, pos) -> + (fun res (Pos.Mark (app, pos)) -> match StrMap.find_opt app res with - | Some (_, old_pos) -> + | Some (Pos.Mark (_, old_pos)) -> let msg = Format.asprintf "application %s already declared %a" app - Pos.format_position old_pos + Pos.format old_pos in Errors.raise_spanned_error msg pos - | None -> StrMap.add app (app, pos) res) + | None -> StrMap.add app (Pos.mark app pos) res) StrMap.empty apps in @@ -981,18 +1147,14 @@ loop_variable_value_name: | s = SYMBOL { parse_parameter $sloc s } loop_variables_value: -| s = with_pos(loop_variable_value_name) EQUALS e = enumeration_loop { - let s, loc = s in ((s, loc), e) - } +| s = with_pos(loop_variable_value_name) EQUALS e = enumeration_loop { s, e } loop_variables_ranges: | r = loop_variables_range { [r] } | r = loop_variables_range AND rs = loop_variables_ranges { r::rs } loop_variables_range: -| ONE s = with_pos(loop_variable_value_name) IN e = enumeration_loop { - let (s, loc) = s in ((s, loc), e) - } +| ONE s = with_pos(loop_variable_value_name) IN e = enumeration_loop { s, e } enumeration_loop: | i = enumeration_loop_item { [i] } @@ -1002,7 +1164,7 @@ enumeration_loop_item: | bounds = interval_loop { bounds } | s = SYMBOL { let pos = mk_position $sloc in - Com.Single (parse_to_atom (parse_variable_or_int $sloc s), pos) + Com.Single (Pos.mark (parse_to_atom (parse_variable_or_int $sloc s) pos) pos) } range_or_minus: @@ -1012,8 +1174,8 @@ range_or_minus: interval_loop: | i1 = SYMBOL rm = range_or_minus i2 = SYMBOL { let pos = mk_position $sloc in - let l1 = parse_to_atom (parse_variable_or_int $sloc i1), pos in - let l2 = parse_to_atom (parse_variable_or_int $sloc i2), pos in + let l1 = Pos.mark (parse_to_atom (parse_variable_or_int $sloc i1) pos) pos in + let l2 = Pos.mark (parse_to_atom (parse_variable_or_int $sloc i2) pos) pos in match rm with | `Range -> Com.Range (l1, l2) | `Minus -> Com.Interval (l1, l2) @@ -1025,19 +1187,31 @@ 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 (Pos.mark (Com.FieldAccess (idx, field, -1)) pos) + } +| v = symbol_with_pos LBRACKET idxFmt = symbol_with_pos + COLON idx = with_pos(sum_expression) RBRACKET { + let m_v = Pos.same (parse_variable $sloc (Pos.unmark v)) v in + let idxFmt = parse_index_format idxFmt in + let pos = mk_position $sloc in + Com.VarValue (Pos.mark (Com.ConcAccess (m_v, idxFmt, idx)) pos) + } | s = SYMBOL { let pos = mk_position $sloc in match parse_variable_or_int $sloc s with - | ParseVar v -> Com.VarValue (v, pos) - | ParseInt i -> Com.FloatValue (float_of_int i, pos) + | ParseVar v -> Com.VarValue (Pos.mark (Com.VarAccess (Pos.mark v pos)) pos) + | ParseInt i -> Com.FloatValue (Pos.mark (float_of_int i) pos) } interval: | i1 = SYMBOL RANGE i2 = SYMBOL { 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 + let ir1 = Pos.mark (parse_int $sloc i1) pos in + let ir2 = Pos.mark (parse_int $sloc i2) pos in + Com.IntervalValue (ir1, ir2) : set_value } (* Some intervals are "03..06" so we must keep the prefix "0" *) @@ -1089,18 +1263,29 @@ product_expression: %inline product_operator: | TIMES { Com.Mul } | DIV { Com.Div } - -table_index_name: -s = SYMBOL { parse_variable $sloc s } +| MOD { Com.Mod } 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) } -| a = with_pos(factor_atom) { - match Pos.unmark a with - | Com.AtomVar v -> Com.Var v +| EVENT_FIELD LPAREN m_idx = with_pos(expression) + COMMA field = symbol_with_pos RPAREN { + Var (FieldAccess (m_idx, field, -1)) + } +| v = symbol_with_pos LBRACKET idxFmt = symbol_with_pos + COLON idx = with_pos(sum_expression) RBRACKET { + let m_v = Pos.same (parse_variable $sloc (Pos.unmark v)) v in + let idxFmt = parse_index_format idxFmt in + Var (ConcAccess (m_v, idxFmt, idx)) + } +| s = symbol_with_pos m_i = with_pos(brackets) { + let m_v = Pos.same (parse_variable $sloc (Pos.unmark s)) s in + Var (TabAccess (m_v, m_i)) + } +| a = factor_atom { + match a with + | Com.AtomVar v -> Com.Var (VarAccess v) | Com.AtomLiteral l -> Com.Literal l } | LPAREN e = expression RPAREN { e } @@ -1136,16 +1321,19 @@ 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) - } -| SIZE LPAREN var = symbol_with_pos RPAREN { - Size (parse_variable $sloc (fst var), snd var) +| ATTRIBUT LPAREN access = with_pos(var_access) + COMMA attr = symbol_with_pos RPAREN { + Attribut (access, attr) } +| SIZE LPAREN access = with_pos(var_access) RPAREN { Size access } | NB_ANOMALIES LPAREN RPAREN { NbAnomalies } | NB_DISCORDANCES LPAREN RPAREN { NbDiscordances } | NB_INFORMATIVES LPAREN RPAREN { NbInformatives } | NB_BLOCKING LPAREN RPAREN { NbBloquantes } +| IS_VARIABLE LPAREN access = with_pos(var_access) + COMMA name = symbol_with_pos RPAREN { + IsVariable (access, name) + } | s = with_pos(function_name) LPAREN RPAREN { FuncCall (parse_function_name s, []) } diff --git a/src/mlang/m_frontend/parse_utils.ml b/src/mlang/m_frontend/parse_utils.ml index 3cbb37d78..3b6ac0bcb 100644 --- a/src/mlang/m_frontend/parse_utils.ml +++ b/src/mlang/m_frontend/parse_utils.ml @@ -16,11 +16,11 @@ module E = Errors -let mk_position sloc = Pos.make_position (fst sloc).Lexing.pos_fname sloc +let mk_position sloc = Pos.make (fst sloc).Lexing.pos_fname sloc (** {1 Frontend variable names}*) -let parse_variable_name sloc (s : string) : Mast.variable_name = +let parse_variable_name sloc (s : string) : string = if not (String.equal (String.uppercase_ascii s) s) then E.raise_spanned_error "invalid variable name" (mk_position sloc) else s @@ -44,7 +44,7 @@ let dup_exists l = dup_consecutive (List.sort sort_on_third l) (** Parse variable with parameters, parameters have to be lowercase letters *) -let parse_variable_generic_name sloc (s : string) : Mast.variable_generic_name = +let parse_variable_generic_name sloc (s : string) : Com.var_name_generic = let parameters = ref [] in for i = String.length s - 1 downto 0 do let p = s.[i] in @@ -58,23 +58,23 @@ let parse_variable_generic_name sloc (s : string) : Mast.variable_generic_name = if dup_exists !parameters then E.raise_spanned_error "variable parameters should have distinct names" (mk_position sloc); - { Mast.parameters = !parameters; Mast.base = s } + { Com.parameters = !parameters; Com.base = s } let parse_variable sloc (s : string) = - try Mast.Normal (parse_variable_name sloc s) + try Com.Normal (parse_variable_name sloc s) with E.StructuredError _ -> ( - try Mast.Generic (parse_variable_generic_name sloc s) + try Com.Generic (parse_variable_generic_name sloc s) with E.StructuredError _ -> E.raise_spanned_error "invalid variable name" (mk_position sloc)) -type parse_val = ParseVar of Mast.variable | ParseInt of int +type parse_val = ParseVar of Com.var_name | ParseInt of int let parse_variable_or_int sloc (s : string) : parse_val = try ParseInt (int_of_string s) with Failure _ -> ( - try ParseVar (Mast.Normal (parse_variable_name sloc s)) + try ParseVar (Com.Normal (parse_variable_name sloc s)) with E.StructuredError _ -> ( - try ParseVar (Mast.Generic (parse_variable_generic_name sloc s)) + try ParseVar (Com.Generic (parse_variable_generic_name sloc s)) with E.StructuredError _ -> E.raise_spanned_error "invalid variable name" (mk_position sloc))) @@ -87,9 +87,10 @@ let parse_literal sloc (s : string) : Com.literal = try Com.Float (float_of_string s) with Failure _ -> E.raise_spanned_error "invalid literal" (mk_position sloc) -let parse_atom sloc (s : string) : Mast.variable Com.atom = +let parse_atom sloc (s : string) : Com.m_var_name Com.atom = try Com.AtomLiteral (Com.Float (float_of_string s)) - with Failure _ -> Com.AtomVar (parse_variable sloc s) + with Failure _ -> + Com.AtomVar (Pos.mark (parse_variable sloc s) (mk_position sloc)) let parse_func_name _ (s : string) : Mast.func_name = s @@ -116,9 +117,10 @@ 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 + Pos.map map f_name (* # parse_string # * Takes a litteral string and produces a String.t of the corresponding chars @@ -178,14 +180,21 @@ let parse_string (s : string) : string = in aux 0 +let parse_index_format (m_s : string Pos.marked) : string Pos.marked = + let s = Pos.unmark m_s in + if not (String.equal (String.uppercase_ascii s) s) then + Errors.raise_spanned_error "bad index format" (Pos.get m_s); + m_s + let parse_if_then_etc l = let rec aux = function - | [ (Some e, ilt, pos) ] -> [ (Com.IfThenElse (e, ilt, []), pos) ] + | [ (Some e, ilt, pos) ] -> [ Pos.mark (Com.IfThenElse (e, ilt, [])) pos ] | [ (None, ile, _pos) ] -> ile - | (Some e, ilt, pos) :: le -> [ (Com.IfThenElse (e, ilt, aux le), pos) ] + | (Some e, ilt, pos) :: le -> + [ Pos.mark (Com.IfThenElse (e, ilt, aux le)) pos ] | _ -> assert false in - match aux l with [ (i, _pos) ] -> i | _ -> assert false + match aux l with [ Pos.Mark (i, _pos) ] -> i | _ -> assert false let parse_when_do_etc (twl, ed) = Com.WhenDoElse (twl, ed) @@ -198,40 +207,40 @@ type target_header = let parse_target_or_function_header name is_function header = let rec aux apps_opt args_opt vars_opt res_opt = function - | (Target_apps apps', pos) :: h -> + | Pos.Mark (Target_apps apps', pos) :: h -> let apps_opt' = match apps_opt with | None -> Some (apps', pos) | Some (_, old_pos) -> Errors.raise_spanned_error (Format.asprintf "application list already declared %a" - Pos.format_position old_pos) + Pos.format old_pos) pos in aux apps_opt' args_opt vars_opt res_opt h - | (Target_input_arg vars', pos) :: h -> + | Pos.Mark (Target_input_arg vars', pos) :: h -> let args_opt = match args_opt with | None -> Some (vars', pos) | Some (_, old_pos) -> Errors.raise_spanned_error - (Format.asprintf "argument list already declared %a" - Pos.format_position old_pos) + (Format.asprintf "argument list already declared %a" Pos.format + old_pos) pos in aux apps_opt args_opt vars_opt res_opt h - | (Target_tmp_vars vars', pos) :: h -> + | Pos.Mark (Target_tmp_vars vars', pos) :: h -> let vars_opt' = match vars_opt with | None -> Some (vars', pos) | Some (_, old_pos) -> Errors.raise_spanned_error (Format.asprintf "temporary variable list already declared %a" - Pos.format_position old_pos) + Pos.format old_pos) pos in aux apps_opt args_opt vars_opt' res_opt h - | (Function_result res', pos) :: h -> + | Pos.Mark (Function_result res', pos) :: h -> if is_function then let res_opt' = match res_opt with @@ -239,7 +248,7 @@ let parse_target_or_function_header name is_function header = | Some (_, old_pos) -> Errors.raise_spanned_error (Format.asprintf "result variable already declared %a" - Pos.format_position old_pos) + Pos.format old_pos) pos in aux apps_opt args_opt vars_opt res_opt' h @@ -249,44 +258,30 @@ let parse_target_or_function_header name is_function header = match apps_opt with | Some (apps, _) -> List.fold_left - (fun res (app, pos) -> + (fun res (Pos.Mark (app, pos)) -> match StrMap.find_opt app res with - | Some (_, old_pos) -> + | Some (Pos.Mark (_, old_pos)) -> let msg = Format.asprintf "application %s already declared %a" app - Pos.format_position old_pos + Pos.format old_pos in Errors.raise_spanned_error msg pos - | None -> StrMap.add app (app, pos) res) + | None -> StrMap.add app (Pos.mark app pos) res) StrMap.empty apps | None -> let ty = if is_function then "function" else "target" in Errors.raise_spanned_error (Format.sprintf "this %s doesn't belong to an application" ty) - (Pos.get_position name) + (Pos.get name) in let args = match args_opt with None -> [] | Some (l, _) -> l in - let vars = - List.fold_left - (fun res (vnm, vt) -> - let vn, pos = vnm in - match StrMap.find_opt vn res with - | Some ((_, old_pos), _) -> - let msg = - Format.asprintf "temporary variable %s already declared %a" - vn Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - | None -> StrMap.add vn (vnm, vt) res) - StrMap.empty - (match vars_opt with None -> [] | Some (l, _) -> l) - in + let vars = match vars_opt with None -> [] | Some (l, _) -> l in let res = match res_opt with | None -> if is_function then Errors.raise_spanned_error "this function doesn't have a result" - (Pos.get_position name) + (Pos.get name) else None | Some (rvar, _) -> Some rvar in diff --git a/src/mlang/m_frontend/parse_utils.mli b/src/mlang/m_frontend/parse_utils.mli index 57c0dc0e5..186ebc546 100644 --- a/src/mlang/m_frontend/parse_utils.mli +++ b/src/mlang/m_frontend/parse_utils.mli @@ -19,12 +19,11 @@ (** {1 Frontend variable names}*) (** A parsed variable can be a regular variable or an integer literal *) -type parse_val = ParseVar of Mast.variable | ParseInt of int +type parse_val = ParseVar of Com.var_name | ParseInt of int val mk_position : Lexing.position * Lexing.position -> Pos.t -val parse_variable : - Lexing.position * Lexing.position -> string -> Mast.variable +val parse_variable : Lexing.position * Lexing.position -> string -> Com.var_name (** Checks whether the variable contains parameters *) val parse_variable_name : Lexing.position * Lexing.position -> string -> string @@ -50,10 +49,12 @@ val parse_int : Lexing.position * Lexing.position -> string -> int val parse_literal : Lexing.position * Lexing.position -> string -> Com.literal val parse_atom : - Lexing.position * Lexing.position -> string -> Mast.variable Com.atom + Lexing.position * Lexing.position -> string -> Com.m_var_name Com.atom val parse_function_name : string Pos.marked -> Com.func Pos.marked +val parse_index_format : string Pos.marked -> string Pos.marked + val parse_if_then_etc : (Mast.expression Pos.marked option * Mast.instruction Pos.marked list * Pos.t) list -> @@ -77,5 +78,5 @@ val parse_target_or_function_header : target_header Pos.marked list -> Mast.application Pos.marked StrMap.t * string Pos.marked list - * (string Pos.marked * Mast.table_size Pos.marked option) StrMap.t + * (string Pos.marked * Mast.table_size Pos.marked option) list * string Pos.marked option diff --git a/src/mlang/m_frontend/validator.ml b/src/mlang/m_frontend/validator.ml new file mode 100644 index 000000000..6b1ea26b8 --- /dev/null +++ b/src/mlang/m_frontend/validator.ml @@ -0,0 +1,2932 @@ +(*This program is free software: you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free Software + Foundation, either version 3 of the License, or (at your option) any later + version. + + This program is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along with + this program. If not, see . *) + +type rule_or_verif = Rule | Verif + +type rdom_or_chain = RuleDomain of Com.DomainId.t | Chaining of string + +module Err = struct + let rov_to_str rov = match rov with Rule -> "rule" | Verif -> "verif" + + let attribute_already_declared attr old_pos pos = + let msg = + Format.asprintf + "attribute \"%s\" declared more than once: already declared %a" attr + Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let var_category_already_definied cat old_pos pos = + let msg = + Format.asprintf + "Category \"%a\" defined more than once: already defined %a" + Com.CatVar.pp cat Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let attribute_already_defined attr old_pos pos = + let msg = + Format.asprintf + "attribute \"%s\" defined more than once: already defined %a" attr + Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let variable_of_unknown_category cat name_pos = + let msg = + Format.asprintf "variable with unknown category %a" Com.CatVar.pp cat + in + Errors.raise_spanned_error msg name_pos + + let attribute_is_not_defined name attr pos = + let msg = + Format.asprintf "variable \"%s\" has no attribute \"%s\"" name attr + in + Errors.raise_spanned_error msg pos + + let alias_already_declared alias old_pos pos = + let msg = + Format.asprintf + "alias \"%s\" declared more than once: already declared %a" alias + Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let variable_already_declared name old_pos pos = + let msg = + Format.asprintf + "variable \"%s\" declared more than once: already declared %a" name + Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let temporary_variable_already_declared name old_pos pos = + let msg = + Format.asprintf + "temporary variable \"%s\" declared more than once: already declared %a" + name Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let error_already_declared name old_pos pos = + let msg = + Format.asprintf + "error \"%s\" declared more than once: already declared %a" name + Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let domain_already_declared rov old_pos pos = + let msg = + Format.asprintf "%s domain declared more than once: already declared %a" + (rov_to_str rov) Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let default_domain_already_declared rov old_pos pos = + let msg = + Format.asprintf + "default %s domain declared more than once: already declared %a" + (rov_to_str rov) Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let no_default_domain rov = + let msg = + Format.asprintf "there are no default %s domain" (rov_to_str rov) + in + Errors.raise_error msg + + let loop_in_domains rov cycle = + let pp_cycle fmt cycle = + let foldCycle first id = + if first then Format.fprintf fmt "%a@;" (Com.DomainId.pp ()) id + else Format.fprintf fmt "-> %a@;" (Com.DomainId.pp ()) id; + false + in + ignore (List.fold_left foldCycle true cycle) + in + let msg = + Format.asprintf "there is a loop in the %s domain hierarchy@;@[%a@]" + (rov_to_str rov) pp_cycle cycle + in + Errors.raise_error msg + + let domain_specialize_itself rov dom_id pos = + let msg = + Format.asprintf "%s domain \"%a\" specialize itself" (rov_to_str rov) + (Com.DomainId.pp ()) dom_id + in + Errors.raise_spanned_error msg pos + + let variable_space_already_declared old_pos pos = + let msg = + Pp.spr "variable space declared more than once: already declared %a" + Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let default_variable_space_already_declared old_pos pos = + let msg = + Pp.spr + "default variable space declared more than once: already declared %a" + Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let no_default_variable_space () = + let msg = Pp.spr "there are no default variable space" in + Errors.raise_error msg + + let target_already_declared name old_pos pos = + let msg = + Format.asprintf + "target \"%s\" declared more than once: already declared %a" name + Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let unknown_variable pos = Errors.raise_spanned_error "unknown variable" pos + + let variable_used_as_table decl_pos pos = + let msg = + Format.asprintf "variable used as a table, declared %a" Pos.format + decl_pos + in + Errors.raise_spanned_error msg pos + + let table_used_as_variable decl_pos pos = + let msg = + Format.asprintf "table used as a variable, declared %a" Pos.format + decl_pos + in + Errors.raise_spanned_error msg pos + + let unknown_attribut_for_var cat pos = + let msg = + Format.asprintf "unknown attribute for a variable of category \"%a\"" + Com.CatVar.pp cat + 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 var_have_no_attrs var pos = + let msg = Pp.spr "variable %s have no attributes" var in + Errors.raise_spanned_error msg pos + + let unknown_variable_category pos = + Errors.raise_spanned_error "unknown_variable_category" pos + + let insruction_forbidden_in_rules pos = + Errors.raise_spanned_error "instruction forbidden in rules" pos + + let unknown_domain rov pos = + let msg = Format.asprintf "unknown %s domain" (rov_to_str rov) in + Errors.raise_spanned_error msg pos + + let unknown_chaining pos = Errors.raise_spanned_error "unknown chaining" pos + + let rule_domain_not_computable pos = + Errors.raise_spanned_error "rule domain not computable" pos + + let verif_domain_not_verifiable pos = + Errors.raise_spanned_error "verif domain not verifiable" pos + + let rov_already_defined rov rov_id old_pos pos = + let msg = + Format.asprintf "%s %d defined more than once: already defined %a" + (rov_to_str rov) rov_id Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let multimax_require_two_args pos = + Errors.raise_spanned_error "function multimax require two arguments" pos + + let second_arg_of_multimax pos = + Errors.raise_spanned_error + "second argument of function multimax must be a variable name" pos + + let loop_in_rules rdom_chain cycle = + let rdom_chain_str = + match rdom_chain with + | RuleDomain rdom_id -> + Format.asprintf "rule domain \"%a\"" (Com.DomainId.pp ()) rdom_id + | Chaining ch -> Format.sprintf "chaining \"%s\"" ch + in + let pp_cycle fmt cycle = + let rec aux first = function + | [] -> () + | (v, Some e) :: tl -> + if first then Format.fprintf fmt "rule %d\n" v + else Format.fprintf fmt " -(%s)-> rule %d\n" e v; + aux false tl + | (v, None) :: tl -> + if first then Format.fprintf fmt "rule %d\n" v + else Format.fprintf fmt " -()-> rule %d\n" v; + aux false tl + in + aux true cycle + in + let msg = + Format.asprintf "there is a loop in rules of %s:\n%a" rdom_chain_str + pp_cycle cycle + in + Errors.raise_error msg + + let rule_domain_incompatible_with_chaining ch_name pos = + let msg = + Format.asprintf "rule domain incompatible with chaining \"%s\"" ch_name + in + Errors.raise_spanned_error msg pos + + let domain_already_used rov dom_pos pos = + let msg = + Format.asprintf "domain of this %s already used %a" (rov_to_str rov) + Pos.format dom_pos + in + Errors.raise_spanned_error msg pos + + let unknown_error pos = Errors.raise_spanned_error "unknown error" pos + + let variable_forbidden_in_filter pos = + Errors.raise_spanned_error "variables are forbidden in verif filters" pos + + let forbidden_expresion_in_filter pos = + Errors.raise_spanned_error "forbidden expression in verif filter" pos + + let expression_only_in_filter pos = + Errors.raise_spanned_error "expression authorized only in verif filters" pos + + let wrong_interval_bounds pos = + Errors.raise_spanned_error "wrong interval bounds" pos + + let wrong_arity_of_function func_name arity pos = + let msg = + Format.asprintf "wrong arity: function \"%a\" expect %d argument%s" + Com.format_func func_name arity + (if arity = 1 then "" else "s") + in + Errors.raise_spanned_error msg pos + + let variable_with_forbidden_category pos = + let msg = Format.sprintf "variable with forbidden category in verif" in + Errors.raise_spanned_error msg pos + + let variable_already_specified name old_pos pos = + let msg = + Format.asprintf + "variable \"%s\" specified more than once: already specified %a" name + Pos.format old_pos + in + Errors.raise_spanned_error msg pos + + let main_target_not_found main_target = + Errors.raise_error + (Format.sprintf "main target \"%s\" not found" main_target) + + let unknown_target name pos = + let msg = Format.asprintf "unknown target %s" name in + Errors.raise_spanned_error msg pos + + let wrong_number_of_args nb_args pos = + let msg = + Format.asprintf "wrong number of arguments, %d required" nb_args + in + Errors.raise_spanned_error msg pos + + let target_must_not_have_a_result tn pos = + let msg = Format.sprintf "target %s must not have a result" tn in + Errors.raise_spanned_error msg pos + + let function_result_missing fn pos = + 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 + in + Errors.raise_spanned_error msg pos + + let function_does_not_exist fn pos = + let msg = Format.sprintf "function %s does not exist" fn in + Errors.raise_spanned_error msg pos + + 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 + 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 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 + + 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 + + let has_no_target () = Errors.raise_error "this program has no target" + + let forbidden_variable_in_raise pos = + let msg = "forbidden variable in leve_erreur" in + Errors.raise_spanned_error msg pos +end + +type syms = Com.DomainId.t Pos.marked Com.DomainIdMap.t + +type 'a doms = 'a Com.domain Com.DomainIdMap.t + +type chaining = { + chain_name : string Pos.marked; + chain_apps : Pos.t StrMap.t; + chain_rules : Com.rule_domain Pos.marked IntMap.t; +} + +type rule = { + rule_id : int Pos.marked; + rule_apps : Pos.t StrMap.t; + rule_domain : Com.rule_domain; + rule_chains : Pos.t StrMap.t; + rule_tmp_vars : int Pos.marked StrMap.t; + rule_instrs : (int Pos.marked, Mast.error_name) Com.m_instruction list; + rule_in_vars : StrSet.t; + rule_out_vars : Pos.t StrMap.t; + rule_seq : int; +} + +type verif = { + verif_id : int Pos.marked; + verif_apps : Pos.t StrMap.t; + verif_domain : Com.verif_domain; + verif_expr : Mast.expression Pos.marked; + verif_error : Mast.error_name Pos.marked; + verif_var : string Pos.marked option; + verif_is_blocking : bool; + verif_cat_var_stats : int Com.CatVar.Map.t; + verif_var_stats : int StrMap.t; + verif_seq : int; +} + +type target = (int Pos.marked, Mast.error_name) Com.target + +type program = { + prog_prefix : string; + prog_seq : int; + prog_app : Pos.t StrMap.t; + prog_apps : Pos.t StrMap.t; + prog_chainings : chaining StrMap.t; + prog_var_cats : Com.CatVar.data Com.CatVar.Map.t; + prog_dict : Com.Var.t IntMap.t; + prog_vars : int StrMap.t; + prog_alias : int StrMap.t; + prog_var_spaces : int StrMap.t; + prog_var_spaces_idx : Com.variable_space IntMap.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; + prog_vdoms : Com.verif_domain_data doms; + prog_vdom_syms : syms; + prog_functions : target StrMap.t; + prog_rules : rule IntMap.t; + prog_rdom_calls : (int Pos.marked * Com.DomainId.t) StrMap.t; + prog_verifs : verif IntMap.t; + prog_vdom_calls : + (int Pos.marked * Com.DomainId.t * Mast.expression Pos.marked) StrMap.t; + prog_targets : target StrMap.t; + prog_main_target : string; +} + +let is_vartmp (var : string) = + String.length var >= 6 && String.sub var 0 6 = "VARTMP" + +let check_name_in_tgv prog m_name = + let vn, vpos = Pos.to_couple m_name in + let err old_pos = Err.variable_already_declared vn old_pos vpos in + match StrMap.find_opt vn prog.prog_vars with + | Some id -> + let var = IntMap.find id prog.prog_dict in + let old_pos = Pos.get @@ Com.Var.name var in + err old_pos + | None -> () + +let check_alias_in_tgv prog m_alias = + let an, apos = Pos.to_couple m_alias in + let err old_pos = Err.alias_already_declared an old_pos apos in + match StrMap.find_opt an prog.prog_alias with + | Some id -> + let var = IntMap.find id prog.prog_dict in + let old_pos = Pos.get @@ Option.get @@ Com.Var.alias var in + err old_pos + | None -> () + +let check_name_in_tmp tmps m_name = + let vn, vpos = Pos.to_couple m_name in + let err old_pos = Err.variable_already_declared vn old_pos vpos in + match StrMap.find_opt vn tmps with + | Some (Pos.Mark (_, old_pos)) -> err old_pos + | None -> () + +let check_name_in_args dict args m_name = + let vn, vpos = Pos.to_couple m_name in + let err old_pos = Err.variable_already_declared vn old_pos vpos in + let find (Pos.Mark (id, _)) = + let var = IntMap.find id dict in + vn = Com.Var.name_str var + in + match List.find_opt find args with + | Some (Pos.Mark (_, old_pos)) -> err old_pos + | None -> () + +let get_target_file (pos : Pos.t) : string = + let file = Pos.get_file pos |> Filename.basename in + let file = + try Filename.chop_extension file with Invalid_argument _ -> file + in + Format.sprintf "m_%s" file + +let safe_prefix (p : Mast.program) : string = + let target_names = + List.fold_left + (fun names source_file -> + List.fold_left + (fun names (Pos.Mark (item, _pos)) -> + match item with + | Mast.Target t -> Pos.unmark t.Mast.target_name :: names + | _ -> names) + names source_file) + [] p + in + let sorted_names = + List.sort + (fun x0 x1 -> + let cmp = compare (String.length x1) (String.length x0) in + if cmp = 0 then compare x0 x1 else cmp) + target_names + in + let buf = Buffer.create 16 in + let rec make_prefix = function + | name :: tl -> + let i = Buffer.length buf in + if i >= String.length name then make_prefix [] + else ( + (if Strings.starts_with ~prefix:(Buffer.contents buf) name then + let c = match name.[i] with 'a' -> 'b' | _ -> 'a' in + Buffer.add_char buf c); + make_prefix tl) + | [] -> Buffer.contents buf + in + make_prefix sorted_names + +let empty_program (p : Mast.program) main_target = + let prog_app = + let fold s a = StrMap.add a Pos.none s in + List.fold_left fold StrMap.empty !Cli.application_names + in + { + prog_prefix = safe_prefix p; + prog_seq = 0; + prog_app; + prog_apps = StrMap.empty; + prog_chainings = StrMap.empty; + prog_var_cats = Com.CatVar.Map.empty; + prog_dict = IntMap.empty; + prog_vars = StrMap.empty; + prog_var_spaces = StrMap.empty; + prog_var_spaces_idx = IntMap.empty; + prog_event_fields = StrMap.empty; + prog_event_field_idxs = IntMap.empty; + prog_event_pos = Pos.none; + prog_alias = StrMap.empty; + prog_errors = StrMap.empty; + prog_rdoms = Com.DomainIdMap.empty; + prog_rdom_syms = Com.DomainIdMap.empty; + prog_vdoms = Com.DomainIdMap.empty; + prog_vdom_syms = Com.DomainIdMap.empty; + prog_functions = StrMap.empty; + prog_rules = IntMap.empty; + prog_rdom_calls = StrMap.empty; + prog_verifs = IntMap.empty; + prog_vdom_calls = StrMap.empty; + prog_targets = StrMap.empty; + prog_main_target = main_target; + } + +let get_seq (prog : program) : int * program = + let seq = prog.prog_seq in + let prog = { prog with prog_seq = seq + 1 } in + (seq, prog) + +let check_application (name : string) (pos : Pos.t) (prog : program) : program = + (* Already checked during preprocessing *) + let prog_apps = StrMap.add name pos prog.prog_apps in + { prog with prog_apps } + +let check_chaining (name : string) (pos : Pos.t) + (m_apps : string Pos.marked list) (prog : program) : program = + (* Already checked during preprocessing *) + let chain_name = Pos.mark name pos in + let chain_apps = + List.fold_left + (fun apps (Pos.Mark (app, app_pos)) -> StrMap.add app app_pos apps) + StrMap.empty m_apps + in + let chain_rules = IntMap.empty in + let chaining = { chain_name; chain_apps; chain_rules } in + let prog_chainings = StrMap.add name chaining prog.prog_chainings in + { prog with prog_chainings } + +let get_var_cat_id_str (var_cat : Com.CatVar.t) : string = + let buf = Buffer.create 100 in + (match var_cat with + | Com.CatVar.Computed { is_base } -> + Buffer.add_string buf "calculee"; + if is_base then Buffer.add_string buf "_base" + | Com.CatVar.Input ss -> + Buffer.add_string buf "saisie"; + let add buf s = + String.iter + (function + | '_' -> Buffer.add_string buf "__" | c -> Buffer.add_char buf c) + s + in + StrSet.iter + (fun s -> + Buffer.add_char buf '_'; + add buf s) + ss); + Buffer.contents buf + +let get_var_cat_loc (var_cat : Com.CatVar.t) : Com.CatVar.loc = + match var_cat with + | Com.CatVar.Computed { is_base } -> + if is_base then Com.CatVar.LocBase else Com.CatVar.LocComputed + | Com.CatVar.Input _ -> Com.CatVar.LocInput + +let get_var_cats (cat_decl : Mast.var_category_decl) : Com.CatVar.t list = + match cat_decl.Mast.var_type with + | Mast.Input -> + let id = StrSet.from_marked_list cat_decl.Mast.var_category in + [ Com.CatVar.Input id ] + | Mast.Computed -> + [ + Com.CatVar.Computed { is_base = false }; + Com.CatVar.Computed { is_base = true }; + ] + +let check_var_category (cat_decl : Mast.var_category_decl) (decl_pos : Pos.t) + (prog : program) : program = + let attributs = + List.fold_left + (fun attributs (Pos.Mark (attr, pos)) -> + match StrMap.find_opt attr attributs with + | None -> StrMap.add attr pos attributs + | Some old_pos -> Err.attribute_already_declared attr old_pos pos) + StrMap.empty cat_decl.Mast.var_attributes + in + let add_cat cats cat = + match Com.CatVar.Map.find_opt cat cats with + | Some Com.CatVar.{ pos; _ } -> + Err.var_category_already_definied cat pos decl_pos + | None -> + let data = + Com.CatVar. + { + id = cat; + id_str = get_var_cat_id_str cat; + id_int = Com.CatVar.Map.cardinal cats; + loc = get_var_cat_loc cat; + attributs; + pos = decl_pos; + } + in + Com.CatVar.Map.add cat data cats + in + let prog_var_cats = + List.fold_left add_cat prog.prog_var_cats (get_var_cats cat_decl) + in + { prog with prog_var_cats } + +let get_attributes (attr_list : Mast.variable_attribute list) : + int Pos.marked StrMap.t = + List.fold_left + (fun attributes (m_attr, m_value) -> + let attr, attr_pos = Pos.to_couple m_attr in + let value = Pos.unmark m_value in + match StrMap.find_opt attr attributes with + | Some (Pos.Mark (_, old_pos)) -> + Err.attribute_already_defined attr old_pos attr_pos + | None -> StrMap.add attr (Pos.mark value attr_pos) attributes) + StrMap.empty attr_list + +let check_global_var (var : Com.Var.t) (prog : program) : program = + let name, name_pos = Pos.to_couple var.name in + let cat = + let cat = Com.Var.cat var in + match Com.CatVar.Map.find_opt cat prog.prog_var_cats with + | None -> Err.variable_of_unknown_category cat name_pos + | Some cat -> cat + in + StrMap.iter + (fun attr _ -> + if not (StrMap.mem attr (Com.Var.attrs var)) then + Err.attribute_is_not_defined name attr name_pos) + cat.attributs; + check_name_in_tgv prog var.name; + let prog_dict = IntMap.add var.id var prog.prog_dict in + let prog_vars = StrMap.add name var.id prog.prog_vars in + let prog_alias = + match Com.Var.alias var with + | Some m_alias -> + check_alias_in_tgv prog m_alias; + StrMap.add (Pos.unmark m_alias) var.id prog.prog_alias + | None -> prog.prog_alias + in + { prog with prog_dict; prog_vars; prog_alias } + +let check_var_decl (var_decl : Mast.variable_decl) (prog : program) : program = + match var_decl with + | Mast.ConstVar _ -> assert false + | Mast.InputVar (Pos.Mark (input_var, _decl_pos)) -> + let global_category = + let input_set = + List.fold_left + (fun res (Pos.Mark (str, _pos)) -> StrSet.add str res) + StrSet.empty input_var.input_category + in + Com.CatVar.Input input_set + in + let var = + Com.Var.new_tgv ~name:input_var.Mast.input_name ~table:None + ~is_given_back:input_var.input_is_givenback + ~alias:(Some input_var.Mast.input_alias) + ~descr:input_var.Mast.input_description + ~attrs:(get_attributes input_var.Mast.input_attributes) + ~cat:global_category + ~typ:(Option.map Pos.unmark input_var.Mast.input_typ) + in + check_global_var var prog + | Mast.ComputedVar (Pos.Mark (comp_var, _decl_pos)) -> + let global_category = + let is_base = + List.fold_left + (fun res (Pos.Mark (str, _pos)) -> + match str with "base" -> true | _ -> res) + false comp_var.comp_category + in + Com.CatVar.Computed { is_base } + in + let m_name = comp_var.Mast.comp_name in + let is_given_back = comp_var.comp_is_givenback in + let alias = None in + let descr = comp_var.Mast.comp_description in + let attrs = get_attributes comp_var.Mast.comp_attributes in + let cat = global_category in + let typ = Option.map Pos.unmark comp_var.Mast.comp_typ in + let var = + Com.Var.new_tgv ~name:m_name ~table:None ~is_given_back ~alias ~descr + ~attrs ~cat ~typ + in + let table = + match comp_var.Mast.comp_table with + | Some (Pos.Mark (Mast.LiteralSize sz, _pos)) -> + let name, name_pos = Pos.to_couple m_name in + let iFmt = String.map (fun _ -> '0') (Pp.spr "%d" sz) in + let init i = + let m_iName = + Pos.mark (Strings.concat_int name iFmt i) name_pos + in + Com.Var.new_tgv ~name:m_iName ~table:None ~is_given_back ~alias + ~descr ~attrs ~cat ~typ + in + Some (Array.init sz init) + | Some _ -> assert false + | None -> None + in + let prog = + match table with + | Some tab -> Array.fold_left (fun p v -> check_global_var v p) prog tab + | None -> prog + in + let var = Com.Var.set_table var table in + check_global_var var prog + +let check_variable_space_decl (vsd : Com.variable_space) (prog : program) : + program = + let name, pos = Pos.to_couple vsd.vs_name in + let vsd, prog_var_spaces_idx = + match StrMap.find_opt name prog.prog_var_spaces with + | Some old_id -> + let old_vsd = IntMap.find old_id prog.prog_var_spaces_idx in + Err.variable_space_already_declared (Pos.get old_vsd.vs_name) pos + | None -> + let vs_id = IntMap.cardinal prog.prog_var_spaces_idx in + let vsd = { vsd with vs_id } in + (vsd, IntMap.add vs_id vsd prog.prog_var_spaces_idx) + in + let prog_var_spaces = + if vsd.vs_by_default then + match StrMap.find_opt "" prog.prog_var_spaces with + | Some old_id -> + let old_vsd = IntMap.find old_id prog.prog_var_spaces_idx in + Err.default_variable_space_already_declared (Pos.get old_vsd.vs_name) + pos + | None -> + prog.prog_var_spaces |> StrMap.add "" vsd.vs_id + |> StrMap.add name vsd.vs_id + else prog.prog_var_spaces |> StrMap.add name vsd.vs_id + in + { prog with prog_var_spaces; prog_var_spaces_idx } + +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 old_ef.name in + let name_pos = Pos.get 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 + let sous_code = List.nth error.error_descr 2 in + let libelle = List.nth error.error_descr 3 in + let is_isf = + match List.nth_opt error.error_descr 4 with + | Some s -> s + | None -> Pos.without "" + in + let err = + Com.Error. + { + name = error.Mast.error_name; + typ = Pos.unmark error.Mast.error_typ; + famille; + code_bo; + sous_code; + is_isf; + libelle; + } + in + let name, name_pos = Pos.to_couple err.name in + match StrMap.find_opt name prog.prog_errors with + | Some old_err -> + let old_pos = Pos.get old_err.name in + Err.error_already_declared name old_pos name_pos + | None -> + let prog_errors = StrMap.add name err prog.prog_errors in + { prog with prog_errors } + +let check_domain (rov : rule_or_verif) (decl : 'a Mast.domain_decl) + (dom_data : 'b) ((doms, syms) : 'b doms * syms) : 'b doms * syms = + let dom_names = + List.fold_left + (fun dom_names (Pos.Mark (sl, sl_pos)) -> + let id = Com.DomainId.from_marked_list sl in + Com.DomainIdMap.add id sl_pos dom_names) + Com.DomainIdMap.empty decl.dom_names + in + let dom_id = + let n, p = Com.DomainIdMap.min_binding dom_names in + Pos.mark n p + in + let domain = + Com. + { + dom_id; + dom_names; + dom_by_default = decl.dom_by_default; + dom_min = DomainIdSet.from_marked_list_list decl.dom_parents; + dom_max = DomainIdSet.empty; + dom_rov = IntSet.empty; + dom_data; + dom_used = None; + } + in + let dom_id_name, dom_id_pos = Pos.to_couple dom_id in + let syms = + Com.DomainIdMap.fold + (fun name name_pos syms -> + match Com.DomainIdMap.find_opt name syms with + | Some (Pos.Mark (_, old_pos)) -> + Err.domain_already_declared rov old_pos name_pos + | None -> + let value = Pos.mark dom_id_name name_pos in + Com.DomainIdMap.add name value syms) + dom_names syms + in + let syms = + if decl.dom_by_default then + match Com.DomainIdMap.find_opt Com.DomainId.empty syms with + | Some (Pos.Mark (_, old_pos)) -> + Err.default_domain_already_declared rov old_pos dom_id_pos + | None -> + let value = Pos.without dom_id_name in + Com.DomainIdMap.add Com.DomainId.empty value syms + else syms + in + let doms = Com.DomainIdMap.add dom_id_name domain doms in + (doms, syms) + +let check_rule_dom_decl (decl : Mast.rule_domain_decl) (prog : program) : + program = + let dom_data = Com.{ rdom_computable = decl.Mast.dom_data.rdom_computable } in + let doms_syms = (prog.prog_rdoms, prog.prog_rdom_syms) in + let doms, syms = check_domain Rule decl dom_data doms_syms in + { prog with prog_rdoms = doms; prog_rdom_syms = syms } + +let mast_to_catvars (cs : Pos.t Com.CatVar.Map.t) + (cats : Com.CatVar.data Com.CatVar.Map.t) : Pos.t Com.CatVar.Map.t = + let filter_cats pred = + Com.CatVar.Map.fold + (fun cv (cvd : Com.CatVar.data) res -> + if pred cv then Com.CatVar.Map.add cv cvd.pos res else res) + cats Com.CatVar.Map.empty + in + let fold cv pos res = + match cv with + | Com.CatVar.Input set when StrSet.mem "*" set -> + filter_cats (function Com.CatVar.Input _ -> true | _ -> false) + |> Com.CatVar.Map.union (fun _ p _ -> Some p) res + | Com.CatVar.Input _ -> + if Com.CatVar.Map.mem cv cats then Com.CatVar.Map.add cv pos res + else Err.unknown_variable_category pos + | _ -> Com.CatVar.Map.add cv pos res + in + Com.CatVar.Map.fold fold cs Com.CatVar.Map.empty + +let check_verif_dom_decl (decl : Mast.verif_domain_decl) (prog : program) : + program = + let vdom_auth = + let rec aux vdom_auth = function + | [] -> vdom_auth + | l :: t -> + let vcats = + mast_to_catvars + (Com.CatVar.Map.from_string_list l) + prog.prog_var_cats + in + aux (Com.CatVar.Map.union (fun _ p _ -> Some p) vcats vdom_auth) t + in + aux Com.CatVar.Map.empty decl.Mast.dom_data.vdom_auth + in + let vdom_verifiable = decl.Mast.dom_data.vdom_verifiable in + let dom_data = Com.{ vdom_auth; vdom_verifiable } in + let doms_syms = (prog.prog_vdoms, prog.prog_vdom_syms) in + let doms, syms = check_domain Verif decl dom_data doms_syms in + { prog with prog_vdoms = doms; prog_vdom_syms = syms } + +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 + let get_dom id doms = Com.DomainIdMap.find (get_id id) doms in + let module DomGraph : + TopologicalSorting.GRAPH + with type 'a t = 'a doms + and type vertex = Com.DomainId.t + and type edge = unit = struct + type 'a t = 'a doms + + type vertex = Com.DomainId.t + + type edge = unit + + type 'a vertexMap = 'a Com.DomainIdMap.t + + let vertexMapEmpty = Com.DomainIdMap.empty + + let vertexMapAdd id value map = Com.DomainIdMap.add (get_id id) value map + + let vertexMapRemove id map = Com.DomainIdMap.remove (get_id id) map + + let vertexMapFindOpt id map = Com.DomainIdMap.find_opt (get_id id) map + + let vertexMapFold fold map res = + Com.DomainIdMap.fold + (fun id edge res -> fold (get_id id) edge res) + map res + + let vertices doms = + let get_vertex id _ nds = Com.DomainIdMap.add id None nds in + Com.DomainIdMap.fold get_vertex doms Com.DomainIdMap.empty + + let edges doms id = + Com.DomainIdSet.fold + (fun id res -> Com.DomainIdMap.add id None res) + (get_dom id doms).Com.dom_min Com.DomainIdMap.empty + end in + let module DomSorting = TopologicalSorting.Make (DomGraph) in + let sorted_doms = + try DomSorting.sort doms with + | DomSorting.Cycle cycle -> Err.loop_in_domains rov (List.map fst cycle) + | DomSorting.AutoCycle (id, _) -> + let dom = get_dom id doms in + let dom_id, dom_id_pos = Pos.to_couple dom.Com.dom_id in + Err.domain_specialize_itself rov dom_id dom_id_pos + in + let doms = + let set_min doms id = + let dom = get_dom id doms in + let dom_min = + let fold parent_id res = + let parent_dom = get_dom parent_id doms in + let parent_id = Pos.unmark parent_dom.Com.dom_id in + let dom_min = Com.DomainIdSet.map get_id parent_dom.Com.dom_min in + Com.DomainIdSet.one parent_id + |> Com.DomainIdSet.union dom_min + |> Com.DomainIdSet.union res + in + Com.DomainIdSet.fold fold dom.Com.dom_min Com.DomainIdSet.empty + in + let dom = Com.{ dom with dom_min } in + Com.DomainIdMap.add id dom doms + in + List.fold_left set_min doms sorted_doms + in + let doms = + let set_max id dom doms = + let fold min_id doms = + let min_dom = Com.DomainIdMap.find min_id doms in + let dom_max = Com.DomainIdSet.add id min_dom.Com.dom_max in + let min_dom = Com.{ min_dom with dom_max } in + Com.DomainIdMap.add min_id min_dom doms + in + Com.DomainIdSet.fold fold dom.Com.dom_min doms + in + Com.DomainIdMap.fold set_max doms doms + in + let doms = + let add_sym name (Pos.Mark (id, _)) doms = + Com.DomainIdMap.add name (get_dom id doms) doms + in + Com.DomainIdMap.fold add_sym syms doms + in + match Com.DomainIdMap.find_opt Com.DomainId.empty doms with + | None -> Err.no_default_domain rov + | Some _ -> doms + +let complete_rdom_decls (prog : program) : program = + let prog_rdoms = + let doms_syms = (prog.prog_rdoms, prog.prog_rdom_syms) in + let prog_rdoms = complete_dom_decls Rule doms_syms in + StrMap.fold + (fun _ (m_seq, rdom_id) prog_rdoms -> + let rdom = Com.DomainIdMap.find rdom_id prog_rdoms in + Com.DomainIdSet.fold + (fun rid prog_rdoms -> + let rd = Com.DomainIdMap.find rid prog_rdoms in + let rd = + match rd.Com.dom_used with + | Some _ -> rd + | None -> { rd with Com.dom_used = Some m_seq } + in + Com.DomainIdMap.add rid rd prog_rdoms) + (Com.DomainIdSet.add rdom_id rdom.Com.dom_min) + prog_rdoms) + prog.prog_rdom_calls prog_rdoms + in + { prog with prog_rdoms } + +let complete_vdom_decls (prog : program) : program = + let prog_vdoms = + let doms_syms = (prog.prog_vdoms, prog.prog_vdom_syms) in + let prog_vdoms = complete_dom_decls Verif doms_syms in + StrMap.fold + (fun _ (m_seq, vdom_id, _) prog_vdoms -> + let vdom = Com.DomainIdMap.find vdom_id prog_vdoms in + Com.DomainIdSet.fold + (fun vid prog_vdoms -> + let vd = Com.DomainIdMap.find vid prog_vdoms in + let vd = + match vd.Com.dom_used with + | Some _ -> vd + | None -> { vd with Com.dom_used = Some m_seq } + in + Com.DomainIdMap.add vid vd prog_vdoms) + (Com.DomainIdSet.add vdom_id vdom.Com.dom_min) + prog_vdoms) + prog.prog_vdom_calls prog_vdoms + in + { prog with prog_vdoms } + +type var_mem_type = Num | Table | Both + +type var_env = { prog : program; vars : int StrMap.t } + +let add_var_env (var : Com.Var.t) env = + let prog_dict = IntMap.add var.id var env.prog.prog_dict in + let prog = { env.prog with prog_dict } in + let vars = StrMap.add (Com.Var.name_str var) var.id env.vars in + { prog; vars } + +let check_name_in_env env m_name = + let name, pos = Pos.to_couple m_name in + match StrMap.find_opt name env.vars with + | Some id -> + let var = IntMap.find id env.prog.prog_dict in + let old_pos = Pos.get @@ Com.Var.name var in + Err.variable_already_declared name old_pos pos + | None -> () + +let rec fold_var_expr (get_var : 'v -> string Pos.marked) + (fold_var : 'v -> var_mem_type -> var_env -> 'a -> 'a) (is_filter : bool) + (acc : 'a) (m_expr : 'v Com.m_expression) (env : var_env) : 'a = + let fold_aux = fold_var_expr get_var fold_var is_filter in + let expr, expr_pos = Pos.to_couple m_expr in + match expr with + | TestInSet (_positive, e, values) -> + let acc = fold_aux acc e env in + List.fold_left + (fun acc set_value -> + match set_value with + | Com.VarValue (Pos.Mark (a, a_pos)) -> ( + if is_filter then Err.forbidden_expresion_in_filter a_pos; + match a with + | VarAccess m_v -> fold_var m_v Num env acc + | TabAccess (m_v, m_i) -> + let acc = fold_aux acc m_i env in + fold_var m_v Table env acc + | ConcAccess (_m_v, _m_if, i) -> fold_aux acc i env + | FieldAccess (ie, f, _) -> + let f_name, f_pos = Pos.to_couple 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_aux acc ie env) + | Com.FloatValue _ -> acc + | Com.IntervalValue (bn, en) -> + if Pos.unmark bn > Pos.unmark en then + Err.wrong_interval_bounds (Pos.get bn); + acc) + acc values + | Comparison (_op, e1, e2) -> + let acc = fold_aux acc e1 env in + fold_aux acc e2 env + | Binop (_op, e1, e2) -> + let acc = fold_aux acc e1 env in + fold_aux acc e2 env + | Unop (_op, e) -> fold_aux acc e env + | Conditional (e1, e2, e3_opt) -> ( + let acc = fold_aux acc e1 env in + let acc = fold_aux acc e2 env in + match e3_opt with Some e3 -> fold_aux acc e3 env | None -> acc) + | FuncCall (Pos.Mark (func_name, fpos), args) -> ( + let check_func arity = + if arity > -1 && List.length args <> arity then + Err.wrong_arity_of_function func_name arity expr_pos; + List.fold_left (fun acc e -> fold_aux acc e env) acc args + in + match func_name with + | Com.Multimax -> ( + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + match args with + | [ expr; var_expr ] -> ( + let acc = fold_aux acc expr env in + match var_expr with + | Pos.Mark (Var (VarAccess m_v), _) -> fold_var m_v Table env acc + | _ -> Err.second_arg_of_multimax (Pos.get var_expr)) + | _ -> Err.multimax_require_two_args expr_pos) + | Com.SumFunc -> check_func (-1) + | Com.VerifNumber -> check_func 0 + | Com.ComplNumber -> check_func 0 + | Com.AbsFunc -> check_func 1 + | Com.MinFunc -> check_func 2 + | Com.MaxFunc -> check_func 2 + | Com.GtzFunc -> check_func 1 + | Com.GtezFunc -> check_func 1 + | Com.NullFunc -> check_func 1 + | Com.ArrFunc -> check_func 1 + | Com.InfFunc -> check_func 1 + | Com.Supzero -> check_func 1 + | 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 = + match StrMap.find_opt fn env.prog.prog_functions with + | Some fd -> fd + | None -> Err.function_does_not_exist fn fpos + in + check_func (List.length fd.target_args)) + | Literal _ -> acc + | Var access -> ( + if is_filter then Err.variable_forbidden_in_filter expr_pos; + match access with + | VarAccess m_v -> fold_var m_v Num env acc + | TabAccess (m_v, m_i) -> + let acc = fold_aux acc m_i env in + fold_var m_v Table env acc + | ConcAccess (_, _, i) -> fold_aux acc i env + | FieldAccess (e, f, _) -> ( + match StrMap.find_opt (Pos.unmark f) env.prog.prog_event_fields with + | Some _ -> fold_aux acc e env + | None -> Err.unknown_event_field (Pos.unmark f) (Pos.get 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 + Com.CatVar.Map.iter + (fun cat pos -> + if not (Com.CatVar.Map.mem cat env.prog.prog_var_cats) then + Err.unknown_domain Verif pos) + cats; + acc + | Attribut (Pos.Mark (access, _pos), a) -> ( + match access with + | VarAccess m_v -> + let name, var_pos = Pos.to_couple @@ get_var m_v in + (match StrMap.find_opt name env.vars with + | Some id -> + let var = IntMap.find id env.prog.prog_dict in + if Com.Var.is_tgv var then ( + let cat = Com.Var.cat var in + if not (StrMap.mem (Pos.unmark a) (Com.Var.attrs var)) then + Err.unknown_attribut_for_var cat (Pos.get a)) + else if Com.Var.is_temp var then + Err.var_have_no_attrs (Com.Var.name_str var) var_pos + | None -> Err.unknown_variable var_pos); + fold_var m_v Both env acc + | TabAccess (m_v, m_i) -> + let name, var_pos = Pos.to_couple @@ get_var m_v in + (match StrMap.find_opt name env.vars with + | Some id -> + let var = IntMap.find id env.prog.prog_dict in + if Com.Var.is_tgv var then ( + let cat = Com.Var.cat var in + if not (StrMap.mem (Pos.unmark a) (Com.Var.attrs var)) then + Err.unknown_attribut_for_var cat (Pos.get a)) + else if Com.Var.is_temp var then + Err.var_have_no_attrs (Com.Var.name_str var) var_pos + else if Com.Var.is_ref var then + Err.variable_used_as_table (Pos.get @@ Com.Var.name var) var_pos + | None -> Err.unknown_variable var_pos); + let acc = fold_aux acc m_i env in + fold_var m_v Table env acc + | ConcAccess (_, _, i) -> + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + fold_aux acc i env + | FieldAccess (e, f, _) -> + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + let f_name, f_pos = Pos.to_couple 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 a) + | Some _ -> Err.event_field_is_not_a_reference f_name f_pos + | None -> Err.unknown_event_field f_name f_pos); + fold_aux acc e env) + | Size (Pos.Mark (access, _)) | IsVariable (Pos.Mark (access, _), _) -> ( + match access with + | VarAccess m_v -> fold_var m_v Both env acc + | TabAccess (m_v, m_i) -> + let acc = fold_aux acc m_i env in + fold_var m_v Table env acc + | ConcAccess (_, _, i) -> + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + fold_aux acc i env + | FieldAccess (e, f, _) -> + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + let f_name, f_pos = Pos.to_couple 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_aux acc e env) + | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes -> + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + acc + | FuncCallLoop _ | Loop _ -> assert false + +let get_var_mem_type (var : Com.m_var_name) (env : var_env) : + var_mem_type Pos.marked = + let var_data, var_pos = Pos.to_couple var in + let vn = Com.get_normal_var var_data in + let to_mem is_t = match is_t with Some _ -> Table | None -> Num in + match StrMap.find_opt vn env.vars with + | Some id -> + let var = IntMap.find id env.prog.prog_dict in + let mem = + if Com.Var.is_ref var then Num else to_mem (Com.Var.get_table var) + in + Pos.same mem (Com.Var.name var) + | None -> Err.unknown_variable var_pos + +let check_variable (var : Com.m_var_name) (idx_mem : var_mem_type) + (env : var_env) : unit = + let decl_mem, decl_pos = Pos.to_couple @@ get_var_mem_type var env in + match (decl_mem, idx_mem) with + | _, Both | Num, Num | Table, Table -> () + | Both, _ -> assert false + (* | Both, Num -> Err.mixed_variable_used_as_num decl_pos (Pos.get var) + | Both, Table -> Err.mixed_variable_used_as_table decl_pos (Pos.get var)*) + | Num, Table -> Err.variable_used_as_table decl_pos (Pos.get var) + | Table, Num -> Err.table_used_as_variable decl_pos (Pos.get var) + +let check_expression (is_filter : bool) (env : var_env) + (m_expr : Mast.m_expression) : unit = + let get_var m_v = Pos.same (Com.get_normal_var @@ Pos.unmark m_v) m_v in + let fold_var var idx_mem env _acc = check_variable var idx_mem env in + fold_var_expr get_var fold_var is_filter () m_expr env + +let get_compute_id_str (instr : Mast.instruction) (prog : program) : string = + let buf = Buffer.create 100 in + Buffer.add_string buf prog.prog_prefix; + let add_sml buf sml = + let id = Com.DomainId.from_marked_list (Pos.unmark sml) in + let add s = + String.iter + (function + | '_' -> Buffer.add_string buf "__" | c -> Buffer.add_char buf c) + s + in + Com.DomainId.iter + (fun s -> + Buffer.add_char buf '_'; + add s) + id; + id + in + (match instr with + | Com.ComputeDomain l -> ( + Buffer.add_string buf "_rules"; + let id = add_sml buf l in + match Com.DomainIdMap.find_opt id prog.prog_rdom_syms with + | Some (Pos.Mark (dom_id, _)) -> + let rdom = Com.DomainIdMap.find dom_id prog.prog_rdoms in + if not rdom.Com.dom_data.rdom_computable then + Err.rule_domain_not_computable (Pos.get l) + | None -> Err.unknown_domain Rule (Pos.get l)) + | Com.ComputeChaining (Pos.Mark (ch_name, ch_pos)) -> ( + Buffer.add_string buf "_chaining_"; + Buffer.add_string buf ch_name; + match StrMap.find_opt ch_name prog.prog_chainings with + | Some _ -> () + | None -> Err.unknown_chaining ch_pos) + | Com.ComputeVerifs (l, _) -> ( + Buffer.add_string buf "_verifs"; + let id = add_sml buf l in + Buffer.add_char buf '_'; + let cpt = StrMap.cardinal prog.prog_vdom_calls in + Buffer.add_string buf (Format.sprintf "%d" cpt); + match Com.DomainIdMap.find_opt id prog.prog_vdom_syms with + | Some (Pos.Mark (dom_id, _)) -> + let vdom = Com.DomainIdMap.find dom_id prog.prog_vdoms in + if not vdom.Com.dom_data.vdom_verifiable then + Err.verif_domain_not_verifiable (Pos.get l) + | None -> Err.unknown_domain Verif (Pos.get l)) + | _ -> assert false); + Buffer.contents buf + +let cats_variable_from_decl_list (l : Mast.var_category_id list) + (cats : Com.CatVar.data Com.CatVar.Map.t) : Pos.t Com.CatVar.Map.t = + let rec aux res = function + | [] -> res + | l :: t -> + let vcats = mast_to_catvars (Com.CatVar.Map.from_string_list l) cats in + aux (Com.CatVar.Map.union (fun _ p _ -> Some p) vcats res) t + in + aux Com.CatVar.Map.empty l + +let rec check_instructions (is_rule : bool) (env : var_env) + (instrs : Mast.instruction Pos.marked list) : + program * (int Pos.marked, Mast.error_name) Com.m_instruction list = + let map_var env m_v = + let name = Com.get_normal_var (Pos.unmark m_v) in + let id = StrMap.find name env.vars in + Pos.same id m_v + in + let map_expr env m_expr = + check_expression false env m_expr; + Com.m_expr_map_var (map_var env) m_expr + in + let check_it_var env var = + let m_name = Pos.same (Com.get_normal_var (Pos.unmark var)) var in + check_name_in_env env m_name; + m_name + in + let check_aux = check_instructions is_rule in + let rec aux + ((env, res) : + var_env * (int Pos.marked, Mast.error_name) Com.m_instruction list) + (m_instr_list : Mast.instruction Pos.marked list) : + var_env * (int Pos.marked, Mast.error_name) Com.m_instruction list = + match m_instr_list with + | [] -> (env, List.rev res) + | m_instr :: il -> ( + let instr, instr_pos = Pos.to_couple m_instr in + match instr with + | Com.Affectation (Pos.Mark (f, fpos)) -> ( + match f with + | Com.SingleFormula (VarDecl (m_a, e)) -> + let m_a' = + let access, apos = Pos.to_couple m_a in + match access with + | VarAccess m_v -> + check_variable m_v Num env; + let m_v' = map_var env m_v in + Pos.mark (Com.VarAccess m_v') apos + | TabAccess (m_v, m_i) -> + check_variable m_v Table env; + let m_v' = map_var env m_v in + let m_i' = map_expr env m_i in + Pos.mark (Com.TabAccess (m_v', m_i')) apos + | ConcAccess (m_vn, iFmt, m_i) -> + if is_rule then + Err.insruction_forbidden_in_rules instr_pos; + let m_i' = map_expr env m_i in + Pos.mark (Com.ConcAccess (m_vn, iFmt, m_i')) apos + | FieldAccess (m_i, f, id) -> + if is_rule then + Err.insruction_forbidden_in_rules instr_pos; + let f_name, f_pos = Pos.to_couple 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 m_i' = map_expr env m_i in + Pos.mark (Com.FieldAccess (m_i', f, id)) apos + in + let e' = map_expr env e in + let f' = Com.SingleFormula (VarDecl (m_a', e')) in + let instr' = Com.Affectation (Pos.mark f' fpos) in + aux (env, Pos.mark instr' instr_pos :: res) il + | Com.SingleFormula (EventFieldRef (m_i, f, iFmt, m_v)) -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + let f_name, f_pos = Pos.to_couple 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 m_i' = map_expr env m_i in + check_variable m_v Num env; + let m_v' = map_var env m_v in + let f' = + Com.SingleFormula (EventFieldRef (m_i', f, iFmt, m_v')) + in + let instr' = Com.Affectation (Pos.mark f' fpos) in + aux (env, Pos.mark instr' instr_pos :: res) il + | Com.MultipleFormulaes _ -> assert false) + | Com.IfThenElse (expr, i_then, i_else) -> + let expr' = map_expr env expr in + let prog, res_then = check_aux env i_then in + let env = { env with prog } in + let prog, res_else = check_aux env i_else in + let env = { env with prog } in + let res_instr = Com.IfThenElse (expr', res_then, res_else) in + aux (env, Pos.mark res_instr instr_pos :: res) il + | Com.WhenDoElse (wdl, ed) -> + let rec wde (env, res) = function + | (expr, dl, pos) :: l -> + let expr' = map_expr env expr in + let prog, res_do = check_aux env dl in + let env = { env with prog } in + let res = (expr', res_do, pos) :: res in + wde (env, res) l + | [] -> + let prog, res_ed = check_aux env (Pos.unmark ed) in + let env = { env with prog } in + let ed' = Pos.same res_ed ed in + let res = Com.WhenDoElse (List.rev res, ed') in + (env, res) + in + let env, wde_res = wde (env, []) wdl in + aux (env, Pos.mark wde_res instr_pos :: res) il + | Com.ComputeDomain (Pos.Mark (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 + let rdom_id = + let id = Com.DomainId.from_marked_list rdom_list in + Pos.unmark (Com.DomainIdMap.find id env.prog.prog_rdom_syms) + in + let seq, prog = get_seq env.prog in + let prog_rdom_calls = + let used_data = (Pos.mark seq rdom_pos, rdom_id) in + StrMap.add tname used_data prog.prog_rdom_calls + in + let prog = { prog with prog_rdom_calls } in + let env = { env with prog } in + let res_instr = Com.ComputeTarget (Pos.without tname, []) in + aux (env, Pos.mark res_instr instr_pos :: res) 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 (Pos.without tname, []) in + aux (env, Pos.mark res_instr instr_pos :: res) il + | Com.ComputeVerifs (Pos.Mark (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 + let vdom_id = + let id = Com.DomainId.from_marked_list vdom_list in + Pos.unmark (Com.DomainIdMap.find id env.prog.prog_vdom_syms) + in + let seq, prog = get_seq env.prog in + check_expression true env expr; + let prog_vdom_calls = + let used_data = (Pos.mark seq vdom_pos, vdom_id, expr) in + StrMap.add tname used_data prog.prog_vdom_calls + in + let prog = { prog with prog_vdom_calls } in + let env = { env with prog } in + let res_instr = Com.ComputeTarget (Pos.without tname, []) in + aux (env, Pos.mark res_instr instr_pos :: res) il + | Com.VerifBlock instrs -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + let prog, res_instrs = check_aux env instrs in + let env = { env with prog } in + let res_instr = Com.VerifBlock res_instrs in + aux (env, Pos.mark res_instr instr_pos :: res) il + | Com.ComputeTarget (Pos.Mark (tn, tpos), targs) -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + (match StrMap.find_opt tn env.prog.prog_targets with + | None -> Err.unknown_target tn tpos + | Some target -> + let nb_args = List.length target.target_args in + if List.length targs <> nb_args then + Err.wrong_number_of_args nb_args tpos); + let targs' = + let map v = + check_variable v Num env; + map_var env v + in + List.map map targs + in + let instr' = Com.ComputeTarget (Pos.mark tn tpos, targs') in + aux (env, Pos.mark instr' instr_pos :: res) il + | Com.Print (std, args) -> + let args' = + List.map + (fun m_arg -> + let arg, arg_pos = Pos.to_couple m_arg in + let arg' = + match arg with + | Com.PrintString s -> Com.PrintString s + | Com.PrintAccess (info, m_a) -> + let a' = + match Pos.unmark m_a with + | Com.VarAccess v -> + check_variable v Both env; + Com.VarAccess (map_var env v) + | Com.TabAccess (m_v, m_i) -> + check_variable m_v Table env; + let m_v' = map_var env m_v in + let m_i' = map_expr env m_i in + Com.TabAccess (m_v', m_i') + | Com.ConcAccess (m_vn, m_if, m_i) -> + let m_i' = map_expr env m_i in + Com.ConcAccess (m_vn, m_if, m_i') + | Com.FieldAccess (e, f, id) -> ( + let f_name, f_pos = Pos.to_couple f in + match + StrMap.find_opt f_name + env.prog.prog_event_fields + with + | Some ef when ef.is_var -> + let e' = map_expr env e in + Com.FieldAccess (e', f, id) + | Some _ -> + Err.event_field_is_not_a_reference f_name + f_pos + | None -> Err.unknown_event_field f_name f_pos) + in + Com.PrintAccess (info, Pos.same a' m_a) + | Com.PrintIndent e -> + let e' = map_expr env e in + Com.PrintIndent e' + | Com.PrintExpr (e, min, max) -> + let e' = map_expr env e in + Com.PrintExpr (e', min, max) + in + Pos.mark arg' arg_pos) + args + in + let instr' = Com.Print (std, args') in + aux (env, Pos.mark instr' instr_pos :: res) il + | Com.Iterate (var, vars, var_params, instrs) -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + let m_name = check_it_var env var in + let env' = + let v = Com.Var.new_ref ~name:m_name in + add_var_env v env + in + let var' = map_var env' var in + let vars' = + let fold (vars', seen) var = + let var_pos = Pos.get var in + let var_name = Com.get_normal_var (Pos.unmark var) in + check_variable var Num env; + match StrMap.find_opt var_name seen with + | None -> + let vars' = map_var env var :: vars' in + let seen = StrMap.add var_name var_pos seen in + (vars', seen) + | Some old_pos -> + Err.variable_already_specified var_name old_pos var_pos + in + List.rev @@ fst @@ List.fold_left fold ([], StrMap.empty) vars + in + let var_params' = + List.map + (fun (vcats, expr) -> + ignore (mast_to_catvars vcats env.prog.prog_var_cats); + (vcats, map_expr env' expr)) + var_params + in + let prog, instrs' = check_aux env' instrs in + let env = { env with prog } in + let instr' = Com.Iterate (var', vars', var_params', instrs') in + aux (env, Pos.mark instr' instr_pos :: res) il + | Com.Iterate_values (var, var_intervals, instrs) -> + let m_name = check_it_var env var in + let env' = + let v = Com.Var.new_temp ~name:m_name ~table:None in + add_var_env v env + in + let var' = map_var env' var in + let var_intervals' = + List.map + (fun (e0, e1, step) -> + let e0' = map_expr env e0 in + let e1' = map_expr env e1 in + let step' = map_expr env step in + (e0', e1', step')) + var_intervals + in + let prog, instrs' = check_aux env' instrs in + let env = { env with prog } in + let instr' = Com.Iterate_values (var', var_intervals', instrs') in + aux (env, Pos.mark instr' instr_pos :: res) il + | Com.Restore (vars, var_params, evts, evtfs, instrs) -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + let vars' = + let fold (vars', seen) var = + let var_pos = Pos.get var in + let var_name = Com.get_normal_var (Pos.unmark var) in + check_variable var Both env; + match StrMap.find_opt var_name seen with + | None -> + let vars' = map_var env var :: vars' in + let seen = StrMap.add var_name var_pos seen in + (vars', seen) + | Some old_pos -> + Err.variable_already_specified var_name old_pos var_pos + in + List.rev @@ fst @@ List.fold_left fold ([], StrMap.empty) vars + in + let env, var_params' = + let fold (env, var_params') (var, vcats, expr) = + let m_name = check_it_var env var in + ignore (mast_to_catvars vcats env.prog.prog_var_cats); + let env' = + let v = Com.Var.new_ref ~name:m_name in + add_var_env v env + in + let var' = map_var env' var in + let expr' = map_expr env' expr in + let env = { env with prog = env'.prog } in + let var_params' = (var', vcats, expr') :: var_params' in + (env, var_params') + in + let env, var_params' = List.fold_left fold (env, []) var_params in + (env, List.rev var_params') + in + let evts' = List.map (map_expr env) evts in + let env, evtfs' = + let fold (env, evtfs') (var, expr) = + let m_name = check_it_var env var in + let env' = + let v = Com.Var.new_temp ~name:m_name ~table:None in + add_var_env v env + in + let var' = map_var env' var in + let expr' = map_expr env' expr in + let env = { env with prog = env'.prog } in + let evtfs' = (var', expr') :: evtfs' in + (env, evtfs') + in + let env, evtfs' = List.fold_left fold (env, []) evtfs in + (env, List.rev evtfs') + in + let prog, instrs' = check_aux env instrs in + let env = { env with prog } in + let instr' = + Com.Restore (vars', var_params', evts', evtfs', instrs') + in + aux (env, Pos.mark instr' instr_pos :: res) il + | Com.ArrangeEvents (sort, filter, add, instrs) -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + let env, sort' = + match sort with + | Some (var0, var1, expr) -> + let m_name0 = check_it_var env var0 in + let m_name1 = check_it_var env var1 in + + let env' = + let v0 = Com.Var.new_temp ~name:m_name0 ~table:None in + let v1 = Com.Var.new_temp ~name:m_name1 ~table:None in + env |> add_var_env v0 |> add_var_env v1 + in + let var0' = map_var env' var0 in + let var1' = map_var env' var1 in + let expr' = map_expr env' expr in + let env = { env with prog = env'.prog } in + (env, Some (var0', var1', expr')) + | None -> (env, None) + in + let env, filter' = + match filter with + | Some (var, expr) -> + let m_name = check_it_var env var in + let env' = + let v = Com.Var.new_temp ~name:m_name ~table:None in + add_var_env v env + in + let var' = map_var env' var in + let expr' = map_expr env' expr in + let env = { env with prog = env'.prog } in + (env, Some (var', expr')) + | None -> (env, None) + in + let add' = Option.map (map_expr env) add in + let prog, instrs' = check_aux env instrs in + let env = { env with prog } in + let instr' = Com.ArrangeEvents (sort', filter', add', instrs') in + aux (env, Pos.mark instr' instr_pos :: res) il + | Com.RaiseError (m_err, m_var_opt) -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + let err_name, err_pos = Pos.to_couple m_err in + (match StrMap.find_opt err_name env.prog.prog_errors with + | None -> Err.unknown_error err_pos + | Some _ -> ()); + (match m_var_opt with + | Some m_var -> ( + let var_name, var_pos = Pos.to_couple m_var in + match StrMap.find_opt var_name env.vars with + | Some id -> + let var = IntMap.find id env.prog.prog_dict in + if not (Com.Var.is_tgv var || Com.Var.is_ref var) then + Err.forbidden_variable_in_raise var_pos + | None -> Err.unknown_variable var_pos) + | None -> ()); + let instr' = Com.RaiseError (m_err, m_var_opt) in + aux (env, Pos.mark instr' instr_pos :: res) il + | Com.CleanErrors -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + aux (env, Pos.mark Com.CleanErrors instr_pos :: res) il + | Com.ExportErrors -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + aux (env, Pos.mark Com.ExportErrors instr_pos :: res) il + | Com.FinalizeErrors -> + if is_rule then Err.insruction_forbidden_in_rules instr_pos; + aux (env, Pos.mark Com.FinalizeErrors instr_pos :: res) il) + in + let env, res = aux (env, []) instrs in + (env.prog, res) + +let inout_expression (prog : program) (m_expr : int Pos.marked Com.m_expression) + : Pos.t StrMap.t = + let get_var m_id = + let var = IntMap.find (Pos.unmark m_id) prog.prog_dict in + Pos.same (Com.Var.name_str var) m_id + in + let fold_var m_id _idx_mem _env acc = + let name, pos = Pos.to_couple @@ get_var m_id in + StrMap.union_snd (StrMap.one name pos) acc + in + let env = { prog; vars = StrMap.empty } in + fold_var_expr get_var fold_var false StrMap.empty m_expr env + +let rec inout_instrs (prog : program) (tmps : Pos.t StrMap.t) + (instrs : (int Pos.marked, Mast.error_name) Com.m_instruction list) : + Pos.t StrMap.t * Pos.t StrMap.t * Pos.t list StrMap.t = + let diff_map m0 m1 = + let filter vn _ = not (StrMap.mem vn m1) in + StrMap.filter filter m0 + 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 (tmps, in_vars, out_vars, def_vars) = function + | [] -> (tmps, in_vars, out_vars, def_vars) + | m_instr :: il -> ( + let instr, instr_pos = Pos.to_couple m_instr in + match instr with + | Com.Affectation (Pos.Mark (f, _)) -> ( + match f with + | Com.SingleFormula (VarDecl (m_access, e)) -> ( + let access, access_pos = Pos.to_couple m_access in + let in_vars_aff = inout_expression prog e in + match access with + | VarAccess m_id -> + let m_v = + let var = IntMap.find (Pos.unmark m_id) prog.prog_dict in + Pos.same (Com.Var.name_str var) m_id + in + let out_vars_lvalue = + StrMap.one (Pos.unmark m_v) (Pos.get m_v) + in + let in_vars = + StrMap.union_fst in_vars (diff_map in_vars_aff out_vars) + in + let out_vars = StrMap.union_snd out_vars_lvalue out_vars in + let def_vars = + let vn = Pos.unmark m_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 + aux (tmps, in_vars, out_vars, def_vars) il + | TabAccess (m_id, m_i) -> + let m_v = + let var = IntMap.find (Pos.unmark m_id) prog.prog_dict in + Pos.same (Com.Var.name_str var) m_id + in + let out_vars_lvalue = + StrMap.one (Pos.unmark m_v) (Pos.get m_v) + in + let in_vars_i = inout_expression prog m_i in + let in_vars_aff = StrMap.union_fst in_vars_i in_vars_aff in + let in_vars = + StrMap.union_fst in_vars (diff_map in_vars_aff out_vars) + in + let out_vars = StrMap.union_fst out_vars_lvalue out_vars in + let def_vars = + let vn = Pos.unmark m_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 + aux (tmps, in_vars, out_vars, def_vars) il + | ConcAccess _ | FieldAccess _ -> + Err.insruction_forbidden_in_rules instr_pos) + | Com.SingleFormula (EventFieldRef _) -> + Err.insruction_forbidden_in_rules instr_pos + | Com.MultipleFormulaes _ -> assert false) + | Com.IfThenElse (expr, i_then, i_else) -> + let in_expr = inout_expression prog expr in + let in_then, out_then, def_then = inout_instrs prog tmps i_then in + let in_else, out_else, def_else = inout_instrs prog tmps i_else in + let in_vars = + in_vars |> StrMap.union_snd in_expr |> StrMap.union_snd in_then + |> StrMap.union_snd in_else + in + let out_vars = + out_vars |> StrMap.union_snd out_then |> StrMap.union_snd out_else + in + let def_vars = + merge_seq_defs def_vars (merge_par_defs def_then def_else) + in + aux (tmps, in_vars, out_vars, def_vars) il + | Com.WhenDoElse (wdl, ed) -> + let rec wde (in_vars, out_vars, def_vars) = function + | (expr, dl, _pos) :: l -> + let in_expr = inout_expression prog expr in + let in_do, out_do, def_do = inout_instrs prog tmps dl in + let in_vars = + in_vars |> StrMap.union_snd in_expr + |> StrMap.union_snd in_do + in + let out_vars = out_vars |> StrMap.union_snd out_do in + let def_vars = merge_par_defs def_vars def_do in + wde (in_vars, out_vars, def_vars) l + | [] -> + let in_ed, out_ed, def_ed = + inout_instrs prog tmps (Pos.unmark ed) + in + let in_vars = in_vars |> StrMap.union_snd in_ed in + let out_vars = out_vars |> StrMap.union_snd out_ed in + let def_vars = merge_par_defs def_vars def_ed in + (in_vars, out_vars, def_vars) + in + let in_vars, out_vars, def_vars_wde = + wde (in_vars, out_vars, StrMap.empty) wdl + in + let def_vars = merge_seq_defs def_vars def_vars_wde in + aux (tmps, in_vars, out_vars, def_vars) il + | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ + | Com.VerifBlock _ | Com.ComputeTarget _ -> + Err.insruction_forbidden_in_rules instr_pos + | Com.Print _ -> aux (tmps, in_vars, out_vars, def_vars) il + | Com.Iterate _ -> Err.insruction_forbidden_in_rules instr_pos + | Com.Iterate_values (m_id, var_intervals, instrs) -> + let var_name, var_pos = + let var = IntMap.find (Pos.unmark m_id) prog.prog_dict in + (Com.Var.name_str var, Pos.get m_id) + in + let tmps' = StrMap.add var_name var_pos tmps in + let in_exprs = + List.fold_left + (fun in_exprs (e0, e1, step) -> + in_exprs + |> StrMap.union_snd (inout_expression prog e0) + |> StrMap.union_snd (inout_expression prog e1) + |> StrMap.union_snd (inout_expression prog step)) + StrMap.empty var_intervals + in + let in_instrs, out_instrs, def_instrs = + inout_instrs prog tmps' instrs + in + let in_vars = + in_vars + |> StrMap.union_snd + (in_exprs |> StrMap.union_snd in_instrs + |> StrMap.remove var_name) + in + let out_vars = + out_vars |> StrMap.union_snd (out_instrs |> StrMap.remove var_name) + in + let def_vars = merge_seq_defs def_vars def_instrs in + aux (tmps', in_vars, out_vars, def_vars) il + | Com.Restore _ -> Err.insruction_forbidden_in_rules instr_pos + | Com.ArrangeEvents _ -> Err.insruction_forbidden_in_rules instr_pos + | Com.RaiseError _ -> Err.insruction_forbidden_in_rules instr_pos + | Com.CleanErrors | Com.ExportErrors | Com.FinalizeErrors -> + Err.insruction_forbidden_in_rules instr_pos) + in + let tmps', in_vars, out_vars, def_vars = + aux (tmps, StrMap.empty, StrMap.empty, StrMap.empty) instrs + in + 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 in_vars = diff_map in_vars tmps' in + let out_vars = diff_map out_vars tmps' in + let def_vars = diff_map def_vars tmps' in + (in_vars, out_vars, def_vars) + +let check_code (is_rule : bool) (is_function : bool) + (m_tname : string Pos.marked) (prog : program) tmp_vars args result instrs = + let tname, tpos = Pos.to_couple m_tname in + let env = { prog; vars = prog.prog_vars } in + let tmp_vars', env = + let vars, env = + List.fold_left + (fun (vars, env) ((Pos.Mark (vn, vpos) as m_v), sz) -> + let check_tmp vars (Pos.Mark (vn, vpos)) = + let err old_pos = + Err.temporary_variable_already_declared vn old_pos vpos + in + match StrMap.find_opt vn vars with + | Some (Pos.Mark (_, old_pos)) -> err old_pos + | None -> () + in + check_name_in_tgv prog m_v; + check_tmp vars m_v; + let size = Option.map Pos.unmark (Mast.get_table_size_opt sz) in + match size with + | None -> + let var = Com.Var.new_temp ~name:m_v ~table:None in + (StrMap.add vn (Pos.mark var.id vpos) vars, add_var_env var env) + | Some sz_int -> + let iFmt = String.map (fun _ -> '0') (Pp.spr "%d" sz_int) in + let rec loop (vars, env) i = + if i >= sz_int then (vars, env) + else + let iName = Strings.concat_int vn iFmt i in + let m_iName = Pos.mark iName vpos in + check_tmp vars m_iName; + let var = Com.Var.new_temp ~name:m_iName ~table:None in + let vars = StrMap.add iName (Pos.mark var.id vpos) vars in + let env = add_var_env var env in + loop (vars, env) (i + 1) + in + loop (vars, env) 0) + (StrMap.empty, env) tmp_vars + in + List.fold_left + (fun (vars, env) ((Pos.Mark (vn, vpos) as m_v), sz) -> + let size = Option.map Pos.unmark (Mast.get_table_size_opt sz) in + match size with + | None -> (vars, env) + | Some sz_int -> + let table = + let iFmt = String.map (fun _ -> '0') (Pp.spr "%d" sz_int) in + let init i = + let iName = Strings.concat_int vn iFmt i in + let iId = Pos.unmark @@ StrMap.find iName vars in + IntMap.find iId env.prog.prog_dict + in + Some (Array.init sz_int init) + in + let var = Com.Var.new_temp ~name:m_v ~table in + (StrMap.add vn (Pos.mark var.id vpos) vars, add_var_env var env)) + (vars, env) tmp_vars + in + let args', env = + if is_rule then ([], env) + else + let fold (args, env) m_v = + check_name_in_tgv prog m_v; + check_name_in_tmp tmp_vars' m_v; + let var = + if is_function then Com.Var.new_arg ~name:m_v + else Com.Var.new_ref ~name:m_v + in + (Pos.same var.id m_v :: args, add_var_env var env) + in + let args', env = List.fold_left fold ([], env) args in + (List.rev args', env) + in + let result', env = + if is_rule then (None, env) + else + match result with + | Some m_name -> + if not is_function then Err.target_must_not_have_a_result tname tpos; + check_name_in_tgv prog m_name; + check_name_in_tmp tmp_vars' m_name; + check_name_in_args env.prog.prog_dict args' m_name; + let var = Com.Var.new_res ~name:m_name in + (Some (Pos.same var.id m_name), add_var_env var env) + | None -> + if is_function then Err.function_result_missing tname tpos; + (None, env) + in + let prog', instrs' = check_instructions (is_rule || is_function) env instrs in + let env' = { env with prog = prog' } in + if is_function then ( + let tmps = StrMap.map Pos.get tmp_vars' in + let in_vars, out_vars, _ = inout_instrs prog' tmps instrs' in + let vr = Pos.unmark (Option.get result) in + let bad_in_vars = + List.fold_left + (fun res (Pos.Mark (vn, _)) -> StrMap.remove vn res) + in_vars args + |> StrMap.remove vr + in + let bad_out_vars = StrMap.remove vr out_vars in + (if StrMap.card bad_in_vars > 0 then + let vn, vpos = StrMap.min_binding bad_in_vars in + Err.forbidden_in_var_in_function vn tname vpos); + if StrMap.card bad_out_vars > 0 then + let vn, vpos = StrMap.min_binding bad_out_vars in + Err.forbidden_out_var_in_function vn tname vpos); + (env', args', result', tmp_vars', instrs') + +let check_target (is_function : bool) (t : Mast.target) (prog : program) : + program = + let target_name = t.target_name in + let tname, tpos = Pos.to_couple target_name in + if Com.Func tname <> Pos.unmark (Parse_utils.parse_function_name target_name) + then Err.is_base_function tname tpos; + (match StrMap.find_opt tname prog.prog_targets with + | Some { target_name = Pos.Mark (_, old_pos); _ } -> + Err.target_already_declared tname old_pos tpos + | None -> ()); + let target_file = Some (get_target_file tpos) in + let target_apps = + (* Already checked during preprocessing *) + t.target_apps + in + let env, target_args, target_result, target_tmp_vars, target_prog = + check_code false is_function target_name prog t.target_tmp_vars + t.target_args t.target_result t.target_prog + in + let prog = env.prog in + let target = + Com. + { + target_name; + target_file; + target_apps; + target_args; + target_result; + target_tmp_vars; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + target_prog; + } + in + if is_function then + let prog_functions = StrMap.add tname target prog.prog_functions in + { prog with prog_functions } + else + let prog_targets = StrMap.add tname target prog.prog_targets in + { prog with prog_targets } + +let check_rule (r : Mast.rule) (prog : program) : program = + let id, id_pos = Pos.to_couple r.Mast.rule_number in + let rule_id = Pos.mark id id_pos in + let rule_apps = + (* Already checked during preprocessing *) + StrMap.map Pos.get r.Mast.rule_apps + in + let rdom_id = + Com.DomainId.from_marked_list (Pos.unmark r.Mast.rule_tag_names) + in + let rule_domain, rule_domain_pos = + let rid, rid_pos = + match Com.DomainIdMap.find_opt rdom_id prog.prog_rdom_syms with + | Some m_rid -> Pos.to_couple m_rid + | None -> Err.unknown_domain Rule (Pos.get r.Mast.rule_tag_names) + in + let rule_domain = Com.DomainIdMap.find rid prog.prog_rdoms in + (rule_domain, rid_pos) + in + let rule_chains, prog_chainings = + let fold _ (Pos.Mark (ch, chpos)) (rule_chains, prog_chainings) = + (* Already checked during preprocessing *) + let chain = StrMap.find ch prog.prog_chainings in + let chain_rules = + IntMap.add id (Pos.mark rule_domain rule_domain_pos) chain.chain_rules + in + let chain = { chain with chain_rules } in + let rule_chains = StrMap.add ch chpos rule_chains in + let prog_chainings = StrMap.add ch chain prog_chainings in + (rule_chains, prog_chainings) + in + StrMap.fold fold r.rule_chainings (StrMap.empty, prog.prog_chainings) + in + let env, _, _, rule_tmp_vars, rule_instrs = + check_code true false (Pos.without "") prog r.rule_tmp_vars [] None + r.rule_formulaes + in + let prog = env.prog in + let rule_in_vars, rule_out_vars = + let tmps = StrMap.map Pos.get rule_tmp_vars in + let in_vars, out_vars, _ = inout_instrs prog tmps rule_instrs in + (StrMap.keySet in_vars, out_vars) + in + let rule_seq, prog = get_seq prog in + let rule = + { + rule_id; + rule_apps; + rule_domain; + rule_chains; + rule_tmp_vars; + rule_instrs; + rule_in_vars; + rule_out_vars; + rule_seq; + } + in + (match IntMap.find_opt id prog.prog_rules with + | Some r -> + let rule_pos = Pos.get r.rule_id in + Err.rov_already_defined Rule id rule_pos id_pos + | None -> ()); + let prog_rules = IntMap.add id rule prog.prog_rules in + { prog with prog_rules; prog_chainings } + +let convert_rules (prog : program) : program = + let prog_targets = + IntMap.fold + (fun id rule prog_targets -> + let tname = Format.sprintf "%s_regle_%d" prog.prog_prefix id in + let target_file = Some (get_target_file (Pos.get rule.rule_id)) in + let target_prog = rule.rule_instrs in + let target = + Com. + { + target_name = Pos.without tname; + target_file; + target_apps = StrMap.mapi Pos.mark prog.prog_app; + target_args = []; + target_result = None; + target_tmp_vars = rule.rule_tmp_vars; + target_prog; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + } + in + StrMap.add tname target prog_targets) + prog.prog_rules prog.prog_targets + in + { prog with prog_targets } + +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 = + let in_vars_of_rules = + IntMap.fold + (fun id rule var_map -> + StrSet.fold + (fun var var_map -> + if is_vartmp var then var_map + else + StrMap.update var + (function + | None -> Some (IntSet.one id) + | Some set -> Some (IntSet.add id set)) + var_map) + (in_vars_from rule) var_map) + rules StrMap.empty + in + IntMap.map + (fun rule -> + let edges = + StrSet.fold + (fun out_var edges -> + if is_vartmp out_var then edges + else + match StrMap.find_opt out_var in_vars_of_rules with + | Some out_rules -> + IntSet.fold + (fun out_id edges -> IntMap.add out_id out_var edges) + out_rules edges + | None -> edges) + (out_vars_from rule) IntMap.empty + in + Some edges) + rules + +let rule_graph_to_instrs (rdom_chain : rdom_or_chain) (prog : program) + (rule_graph : string IntMap.t option IntMap.t) : + (int Pos.marked, Mast.error_name) Com.m_instruction list = + let module RuleGraph : + TopologicalSorting.GRAPH + with type 'a t = string IntMap.t option IntMap.t + and type vertex = int + and type edge = string = struct + type 'a t = string IntMap.t option IntMap.t + + type vertex = int + + type edge = string + + type 'a vertexMap = 'a IntMap.t + + let vertexMapEmpty = IntMap.empty + + let vertexMapAdd id value map = IntMap.add id value map + + let vertexMapRemove id map = IntMap.remove id map + + let vertexMapFindOpt id map = IntMap.find_opt id map + + let vertexMapFold fold map res = IntMap.fold fold map res + + let vertices rules = + IntMap.fold (fun id _ res -> IntMap.add id None res) rules IntMap.empty + + let edges rules id = + let es = Option.get (IntMap.find id rules) in + IntMap.map (fun var -> Some var) es + end in + let module RulesSorting = TopologicalSorting.Make (RuleGraph) in + let auto_cycle = + Some + (function + | id, var -> + Cli.debug_print "warning: auto-cycle in rule %d with variable %s" id + var) + in + let sorted_rules = + try RulesSorting.sort ~auto_cycle rule_graph with + | RulesSorting.Cycle cycle -> Err.loop_in_rules rdom_chain cycle + | RulesSorting.AutoCycle _ -> assert false + in + List.map + (fun id -> + let name = Format.sprintf "%s_regle_%d" prog.prog_prefix id in + Pos.without (Com.ComputeTarget (Pos.without name, []))) + sorted_rules + +let rdom_rule_filter (rdom : Com.rule_domain_data Com.domain) (rule : rule) : + bool = + (match rdom.Com.dom_used with + | Some (Pos.Mark (rdom_seq, seq_pos)) -> + if rdom_seq <= rule.rule_seq then + Err.domain_already_used Rule seq_pos (Pos.get rule.rule_id) + | None -> ()); + let rdom_id = Pos.unmark rdom.dom_id in + let rule_rdom_id = Pos.unmark rule.rule_domain.dom_id in + 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 ( + 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 -> StrMap.keySet r.rule_out_vars) + rdom_rules + in + let target_prog = + rule_graph_to_instrs (RuleDomain rdom_id) prog rule_graph + in + let tname = + let spl = + Com.DomainId.fold (fun s l -> Pos.without s :: l) rdom_id [] + in + get_compute_id_str (Com.ComputeDomain (Pos.without spl)) prog + in + let target = + Com. + { + target_name = Pos.without tname; + target_file = None; + target_apps = StrMap.mapi Pos.mark prog.prog_app; + target_args = []; + target_result = None; + target_tmp_vars = StrMap.empty; + target_prog; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + } + in + StrMap.add tname target prog_targets) + else prog_targets) + prog.prog_rdoms prog.prog_targets + in + { prog with prog_targets } + +let rdom_id_rule_filter (prog : program) (rdom_id : Com.DomainId.t) + (rule : rule) : bool = + let rdom = Com.DomainIdMap.find rdom_id prog.prog_rdoms in + rdom_rule_filter rdom rule + +let rdom_ids_rule_filter (prog : program) (rdom_ids : Com.DomainIdSet.t) + (rule : rule) : bool = + Com.DomainIdSet.exists + (fun rdom_id -> rdom_id_rule_filter prog rdom_id rule) + rdom_ids + +let complete_chainings (prog : program) : program = + let prog_targets = + StrMap.fold + (fun ch_name chain prog_targets -> + let all_ids = + Com.DomainIdMap.fold + (fun _ rdom ids -> + let uid = Pos.unmark rdom.Com.dom_id in + Com.DomainIdSet.add uid ids) + prog.prog_rdoms Com.DomainIdSet.empty + in + let sup_ids = + IntMap.fold + (fun _ (Pos.Mark (rdom, id_pos)) sup_ids -> + let uid = Pos.unmark rdom.Com.dom_id in + let rdom_supeq = Com.DomainIdSet.add uid rdom.Com.dom_max in + let sup_ids = Com.DomainIdSet.inter sup_ids rdom_supeq in + if Com.DomainIdSet.cardinal sup_ids = 0 then + Err.rule_domain_incompatible_with_chaining ch_name id_pos + else sup_ids) + chain.chain_rules all_ids + in + let min_ids = + Com.DomainIdSet.filter + (fun id -> + let rdom = Com.DomainIdMap.find id prog.prog_rdoms in + let min_sups = Com.DomainIdSet.inter sup_ids rdom.Com.dom_min in + Com.DomainIdSet.is_empty min_sups) + sup_ids + in + let rdom_rules = + IntMap.filter + (fun _ rule -> rdom_ids_rule_filter prog min_ids rule) + prog.prog_rules + in + let inverted_rule_graph = + create_rule_graph + (fun r -> StrMap.keySet r.rule_out_vars) + (fun r -> r.rule_in_vars) + rdom_rules + in + let rules = + let rec add_connected_rules rid rules = + if IntMap.mem rid rules then rules + else + let edges = Option.get (IntMap.find rid inverted_rule_graph) in + let rules = IntMap.add rid (IntMap.find rid rdom_rules) rules in + IntMap.fold + (fun rid _ rules -> add_connected_rules rid rules) + edges rules + in + IntMap.fold + (fun rid _ rules -> add_connected_rules rid rules) + chain.chain_rules IntMap.empty + in + let rule_graph = + create_rule_graph + (fun r -> r.rule_in_vars) + (fun r -> StrMap.keySet r.rule_out_vars) + rules + in + let target_prog = + rule_graph_to_instrs (Chaining ch_name) prog rule_graph + in + let tname = + get_compute_id_str (Com.ComputeChaining (Pos.without ch_name)) prog + in + let target = + Com. + { + target_name = Pos.without tname; + target_file = None; + target_apps = StrMap.mapi Pos.mark prog.prog_app; + target_args = []; + target_result = None; + target_tmp_vars = StrMap.empty; + target_prog; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + } + in + StrMap.add tname target prog_targets) + prog.prog_chainings prog.prog_targets + in + { prog with prog_targets } + +let check_verif (v : Mast.verification) (prog : program) : program = + let verif_apps = + (* Already checked during preprocessing *) + StrMap.map Pos.get v.Mast.verif_apps + in + let vdom_id = + Com.DomainId.from_marked_list (Pos.unmark v.Mast.verif_tag_names) + in + let verif_domain = + let vid = + match Com.DomainIdMap.find_opt vdom_id prog.prog_vdom_syms with + | Some (Pos.Mark (vid, _)) -> vid + | None -> Err.unknown_domain Verif (Pos.get v.Mast.verif_tag_names) + in + Com.DomainIdMap.find vid prog.prog_vdoms + in + let prog_verifs, prog, _ = + List.fold_left + (fun (prog_verifs, prog, num) (Pos.Mark (cond, cond_pos)) -> + let id, id_pos = Pos.to_couple v.Mast.verif_number in + let id = id + num in + let verif_id = Pos.mark id id_pos in + let verif_expr = cond.Mast.verif_cond_expr in + let verif_error, verif_var = cond.Mast.verif_cond_error in + let err_name, err_pos = Pos.to_couple verif_error in + let verif_is_blocking = + match StrMap.find_opt err_name prog.prog_errors with + | None -> Err.unknown_error err_pos + | Some err -> ( + match err.typ with Com.Error.Anomaly -> true | _ -> false) + in + (match verif_var with + | Some (Pos.Mark (var_name, var_pos)) -> ( + match StrMap.find_opt var_name prog.prog_vars with + | None -> Err.unknown_variable var_pos + | Some _ -> ()) + | None -> ()); + let verif_cat_var_stats, verif_var_stats = + let get_var m_v = + Pos.same (Com.get_normal_var @@ Pos.unmark m_v) m_v + in + let fold_var m_v idx_mem env (vdom_sts, var_sts) = + check_variable m_v idx_mem env; + let name = Com.get_normal_var (Pos.unmark m_v) in + let id = StrMap.find name env.vars in + let var = IntMap.find id env.prog.prog_dict in + let cat = Com.Var.cat var in + if not (Com.CatVar.Map.mem cat verif_domain.dom_data.vdom_auth) then + Err.variable_with_forbidden_category (Pos.get m_v); + let incr = function None -> Some 1 | Some i -> Some (i + 1) in + let vdom_sts = Com.CatVar.Map.update cat incr vdom_sts in + let var_sts = StrMap.update name incr var_sts in + (vdom_sts, var_sts) + in + let init = (Com.CatVar.Map.empty, StrMap.empty) in + let env = { prog; vars = prog.prog_vars } in + fold_var_expr get_var fold_var false init verif_expr env + in + let verif_seq, prog = get_seq prog in + let verif = + { + verif_id; + verif_apps; + verif_domain; + verif_expr; + verif_error; + verif_var; + verif_is_blocking; + verif_cat_var_stats; + verif_var_stats; + verif_seq; + } + in + (match IntMap.find_opt id prog.prog_verifs with + | Some v -> + let verif_pos = Pos.get v.verif_id in + Err.rov_already_defined Verif id verif_pos cond_pos + | None -> ()); + let prog_verifs = IntMap.add id verif prog_verifs in + (prog_verifs, prog, num + 1)) + (prog.prog_verifs, prog, 0) + v.Mast.verif_conditions + in + { prog with prog_verifs } + +let convert_verifs (prog : program) : program = + let prog_targets = + IntMap.fold + (fun id verif prog_targets -> + let tname = Format.sprintf "%s_verif_%d" prog.prog_prefix id in + let target_file = Some (get_target_file (Pos.get verif.verif_id)) in + let target_prog = + let map_var m_v = + let name = Com.get_normal_var (Pos.unmark m_v) in + let id = StrMap.find name prog.prog_vars in + Pos.same id m_v + in + List.map + (Com.m_instr_map_var map_var Fun.id) + [ + Pos.without + (Com.IfThenElse + ( verif.verif_expr, + [ + Pos.without + (Com.RaiseError (verif.verif_error, verif.verif_var)); + ], + [] )); + ] + in + let target = + Com. + { + target_name = Pos.without tname; + target_file; + target_apps = StrMap.mapi Pos.mark prog.prog_app; + target_args = []; + target_result = None; + target_tmp_vars = StrMap.empty; + target_prog; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + } + in + StrMap.add tname target prog_targets) + prog.prog_verifs prog.prog_targets + in + { prog with prog_targets } + +let eval_expr_verif (prog : program) (verif : verif) + (expr : Mast.expression Pos.marked) : float option = + let my_floor a = floor (a +. 0.000001) in + let _my_ceil a = ceil (a -. 0.000001) in + let my_arr a = + let my_var1 = floor a in + let my_var2 = ((a -. my_var1) *. 100000.0) +. 0.5 in + let my_var2 = floor my_var2 /. 100000.0 in + let my_var2 = my_var1 +. my_var2 +. 0.5 in + floor my_var2 + in + let rec aux expr = + match Pos.unmark expr with + | Com.Literal (Com.Float f) -> Some f + | Literal Com.Undefined -> None + | Var _ -> Err.variable_forbidden_in_filter (Pos.get expr) + | Attribut (Pos.Mark (VarAccess m_v, _), m_attr) -> + let var_name = Com.get_normal_var @@ Pos.unmark m_v in + let id = StrMap.find var_name prog.prog_vars in + let var = IntMap.find id prog.prog_dict in + let attrs = Com.Var.attrs var in + let m_val = StrMap.find (Pos.unmark m_attr) attrs in + Some (float (Pos.unmark m_val)) + | Size (Pos.Mark (VarAccess m_v, _)) -> + let var_name = Com.get_normal_var @@ Pos.unmark m_v in + let id = StrMap.find var_name prog.prog_vars in + let var = IntMap.find id prog.prog_dict in + Some (float @@ Com.Var.size @@ var) + | IsVariable (Pos.Mark (VarAccess m_v, _), m_name) -> ( + let var_name = Com.get_normal_var @@ Pos.unmark m_v in + let id = StrMap.find var_name prog.prog_vars in + let var = IntMap.find id prog.prog_dict in + if Pos.unmark m_name = Com.Var.name_str var then Some 1.0 + else + match Com.Var.alias var with + | Some m_alias when Pos.unmark m_alias = Pos.unmark m_name -> Some 1.0 + | _ -> Some 0.0) + | NbCategory cs -> + let cats = mast_to_catvars cs prog.prog_var_cats in + let sum = + Com.CatVar.Map.fold + (fun cat _ sum -> + match Com.CatVar.Map.find_opt cat verif.verif_cat_var_stats with + | Some i -> sum + i + | None -> sum) + cats 0 + in + Some (float sum) + | Unop (op, e0) -> ( + match aux e0 with + | None -> None + | Some f -> ( + match op with Com.Not -> Some (1.0 -. f) | Com.Minus -> Some ~-.f)) + | FuncCall (func, args) -> ( + let rl = List.map aux args in + let unFunc f = + match rl with + | [ None ] -> None + | [ Some x ] -> Some (f x) + | _ -> assert false + in + let biFunc f = + match rl with + | [ None; None ] -> None + | [ None; r ] | [ r; None ] -> r + | [ Some x0; Some x1 ] -> Some (f x0 x1) + | _ -> assert false + in + match Pos.unmark func with + | Com.VerifNumber -> Some (float (Pos.unmark verif.verif_id)) + | Com.ComplNumber -> assert false + | Com.SumFunc -> + List.fold_left + (fun res r -> + match r with + | None -> res + | Some f -> ( + match res with None -> r | Some fr -> Some (f +. fr))) + None rl + | Com.AbsFunc -> unFunc abs_float + | Com.MinFunc -> biFunc min + | Com.MaxFunc -> biFunc max + | Com.GtzFunc -> unFunc (fun x -> if x > 0.0 then 1.0 else 0.0) + | Com.GtezFunc -> unFunc (fun x -> if x >= 0.0 then 1.0 else 0.0) + | Com.NullFunc -> unFunc (fun x -> if x = 0.0 then 1.0 else 0.0) + | Com.ArrFunc -> unFunc my_arr + | Com.InfFunc -> unFunc my_floor + | Com.Supzero -> ( + match rl with + | [ None ] -> None + | [ Some f ] when f = 0.0 -> None + | [ r ] -> r + | _ -> 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 + | Some f0, Some f1 -> ( + let open Com in + match Pos.unmark op with + | Gt -> Some (if f0 > f1 then 1.0 else 0.0) + | Gte -> Some (if f0 >= f1 then 1.0 else 0.0) + | Lt -> Some (if f0 < f1 then 1.0 else 0.0) + | Lte -> Some (if f0 <= f1 then 1.0 else 0.0) + | Eq -> Some (if f0 = f1 then 1.0 else 0.0) + | Neq -> Some (if f0 <> f1 then 1.0 else 0.0))) + | Binop (op, e0, e1) -> ( + let r0 = aux e0 in + let r1 = aux e1 in + match Pos.unmark op with + | Com.And -> ( + match r0 with + | None -> None + | Some f0 -> if f0 = 0.0 then r0 else r1) + | Com.Or -> ( + match r0 with None -> r1 | Some f0 -> if f0 = 0.0 then r1 else r0) + | Com.Add -> ( + match (r0, r1) with + | None, None -> None + | None, Some _ -> r1 + | Some _, None -> r0 + | Some f0, Some f1 -> Some (f0 +. f1)) + | Com.Sub -> ( + match (r0, r1) with + | None, None -> None + | None, Some _ -> r1 + | Some _, None -> r0 + | Some f0, Some f1 -> Some (f0 +. f1)) + | Com.Mul -> ( + match (r0, r1) with + | None, _ | _, None -> None + | Some f0, Some f1 -> Some (f0 *. f1)) + | Com.Div -> ( + match (r0, r1) with + | None, _ | _, None -> None + | 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 + let r2 = match e2 with Some e -> aux e | None -> None in + match r0 with None -> None | Some f -> if f = 1.0 then r1 else r2) + | TestInSet (positive, e, values) -> ( + match aux e with + | None -> None + | Some v -> + let res = + List.fold_left + (fun res set_value -> + match set_value with + | Com.VarValue _ -> assert false + | Com.FloatValue (Pos.Mark (f, _)) -> res || f = v + | Com.IntervalValue (Pos.Mark (bn, _), Pos.Mark (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 + | FuncCallLoop _ | Loop _ | Attribut _ | Size _ | IsVariable _ -> + assert false + in + aux expr + +let vdom_rule_filter (prog : program) (vdom : Com.verif_domain_data Com.domain) + (expr : Mast.expression Pos.marked) (verif : verif) : bool = + (match vdom.Com.dom_used with + | Some (Pos.Mark (vdom_seq, seq_pos)) -> + if vdom_seq <= verif.verif_seq then + Err.domain_already_used Verif seq_pos (Pos.get verif.verif_id) + | None -> ()); + let filter_expr = + match eval_expr_verif prog verif expr with Some 1.0 -> true | _ -> false + in + let vdom_id = Pos.unmark vdom.dom_id in + let verif_vdom_id = Pos.unmark verif.verif_domain.dom_id in + filter_expr + && (Com.DomainId.equal vdom_id verif_vdom_id + || Com.DomainIdSet.mem verif_vdom_id vdom.Com.dom_min) + +module OrdVerif = struct + type t = int * int * int + + let make v = + let iBlock = if v.verif_is_blocking then 0 else 1 in + (iBlock, -v.verif_seq, Pos.unmark v.verif_id) + + let get_id (_, _, id) = id + + let compare x y = compare x y +end + +module OrdVerifSet = struct + include SetExt.Make (OrdVerif) + + let _pp ?(sep = " ") + ?(pp_elt = + fun fmt (i, j, k) -> Format.fprintf fmt "(%d, %d, %d)" i (-j) k) + (_ : unit) (fmt : Format.formatter) (set : t) : unit = + pp ~sep ~pp_elt () fmt set +end + +module OrdVerifSetMap = struct + include MapExt.Make (OrdVerifSet) + + let _pp ?(sep = ", ") ?(pp_key = OrdVerifSet.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 + +let complete_verif_calls (prog : program) : program = + let prog_targets, _ = + StrMap.fold + (fun tname (_, vdom_id, expr) (prog_targets, verif_calls) -> + let verif_set = + IntMap.fold + (fun _verif_id verif verif_set -> + let vdom = Com.DomainIdMap.find vdom_id prog.prog_vdoms in + if vdom_rule_filter prog vdom expr verif then + OrdVerifSet.add (OrdVerif.make verif) verif_set + else verif_set) + prog.prog_verifs OrdVerifSet.empty + in + match OrdVerifSetMap.find_opt verif_set verif_calls with + | Some tn -> + let target_prog = + [ Pos.without (Com.ComputeTarget (Pos.without tn, [])) ] + in + let target = + Com. + { + target_name = Pos.without tname; + target_file = None; + target_apps = StrMap.mapi Pos.mark prog.prog_app; + target_args = []; + target_result = None; + target_tmp_vars = StrMap.empty; + target_prog; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + } + in + let prog_targets = StrMap.add tname target prog_targets in + (prog_targets, verif_calls) + | None -> + let instrs = + let instrs = + OrdVerifSet.fold + (fun ord_verif target_prog -> + let verif_id = OrdVerif.get_id ord_verif in + let verif_tn = + Format.sprintf "%s_verif_%d" prog.prog_prefix verif_id + in + Pos.without (Com.ComputeTarget (Pos.without verif_tn, [])) + :: target_prog) + verif_set [] + in + List.rev instrs + in + let target_prog = [ Pos.without (Com.VerifBlock instrs) ] in + let target = + Com. + { + target_name = Pos.without tname; + target_file = None; + target_apps = StrMap.mapi Pos.mark prog.prog_app; + target_args = []; + target_result = None; + target_tmp_vars = StrMap.empty; + target_prog; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + } + in + let prog_targets = StrMap.add tname target prog_targets in + let verif_calls = OrdVerifSetMap.add verif_set tname verif_calls in + (prog_targets, verif_calls)) + prog.prog_vdom_calls + (prog.prog_targets, OrdVerifSetMap.empty) + in + { prog with prog_targets } + +let proceed (main_target : string) (p : Mast.program) : program = + (* à paramétrer *) + let prog = + List.fold_left + (fun prog source_file -> + List.fold_left + (fun prog (Pos.Mark (item, pos_item)) -> + match item with + | Mast.Application (Pos.Mark (name, pos)) -> + check_application name pos prog + | Mast.Chaining (Pos.Mark (name, pos), m_apps) -> + check_chaining name pos m_apps prog + | Mast.VarCatDecl (Pos.Mark (decl, pos)) -> + check_var_category decl pos prog + | Mast.VariableDecl var_decl -> check_var_decl var_decl prog + | Mast.VariableSpaceDecl vsd -> check_variable_space_decl vsd 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 *) + | Mast.RuleDomDecl decl -> check_rule_dom_decl decl prog + | Mast.VerifDomDecl decl -> check_verif_dom_decl decl prog + | Mast.Function f -> check_target true f prog + | Mast.Target t -> check_target false t prog + | Mast.Rule r -> check_rule r prog + | Mast.Verification v -> check_verif v prog) + prog source_file) + (empty_program p main_target) + p + in + (match StrMap.find_opt "" prog.prog_var_spaces with + | None -> Err.no_default_variable_space () + | Some _ -> ()); + 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 ef.name)) + prog.prog_event_fields; + if StrMap.is_empty prog.prog_targets then Err.has_no_target (); + (match StrMap.find_opt prog.prog_main_target prog.prog_targets with + | None -> Err.main_target_not_found prog.prog_main_target + | Some _ -> ()); + prog |> complete_rdom_decls |> complete_vdom_decls |> convert_rules + |> complete_rule_domains |> complete_chainings |> convert_verifs + |> complete_verif_calls diff --git a/src/mlang/m_frontend/check_validity.mli b/src/mlang/m_frontend/validator.mli similarity index 77% rename from src/mlang/m_frontend/check_validity.mli rename to src/mlang/m_frontend/validator.mli index 75ed034b6..253456c2a 100644 --- a/src/mlang/m_frontend/check_validity.mli +++ b/src/mlang/m_frontend/validator.mli @@ -12,18 +12,6 @@ type rule_or_verif = Rule | Verif -module MarkedVarNames : sig - type t - - val compare : t -> t -> int - - val pp_marked : Format.formatter -> t -> unit - - module Set : SetExt.T with type elt = t - - module Map : MapExt.T with type key = t -end - type syms = Com.DomainId.t Pos.marked Com.DomainIdMap.t type 'a doms = 'a Com.domain Com.DomainIdMap.t @@ -39,11 +27,10 @@ type rule = { rule_apps : Pos.t StrMap.t; rule_domain : Com.rule_domain; rule_chains : Pos.t StrMap.t; - rule_tmp_vars : - (string Pos.marked * Mast.table_size Pos.marked option) StrMap.t; - rule_instrs : Mast.instruction Pos.marked list; - rule_in_vars : MarkedVarNames.Set.t; - rule_out_vars : MarkedVarNames.Set.t; + rule_tmp_vars : int Pos.marked StrMap.t; + rule_instrs : (int Pos.marked, Mast.error_name) Com.m_instruction list; + rule_in_vars : StrSet.t; + rule_out_vars : Pos.t StrMap.t; rule_seq : int; } @@ -53,13 +40,15 @@ type verif = { verif_domain : Com.verif_domain; verif_expr : Mast.expression Pos.marked; verif_error : Mast.error_name Pos.marked; - verif_var : Mast.variable_name Pos.marked option; + verif_var : string Pos.marked option; verif_is_blocking : bool; verif_cat_var_stats : int Com.CatVar.Map.t; verif_var_stats : int StrMap.t; verif_seq : int; } +type target = (int Pos.marked, Mast.error_name) Com.target + type program = { prog_prefix : string; prog_seq : int; @@ -67,22 +56,27 @@ type program = { prog_apps : Pos.t StrMap.t; 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_dict : Com.Var.t IntMap.t; + prog_vars : int StrMap.t; + prog_alias : int StrMap.t; + prog_var_spaces : int StrMap.t; + prog_var_spaces_idx : Com.variable_space IntMap.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; prog_vdoms : Com.verif_domain_data doms; prog_vdom_syms : syms; - prog_functions : Mast.target StrMap.t; + prog_functions : target StrMap.t; prog_rules : rule IntMap.t; prog_rdom_calls : (int Pos.marked * Com.DomainId.t) StrMap.t; prog_verifs : verif IntMap.t; prog_vdom_calls : (int Pos.marked * Com.DomainId.t * Mast.expression Pos.marked) StrMap.t; - prog_targets : Mast.target StrMap.t; + prog_targets : target StrMap.t; prog_main_target : string; - prog_stats : Mir.stats; } val mast_to_catvars : @@ -98,4 +92,4 @@ val cats_variable_from_decl_list : val check_domain : rule_or_verif -> 'a Mast.domain_decl -> 'b -> 'b doms * syms -> 'b doms * syms -val proceed : Mast.program -> string -> program +val proceed : string -> Mast.program -> program diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 3ac20e92a..bea359082 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -46,28 +46,58 @@ module CatVar = struct pp ~sep ~pp_key ~assoc pp_val fmt map let from_string_list = function - | [ ("*", _) ], id_pos -> + | Pos.Mark ([ Pos.Mark ("*", _) ], id_pos) -> one (Input (StrSet.one "*")) id_pos |> add (Computed { is_base = false }) id_pos |> add (Computed { is_base = true }) id_pos - | [ ("saisie", _); ("*", _) ], id_pos -> + | Pos.Mark ([ Pos.Mark ("saisie", _); Pos.Mark ("*", _) ], id_pos) -> one (Input (StrSet.one "*")) id_pos - | ("saisie", _) :: id, id_pos -> + | Pos.Mark (Pos.Mark ("saisie", _) :: id, id_pos) -> one (Input (StrSet.from_marked_list id)) id_pos - | ("calculee", _) :: id, id_pos -> ( + | Pos.Mark (Pos.Mark ("calculee", _) :: id, id_pos) -> ( match id with | [] -> one (Computed { is_base = false }) id_pos - | [ ("base", _) ] -> one (Computed { is_base = true }) id_pos - | [ ("*", _) ] -> + | [ Pos.Mark ("base", _) ] -> one (Computed { is_base = true }) id_pos + | [ Pos.Mark ("*", _) ] -> one (Computed { is_base = false }) id_pos |> add (Computed { is_base = true }) id_pos | _ -> Errors.raise_spanned_error "invalid variable category" id_pos) - | _, id_pos -> + | Pos.Mark (_, id_pos) -> Errors.raise_spanned_error "invalid variable category" id_pos end type loc = LocComputed | LocBase | LocInput + let pp_loc oc = function + | LocInput -> Pp.fpr oc "input" + | LocComputed -> Pp.fpr oc "computed" + | LocBase -> Pp.fpr oc "base" + + module LocSet = struct + include SetExt.Make (struct + type t = loc + + let compare = Stdlib.compare + end) + + let pp ?(sep = ", ") ?(pp_elt = pp_loc) (_ : unit) (fmt : Format.formatter) + (set : t) : unit = + pp ~sep ~pp_elt () fmt set + end + + module LocMap = struct + include MapExt.Make (struct + type t = loc + + let compare = Stdlib.compare + end) + + let pp ?(sep = "; ") ?(pp_key = pp_loc) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map + end + type data = { id : t; id_str : string; @@ -89,21 +119,20 @@ type value_typ = | Real type loc_tgv = { - loc_id : string; loc_cat : CatVar.loc; loc_idx : int; + loc_tab_idx : int; loc_cat_id : CatVar.t; loc_cat_str : string; loc_cat_idx : int; - loc_int : int; } +type loc_tmp = { loc_idx : int; loc_tab_idx : int; loc_cat_idx : int } + type loc = | LocTgv of string * loc_tgv - | LocTmp of string * int + | LocTmp of string * loc_tmp | LocRef of string * int - | LocArg of string * int - | LocRes of string module Var = struct type id = int @@ -116,7 +145,7 @@ module Var = struct id type tgv = { - is_table : int option; + table : t Array.t option; alias : string Pos.marked option; (** Input variable have an alias *) descr : string Pos.marked; (** Description taken from the variable declaration *) @@ -126,9 +155,9 @@ module Var = struct typ : value_typ option; } - type scope = Tgv of tgv | Temp of int option | Ref | Arg | Res + and scope = Tgv of tgv | Temp of t Array.t option | Ref - type t = { + and t = { name : string Pos.marked; (** The position is the variable declaration *) id : id; loc : loc; @@ -139,33 +168,44 @@ module Var = struct match v.scope with | Tgv s -> s | _ -> - Errors.raise_error - (Format.sprintf "%s is not a TGV variable" (Pos.unmark v.name)) + let msg = Pp.spr "%s is not a TGV variable" (Pos.unmark v.name) in + Errors.raise_error msg let name v = v.name let name_str v = Pos.unmark v.name - let is_table v = + let get_table v = match v.scope with - | Tgv tgv -> tgv.is_table - | Temp is_table -> is_table - | Ref | Arg | Res -> None + | Tgv tgv -> tgv.table + | Temp table -> table + | Ref -> None + + let is_table v = get_table v <> None + + let set_table v table = + match v.scope with + | Tgv tgv -> { v with scope = Tgv { tgv with table } } + | Temp _ -> { v with scope = Temp table } + | Ref -> v let cat_var_loc v = match v.scope with | Tgv tgv -> ( match tgv.cat with - | CatVar.Input _ -> Some CatVar.LocInput - | Computed { is_base } when is_base -> Some CatVar.LocBase - | Computed _ -> Some CatVar.LocComputed) - | Temp _ | Ref | Arg | Res -> None + | CatVar.Input _ -> CatVar.LocInput + | Computed { is_base } when is_base -> CatVar.LocBase + | Computed _ -> CatVar.LocComputed) + | Temp _ | Ref -> failwith "not a TGV variable" - let size v = match is_table v with None -> 1 | Some sz -> sz + let size v = match get_table v with None -> 1 | Some tab -> Array.length tab - let alias v = (tgv v).alias + let alias v = match v.scope with Tgv s -> s.alias | _ -> None - let alias_str v = Option.fold ~none:"" ~some:Pos.unmark (tgv v).alias + let alias_str v = + match v.scope with + | Tgv s -> Option.fold ~none:"" ~some:Pos.unmark s.alias + | _ -> "" let descr v = (tgv v).descr @@ -181,37 +221,84 @@ module Var = struct match v.loc with | LocTgv (_, l) -> l | _ -> - Errors.raise_error - (Format.sprintf "%s is not a TGV variable" (Pos.unmark v.name)) + let msg = Pp.spr "%s is not a TGV variable" (Pos.unmark v.name) in + Errors.raise_error msg - let loc_int v = + let loc_cat_idx v = match v.loc with - | LocTgv (_, tgv) -> tgv.loc_int - | LocTmp (_, li) | LocRef (_, li) | LocArg (_, li) -> li - | LocRes id -> - Errors.raise_error - (Format.sprintf "variable %s doesn't have an index" id) + | LocTgv (_, tgv) -> tgv.loc_cat_idx + | LocTmp (_, tmp) -> tmp.loc_cat_idx + | LocRef (_, li) -> li - let is_temp v = match v.scope with Temp _ -> true | _ -> false + let set_loc_tgv_idx v (cv : CatVar.data) i = + match v.loc with + | LocTgv (id, tgv) -> + let loc_cat = cv.loc in + let loc_cat_str = cv.id_str in + let tgv = { tgv with loc_cat; loc_cat_str; loc_cat_idx = i } in + { v with loc = LocTgv (id, tgv) } + | LocTmp (id, _) | LocRef (id, _) -> + Errors.raise_error (Pp.spr "%s has not a TGV location" id) + + let set_loc_tmp_idx v i = + match v.loc with + | LocTmp (id, tmp) -> + let tmp = { tmp with loc_cat_idx = i } in + { v with loc = LocTmp (id, tmp) } + | LocTgv (id, _) | LocRef (id, _) -> + Errors.raise_error (Pp.spr "%s has not a TGV location" id) - let is_ref v = v.scope = Ref + let loc_idx v = + match v.loc with + | LocTgv (_, tgv) -> tgv.loc_idx + | LocTmp (_, tmp) -> tmp.loc_idx + | LocRef (_, li) -> li + + let set_loc_idx v loc_idx = + let loc = + match v.loc with + | LocTgv (id, tgv) -> LocTgv (id, { tgv with loc_idx }) + | LocTmp (id, tmp) -> LocTmp (id, { tmp with loc_idx }) + | LocRef (id, _) -> LocRef (id, loc_idx) + in + { v with loc } + + let loc_tab_idx v = + match v.loc with + | LocTgv (_, tgv) -> tgv.loc_tab_idx + | LocTmp (_, tmp) -> tmp.loc_tab_idx + | LocRef (id, _) -> + let msg = Pp.spr "variable %s cannot be a table" id in + Errors.raise_error msg + + let set_loc_tab_idx v loc_tab_idx = + let loc = + match v.loc with + | LocTgv (id, tgv) -> LocTgv (id, { tgv with loc_tab_idx }) + | LocTmp (id, tmp) -> LocTmp (id, { tmp with loc_tab_idx }) + | LocRef (id, _) -> + let msg = Pp.spr "variable %s cannot be a table" id in + Errors.raise_error msg + in + { v with loc } + + let is_tgv v = match v.scope with Tgv _ -> true | _ -> false - let is_arg v = v.scope = Arg + let is_temp v = match v.scope with Temp _ -> true | _ -> false - let is_res v = v.scope = Res + let is_ref v = v.scope = Ref let init_loc loc_cat_id = { - loc_id = ""; loc_cat = CatVar.LocInput; loc_idx = 0; + loc_tab_idx = -1; loc_cat_id; loc_cat_str = ""; loc_cat_idx = 0; - loc_int = 0; } - let new_tgv ~(name : string Pos.marked) ~(is_table : int option) + let new_tgv ~(name : string Pos.marked) ~(table : t Array.t option) ~(is_given_back : bool) ~(alias : string Pos.marked option) ~(descr : string Pos.marked) ~(attrs : int Pos.marked StrMap.t) ~(cat : CatVar.t) ~(typ : value_typ option) : t = @@ -219,32 +306,25 @@ module Var = struct name; id = new_id (); loc = LocTgv (Pos.unmark name, init_loc cat); - scope = Tgv { is_table; alias; descr; attrs; cat; is_given_back; typ }; + scope = Tgv { table; alias; descr; attrs; cat; is_given_back; typ }; } - let new_temp ~(name : string Pos.marked) ~(is_table : int option) - ~(loc_int : int) : t = - let loc = LocTmp (Pos.unmark name, loc_int) in - { name; id = new_id (); loc; scope = Temp is_table } + let new_temp ~(name : string Pos.marked) ~(table : t Array.t option) : t = + let loc = + LocTmp + (Pos.unmark name, { loc_idx = -1; loc_tab_idx = -1; loc_cat_idx = -1 }) + in + { name; id = new_id (); loc; scope = Temp table } - let new_ref ~(name : string Pos.marked) ~(loc_int : int) : t = - let loc = LocRef (Pos.unmark name, loc_int) in + let new_ref ~(name : string Pos.marked) : t = + let loc = LocRef (Pos.unmark name, -1) in { name; id = new_id (); loc; scope = Ref } - let new_arg ~(name : string Pos.marked) ~(loc_int : int) : t = - let loc = LocArg (Pos.unmark name, loc_int) in - { name; id = new_id (); loc; scope = Arg } + let new_arg ~(name : string Pos.marked) : t = new_temp ~name ~table:None - let new_res ~(name : string Pos.marked) : t = - let loc = LocRes (Pos.unmark name) in - { name; id = new_id (); loc; scope = Res } + let new_res ~(name : string Pos.marked) : t = new_temp ~name ~table:None - let int_of_scope = function - | Tgv _ -> 0 - | Temp _ -> 1 - | Ref -> 2 - | Arg -> 3 - | Res -> 4 + let int_of_scope = function Tgv _ -> 0 | Temp _ -> 1 | Ref -> 2 let compare (var1 : t) (var2 : t) = let c = compare (int_of_scope var1.scope) (int_of_scope var2.scope) in @@ -259,7 +339,7 @@ module Var = struct let pp_var = pp - let compare_var v0 v1 = Int.compare v0.id v1.id + let compare_var v0 v1 = compare v0 v1 module Set = struct include SetExt.Make (struct @@ -291,6 +371,10 @@ 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 } + +type ('n, 'v) event_value = Numeric of 'n | RefVar of 'v + module DomainId = StrSet module DomainIdSet = struct @@ -337,37 +421,24 @@ type verif_domain_data = { type verif_domain = verif_domain_data domain -module TargetMap = StrMap +type variable_space = { + vs_id : int; + vs_name : string Pos.marked; + vs_cats : CatVar.loc Pos.marked CatVar.LocMap.t; + vs_by_default : bool; +} 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 (** 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 -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 *) @@ -383,27 +454,62 @@ type func = | Supzero (** ??? *) | VerifNumber | ComplNumber + | NbEvents | Func of string -type 'v expression = +type var_name_generic = { base : string; parameters : char list } +(** For generic variables, we record the list of their lowercase parameters *) + +(** A variable is either generic (with loop parameters) or normal *) +type var_name = Normal of string | Generic of var_name_generic + +type m_var_name = var_name Pos.marked + +type 'v access = + | VarAccess of 'v + | TabAccess of 'v * 'v m_expression + | ConcAccess of m_var_name * string Pos.marked * 'v m_expression + | FieldAccess of 'v m_expression * string Pos.marked * int + +and 'v m_access = 'v access Pos.marked + +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 m_access + | 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]) *) | 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 | Conditional of 'v m_expression * 'v m_expression * 'v m_expression option | FuncCall of func Pos.marked * 'v m_expression list | 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 - | Attribut of 'v Pos.marked * string Pos.marked - | Size of 'v Pos.marked + | Attribut of 'v m_access * string Pos.marked + | Size of 'v m_access + | IsVariable of 'v m_access * string Pos.marked | NbAnomalies | NbDiscordances | NbInformatives @@ -433,25 +539,61 @@ 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 +type print_info = Name | Alias + type 'v print_arg = | PrintString of string - | PrintName of 'v Pos.marked - | PrintAlias of 'v Pos.marked + | PrintAccess of print_info * 'v access Pos.marked | PrintIndent of 'v m_expression | PrintExpr of 'v m_expression * int * int 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 access Pos.marked * 'v m_expression + | EventFieldRef of 'v m_expression * string Pos.marked * int * 'v type 'v formula = | SingleFormula of 'v formula_decl @@ -469,17 +611,28 @@ type ('v, 'e) instruction = | ComputeDomain of string Pos.marked list Pos.marked | ComputeChaining of string Pos.marked | ComputeVerifs of string Pos.marked list Pos.marked * 'v m_expression - | ComputeTarget of string Pos.marked * 'v Pos.marked list + | ComputeTarget of string Pos.marked * 'v list | VerifBlock of ('v, 'e) m_instruction list | Print of print_std * 'v print_arg Pos.marked list | Iterate of - 'v Pos.marked - * 'v Pos.marked list + 'v + * 'v list * (Pos.t CatVar.Map.t * 'v m_expression) list * ('v, 'e) m_instruction list + | Iterate_values of + 'v + * ('v m_expression * '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 + 'v list + * ('v * Pos.t CatVar.Map.t * 'v m_expression) list + * 'v m_expression list + * ('v * 'v m_expression) list + * ('v, 'e) m_instruction list + | ArrangeEvents of + ('v * 'v * 'v m_expression) option + * ('v * 'v m_expression) option + * 'v m_expression option * ('v, 'e) m_instruction list | RaiseError of 'e Pos.marked * string Pos.marked option | CleanErrors @@ -488,27 +641,244 @@ type ('v, 'e) instruction = and ('v, 'e) m_instruction = ('v, 'e) instruction Pos.marked -let set_loc_int loc loc_int = - match loc with - | LocTgv (id, tgv) -> LocTgv (id, { tgv with loc_int }) - | LocTmp (id, _) -> LocTmp (id, loc_int) - | LocRef (id, _) -> LocRef (id, loc_int) - | LocArg (id, _) -> LocArg (id, loc_int) - | LocRes id -> - Errors.raise_error (Format.sprintf "variable %s doesn't have an index" id) - -let set_loc_tgv_cat loc loc_cat loc_cat_str loc_cat_idx = - match loc with - | LocTgv (id, tgv) -> - LocTgv (id, { tgv with loc_cat; loc_cat_str; loc_cat_idx }) - | LocTmp (id, _) | LocRef (id, _) | LocArg (id, _) | LocRes id -> - Errors.raise_error (Format.sprintf "%s has not a TGV location" id) - -let set_loc_tgv_idx loc loc_idx = - match loc with - | LocTgv (id, tgv) -> LocTgv (id, { tgv with loc_idx }) - | LocTmp (id, _) | LocRef (id, _) | LocArg (id, _) | LocRes id -> - Errors.raise_error (Format.sprintf "%s has not a TGV location" id) +type ('v, 'e) target = { + target_name : string Pos.marked; + target_file : string option; + target_apps : string Pos.marked StrMap.t; + target_args : 'v list; + target_result : 'v option; + target_tmp_vars : 'v StrMap.t; + target_nb_tmps : int; + target_sz_tmps : int; + target_nb_refs : int; + target_prog : ('v, 'e) m_instruction list; +} + +let target_is_function t = t.target_result <> None + +let rec access_map_var f = function + | VarAccess v -> VarAccess (f v) + | TabAccess (v, m_i) -> + let v' = f v in + let m_i' = m_expr_map_var f m_i in + TabAccess (v', m_i') + | ConcAccess (vname, m_ifmt, m_i) -> + let m_i' = m_expr_map_var f m_i in + ConcAccess (vname, m_ifmt, m_i') + | FieldAccess (m_i, field, id) -> + let m_i' = m_expr_map_var f m_i in + FieldAccess (m_i', field, id) + +and m_access_map_var f m_access = Pos.map (access_map_var f) m_access + +and set_value_map_var f = function + | FloatValue value -> FloatValue value + | VarValue m_access -> + let m_access' = m_access_map_var f m_access in + VarValue m_access' + | IntervalValue (i0, i1) -> IntervalValue (i0, i1) + +and atom_map_var f = function + | AtomVar v -> AtomVar (f v) + | AtomLiteral l -> AtomLiteral l + +and m_atom_map_var f m_a = Pos.map (atom_map_var f) m_a + +and set_value_loop_map_var f = function + | Single m_a0 -> Single (m_atom_map_var f m_a0) + | Range (m_a0, m_a1) -> + let m_a0' = m_atom_map_var f m_a0 in + let m_a1' = m_atom_map_var f m_a1 in + Range (m_a0', m_a1') + | Interval (m_a0, m_a1) -> + let m_a0' = m_atom_map_var f m_a0 in + let m_a1' = m_atom_map_var f m_a1 in + Interval (m_a0', m_a1') + +and loop_variable_map_var f (m_ch, svl) = + let svl' = List.map (set_value_loop_map_var f) svl in + (m_ch, svl') + +and loop_variables_map_var f = function + | ValueSets lvl -> ValueSets (List.map (loop_variable_map_var f) lvl) + | Ranges lvl -> Ranges (List.map (loop_variable_map_var f) lvl) + +and expr_map_var f = function + | TestInSet (positive, m_e0, values) -> + let m_e0' = m_expr_map_var f m_e0 in + let values' = List.map (set_value_map_var f) values in + TestInSet (positive, m_e0', values') + | Unop (op, m_e0) -> Unop (op, m_expr_map_var f m_e0) + | Comparison (op, m_e0, m_e1) -> + let m_e0' = m_expr_map_var f m_e0 in + let m_e1' = m_expr_map_var f m_e1 in + Comparison (op, m_e0', m_e1') + | Binop (op, m_e0, m_e1) -> + let m_e0' = m_expr_map_var f m_e0 in + let m_e1' = m_expr_map_var f m_e1 in + Binop (op, m_e0', m_e1') + | Conditional (m_e0, m_e1, m_e2_opt) -> + let m_e0' = m_expr_map_var f m_e0 in + let m_e1' = m_expr_map_var f m_e1 in + let m_e2_opt' = Option.map (m_expr_map_var f) m_e2_opt in + Conditional (m_e0', m_e1', m_e2_opt') + | FuncCall (fn, m_el) -> + let m_el' = List.map (m_expr_map_var f) m_el in + FuncCall (fn, m_el') + | FuncCallLoop (fn, m_loop, m_e0) -> + let m_loop' = Pos.map (loop_variables_map_var f) m_loop in + let m_e0' = m_expr_map_var f m_e0 in + FuncCallLoop (fn, m_loop', m_e0') + | Literal l -> Literal l + | Var access -> Var (access_map_var f access) + | Loop (m_loop, m_e0) -> + let m_loop' = Pos.map (loop_variables_map_var f) m_loop in + let m_e0' = m_expr_map_var f m_e0 in + Loop (m_loop', m_e0') + | NbCategory cvm -> NbCategory cvm + | Attribut (m_access, attr) -> + let m_access' = Pos.map (access_map_var f) m_access in + Attribut (m_access', attr) + | Size m_access -> Size (Pos.map (access_map_var f) m_access) + | IsVariable (m_access, name) -> + let m_access' = Pos.map (access_map_var f) m_access in + IsVariable (m_access', name) + | NbAnomalies -> NbAnomalies + | NbDiscordances -> NbDiscordances + | NbInformatives -> NbInformatives + | NbBloquantes -> NbBloquantes + +and m_expr_map_var f e = Pos.map (expr_map_var f) e + +let rec print_arg_map_var f = function + | PrintString s -> PrintString s + | PrintAccess (info, m_a) -> PrintAccess (info, m_access_map_var f m_a) + | PrintIndent m_e0 -> PrintIndent (m_expr_map_var f m_e0) + | PrintExpr (m_e0, i0, i1) -> PrintExpr (m_expr_map_var f m_e0, i0, i1) + +and formula_loop_map_var f m_lvs = Pos.map (loop_variables_map_var f) m_lvs + +and formula_decl_map_var f = function + | VarDecl (m_access, m_e1) -> + let m_access' = m_access_map_var f m_access in + let m_e1' = m_expr_map_var f m_e1 in + VarDecl (m_access', m_e1') + | EventFieldRef (m_e0, m_if, id, v) -> + let m_e0' = m_expr_map_var f m_e0 in + let v' = f v in + EventFieldRef (m_e0', m_if, id, v') + +and formula_map_var f = function + | SingleFormula fd -> SingleFormula (formula_decl_map_var f fd) + | MultipleFormulaes (fl, fd) -> + let fl' = formula_loop_map_var f fl in + let fd' = formula_decl_map_var f fd in + MultipleFormulaes (fl', fd') + +and instr_map_var f g = function + | Affectation m_f -> Affectation (Pos.map (formula_map_var f) m_f) + | IfThenElse (m_e0, m_il0, m_il1) -> + let m_e0' = m_expr_map_var f m_e0 in + let m_il0' = List.map (m_instr_map_var f g) m_il0 in + let m_il1' = List.map (m_instr_map_var f g) m_il1 in + IfThenElse (m_e0', m_il0', m_il1') + | WhenDoElse (m_eil, m_il) -> + let map (m_e0, m_il0, pos) = + let m_e0' = m_expr_map_var f m_e0 in + let m_il0' = List.map (m_instr_map_var f g) m_il0 in + (m_e0', m_il0', pos) + in + let m_eil' = List.map map m_eil in + let m_il' = Pos.map (List.map (m_instr_map_var f g)) m_il in + WhenDoElse (m_eil', m_il') + | ComputeDomain dom -> ComputeDomain dom + | ComputeChaining ch -> ComputeChaining ch + | ComputeVerifs (m_sl, m_e0) -> + let m_e0' = m_expr_map_var f m_e0 in + ComputeVerifs (m_sl, m_e0') + | ComputeTarget (tn, args) -> + let args' = List.map f args in + ComputeTarget (tn, args') + | VerifBlock m_il0 -> VerifBlock (List.map (m_instr_map_var f g) m_il0) + | Print (pr_std, pr_args) -> + let pr_args' = List.map (Pos.map (print_arg_map_var f)) pr_args in + Print (pr_std, pr_args') + | Iterate (v, vl, cvml, m_il) -> + let v' = f v in + let vl' = List.map f vl in + let cvml' = + let map (cvm, m_e) = (cvm, m_expr_map_var f m_e) in + List.map map cvml + in + let m_il' = List.map (m_instr_map_var f g) m_il in + Iterate (v', vl', cvml', m_il') + | Iterate_values (v, e3l, m_il) -> + let v' = f v in + let e3l' = + let map (m_e0, m_e1, m_e2) = + let m_e0' = m_expr_map_var f m_e0 in + let m_e1' = m_expr_map_var f m_e1 in + let m_e2' = m_expr_map_var f m_e2 in + (m_e0', m_e1', m_e2') + in + List.map map e3l + in + let m_il' = List.map (m_instr_map_var f g) m_il in + Iterate_values (v', e3l', m_il') + | Restore (vl, cvml, el, vel, m_il) -> + let vl' = List.map f vl in + let cvml' = + let map (v, cvm, m_e0) = + let v' = f v in + let m_e0' = m_expr_map_var f m_e0 in + (v', cvm, m_e0') + in + List.map map cvml + in + let el' = List.map (m_expr_map_var f) el in + let vel' = + let map (v, m_e0) = + let v' = f v in + let m_e0' = m_expr_map_var f m_e0 in + (v', m_e0') + in + List.map map vel + in + let m_il' = List.map (m_instr_map_var f g) m_il in + Restore (vl', cvml', el', vel', m_il') + | ArrangeEvents (vve_opt, ve_opt, e_opt, m_il) -> + let vve_opt' = + let map (v0, v1, m_e0) = + let v0' = f v0 in + let v1' = f v1 in + let m_e0' = m_expr_map_var f m_e0 in + (v0', v1', m_e0') + in + Option.map map vve_opt + in + let ve_opt' = + let map (v, m_e0) = + let v' = f v in + let m_e0' = m_expr_map_var f m_e0 in + (v', m_e0') + in + Option.map map ve_opt + in + let e_opt' = Option.map (m_expr_map_var f) e_opt in + let m_il' = List.map (m_instr_map_var f g) m_il in + ArrangeEvents (vve_opt', ve_opt', e_opt', m_il') + | RaiseError (m_err, m_s_opt) -> + let m_err' = Pos.map g m_err in + RaiseError (m_err', m_s_opt) + | CleanErrors -> CleanErrors + | ExportErrors -> ExportErrors + | FinalizeErrors -> FinalizeErrors + +and m_instr_map_var f g m_i = Pos.map (instr_map_var f g) m_i + +let get_var_name v = match v with Normal s -> s | Generic s -> s.base + +let get_normal_var = function Normal name -> name | Generic _ -> assert false let format_value_typ fmt t = Pp.string fmt @@ -574,7 +944,8 @@ let format_binop fmt op = | Add -> "+" | Sub -> "-" | Mul -> "*" - | Div -> "/") + | Div -> "/" + | Mod -> "%") let format_comp_op fmt op = Format.pp_print_string fmt @@ -586,12 +957,24 @@ let format_comp_op fmt op = | Eq -> "=" | Neq -> "!=") -let format_set_value format_variable fmt sv = - let open Format in +let format_access form_var form_expr fmt = function + | VarAccess v -> form_var fmt v + | TabAccess (v, m_i) -> + Format.fprintf fmt "%a[%a]" form_var v form_expr (Pos.unmark m_i) + | ConcAccess (m_vn, m_idxf, idx) -> + Format.fprintf fmt "%s{%s, %a}" + (get_var_name (Pos.unmark m_vn)) + (Pos.unmark m_idxf) form_expr (Pos.unmark idx) + | 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 - | 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) + | FloatValue i -> Pp.fpr fmt "%f" (Pos.unmark i) + | 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) let format_func fmt f = Format.pp_print_string fmt @@ -610,6 +993,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 = @@ -618,7 +1002,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 @@ -628,9 +1012,6 @@ 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) | 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) @@ -646,26 +1027,39 @@ 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 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) + | IsVariable (m_acc, name) -> + Format.fprintf fmt "est_variable(%a, %s)" + (format_access form_var form_expr) + (Pos.unmark m_acc) (Pos.unmark name) | 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 + | PrintAccess (info, m_a) -> + let infoStr = match info with Name -> "nom" | Alias -> "alias" in + Format.fprintf fmt "%s(%a)" infoStr + (format_access form_var form_expr) + (Pos.unmark m_a) | PrintIndent e -> Format.fprintf fmt "indenter(%a)" (Pp.unmark (format_expression form_var)) @@ -682,13 +1076,16 @@ let format_print_arg form_var fmt = function (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 (m_access, e) -> + format_access form_var + (format_expression form_var) + fmt (Pos.unmark m_access); + Format.fprintf fmt " = %a" (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 v let format_formula form_var fmt f = match f with @@ -726,7 +1123,7 @@ let rec format_instruction form_var form_err = in aux "" wdl in - let pp_ed fmt (dl, _) = + let pp_ed fmt (Pos.Mark (dl, _)) = Format.fprintf fmt "@[else_do@\n%a@;@]endwhen@;" form_instrs dl in Format.fprintf fmt "%a%a@\n" pp_wdl wdl pp_ed ed @@ -746,8 +1143,7 @@ let rec format_instruction form_var form_err = (Pos.unmark l) (Pp.unmark form_expr) expr | ComputeTarget (tname, targs) -> Format.fprintf fmt "calculer cible %s : avec %a@," (Pos.unmark tname) - (Pp.list_comma (Pp.unmark form_var)) - targs + (Pp.list_comma form_var) targs | Print (std, args) -> let print_cmd = match std with StdOut -> "afficher" | StdErr -> "afficher_erreur" @@ -761,24 +1157,70 @@ let rec format_instruction form_var form_err = (CatVar.Map.pp_keys ()) vcs form_expr (Pos.unmark expr) in Format.fprintf fmt "iterate variable %a@;: %a@;: %a@;: dans (" form_var - (Pos.unmark var) - (Pp.list_comma (Pp.unmark form_var)) - vars + var (Pp.list_comma form_var) vars (Pp.list_space format_var_param) var_params; Format.fprintf fmt "@[ %a@]@\n)@\n" form_instrs itb - | Restore (vars, var_params, rb) -> + | Iterate_values (var, var_intervals, itb) -> + 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 var + (Pp.list_space format_var_intervals) + var_intervals; + Format.fprintf fmt "@[ %a@]@\n)@\n" form_instrs itb + | Restore (vars, var_params, evts, evtfs, rb) -> + let format_vars fmt = function + | [] -> () + | vars -> + Format.fprintf fmt "@;: variables %a" (Pp.list_comma form_var) + vars + in let format_var_param fmt (var, vcs, expr) = - Format.fprintf fmt ": variable %a : categorie %a : avec %a@\n" - (Pp.unmark form_var) var (CatVar.Map.pp_keys ()) vcs form_expr - (Pos.unmark expr) + Format.fprintf fmt "@;: variable %a : categorie %a : avec %a" 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 + let format_evtfs fmt = function + | [] -> () + | evtfs -> + List.iter + (fun (v, e) -> + Format.fprintf fmt "@;: evenement %a : avec %a" 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, a, itb) -> + Format.fprintf fmt "arrange_evenements@;:"; + (match s with + | Some (v0, v1, e) -> + Format.fprintf fmt "trier %a,%a : avec %a@;" form_var v0 form_var v1 + form_expr (Pos.unmark e) + | None -> ()); + (match f with + | Some (v, e) -> + Format.fprintf fmt "filter %a : avec %a@;" form_var 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) (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 948fa9d39..295409640 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -15,6 +15,12 @@ module CatVar : sig type loc = LocComputed | LocBase | LocInput + val pp_loc : Format.formatter -> loc -> unit + + module LocSet : SetExt.T with type elt = loc + + module LocMap : MapExt.T with type key = loc + type data = { id : t; id_str : string; @@ -36,27 +42,26 @@ type value_typ = | Real type loc_tgv = { - loc_id : string; loc_cat : CatVar.loc; loc_idx : int; + loc_tab_idx : int; loc_cat_id : CatVar.t; loc_cat_str : string; loc_cat_idx : int; - loc_int : int; } +type loc_tmp = { loc_idx : int; loc_tab_idx : int; loc_cat_idx : int } + type loc = | LocTgv of string * loc_tgv - | LocTmp of string * int + | LocTmp of string * loc_tmp | LocRef of string * int - | LocArg of string * int - | LocRes of string module Var : sig type id = int type tgv = { - is_table : int option; + table : t Array.t option; alias : string Pos.marked option; (** Input variable have an alias *) descr : string Pos.marked; (** Description taken from the variable declaration *) @@ -66,9 +71,9 @@ module Var : sig typ : value_typ option; } - type scope = Tgv of tgv | Temp of int option | Ref | Arg | Res + and scope = Tgv of tgv | Temp of t Array.t option | Ref - type t = { + and t = { name : string Pos.marked; (** The position is the variable declaration *) id : id; loc : loc; @@ -81,9 +86,13 @@ module Var : sig val name_str : t -> string - val is_table : t -> int option + val get_table : t -> t Array.t option + + val is_table : t -> bool + + val set_table : t -> t Array.t option -> t - val cat_var_loc : t -> CatVar.loc option + val cat_var_loc : t -> CatVar.loc val size : t -> int @@ -103,21 +112,31 @@ module Var : sig val loc_tgv : t -> loc_tgv - val loc_int : t -> int + val loc_cat_idx : t -> int - val is_temp : t -> bool + val set_loc_tgv_idx : t -> CatVar.data -> int -> t - val is_ref : t -> bool + val set_loc_tmp_idx : t -> int -> t + + val loc_idx : t -> int - val is_arg : t -> bool + val set_loc_idx : t -> int -> t - val is_res : t -> bool + val loc_tab_idx : t -> int + + val set_loc_tab_idx : t -> int -> t + + val is_tgv : t -> bool + + val is_temp : t -> bool + + val is_ref : t -> bool val init_loc : CatVar.t -> loc_tgv val new_tgv : name:string Pos.marked -> - is_table:int option -> + table:t Array.t option -> is_given_back:bool -> alias:string Pos.marked option -> descr:string Pos.marked -> @@ -126,12 +145,11 @@ module Var : sig typ:value_typ option -> t - val new_temp : - name:string Pos.marked -> is_table:int option -> loc_int:int -> t + val new_temp : name:string Pos.marked -> table:t Array.t option -> t - val new_ref : name:string Pos.marked -> loc_int:int -> t + val new_ref : name:string Pos.marked -> t - val new_arg : name:string Pos.marked -> loc_int:int -> t + val new_arg : name:string Pos.marked -> t val new_res : name:string Pos.marked -> t @@ -141,13 +159,19 @@ module Var : sig module Set : SetExt.T with type elt = t - module Map : MapExt.T with type key = t + module Map : sig + include MapExt.T with type key = t + end (* val compare_name_ref : (string -> string -> int) ref val compare_name : string -> string -> int*) end +type event_field = { name : string Pos.marked; index : int; is_var : bool } + +type ('n, 'v) event_value = Numeric of 'n | RefVar of 'v + module DomainId : StrSet.T module DomainIdSet : @@ -175,12 +199,44 @@ type verif_domain_data = { vdom_verifiable : bool; } -type verif_domain = verif_domain_data domain +type variable_space = { + vs_id : int; + vs_name : string Pos.marked; + vs_cats : CatVar.loc Pos.marked CatVar.LocMap.t; + vs_by_default : bool; +} -module TargetMap : StrMap.T +type verif_domain = verif_domain_data domain 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 @@ -192,74 +248,64 @@ type literal = Float of float | Undefined number or characters and there can be multiple of them. We have to store all this information. *) +type var_name_generic = { base : string; parameters : char list } +(** For generic variables, we record the list of their lowercase parameters *) + +(** A variable is either generic (with loop parameters) or normal *) +type var_name = Normal of string | Generic of var_name_generic + +type m_var_name = var_name Pos.marked + +type 'v access = + | VarAccess of 'v + | TabAccess of 'v * 'v m_expression + | ConcAccess of m_var_name * string Pos.marked * 'v m_expression + | FieldAccess of 'v m_expression * string Pos.marked * int + +and 'v m_access = 'v access Pos.marked + (** 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 - -(** 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 + | VarValue of 'v m_access + | IntervalValue 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 - | Func of string - -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]) *) | 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 | Conditional of 'v m_expression * 'v m_expression * 'v m_expression option | FuncCall of func Pos.marked * 'v m_expression list | 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 - | Attribut of 'v Pos.marked * string Pos.marked - | Size of 'v Pos.marked + | Attribut of 'v m_access * string Pos.marked + | Size of 'v m_access + | IsVariable of 'v m_access * string Pos.marked | NbAnomalies | NbDiscordances | NbInformatives @@ -284,15 +330,24 @@ 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 +type print_info = Name | Alias + type 'v print_arg = | PrintString of string - | PrintName of 'v Pos.marked - | PrintAlias of 'v Pos.marked + | PrintAccess of print_info * 'v access Pos.marked | PrintIndent of 'v m_expression | PrintExpr of 'v m_expression * int * int @@ -302,7 +357,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 access Pos.marked * 'v m_expression + | EventFieldRef of 'v m_expression * string Pos.marked * int * 'v type 'v formula = | SingleFormula of 'v formula_decl @@ -320,17 +377,28 @@ type ('v, 'e) instruction = | ComputeDomain of string Pos.marked list Pos.marked | ComputeChaining of string Pos.marked | ComputeVerifs of string Pos.marked list Pos.marked * 'v m_expression - | ComputeTarget of string Pos.marked * 'v Pos.marked list + | ComputeTarget of string Pos.marked * 'v list | VerifBlock of ('v, 'e) m_instruction list | Print of print_std * 'v print_arg Pos.marked list | Iterate of - 'v Pos.marked - * 'v Pos.marked list + 'v + * 'v list * (Pos.t CatVar.Map.t * 'v m_expression) list * ('v, 'e) m_instruction list + | Iterate_values of + 'v + * ('v m_expression * '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 + 'v list + * ('v * Pos.t CatVar.Map.t * 'v m_expression) list + * 'v m_expression list + * ('v * 'v m_expression) list + * ('v, 'e) m_instruction list + | ArrangeEvents of + ('v * 'v * 'v m_expression) option + * ('v * 'v m_expression) option + * 'v m_expression option * ('v, 'e) m_instruction list | RaiseError of 'e Pos.marked * string Pos.marked option | CleanErrors @@ -339,11 +407,34 @@ type ('v, 'e) instruction = and ('v, 'e) m_instruction = ('v, 'e) instruction Pos.marked -val set_loc_int : loc -> int -> loc +type ('v, 'e) target = { + target_name : string Pos.marked; + target_file : string option; + target_apps : string Pos.marked StrMap.t; + target_args : 'v list; + target_result : 'v option; + target_tmp_vars : 'v StrMap.t; + target_nb_tmps : int; + target_sz_tmps : int; + target_nb_refs : int; + target_prog : ('v, 'e) m_instruction list; +} + +val target_is_function : ('v, 'e) target -> bool + +val expr_map_var : ('v -> 'w) -> 'v expression -> 'w expression -val set_loc_tgv_cat : loc -> CatVar.loc -> string -> int -> loc +val m_expr_map_var : ('v -> 'w) -> 'v m_expression -> 'w m_expression -val set_loc_tgv_idx : loc -> int -> loc +val instr_map_var : + ('v -> 'w) -> ('e -> 'f) -> ('v, 'e) instruction -> ('w, 'f) instruction + +val m_instr_map_var : + ('v -> 'w) -> ('e -> 'f) -> ('v, 'e) m_instruction -> ('w, 'f) m_instruction + +val get_var_name : var_name -> string + +val get_normal_var : var_name -> string val format_value_typ : Pp.t -> value_typ -> unit @@ -360,7 +451,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 c1d68bc70..99477446e 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -24,6 +24,8 @@ type set_value = Com.Var.t Com.set_value type expression = Com.Var.t Com.expression +type m_expression = expression Pos.marked + (** The definitions here are modeled closely to the source M language. One could also adopt a more lambda-calculus-compatible model with functions used to model tables. *) @@ -32,31 +34,24 @@ type instruction = (Com.Var.t, Com.Error.t) Com.instruction type m_instruction = instruction Pos.marked -type target_data = { - target_name : string Pos.marked; - target_file : string option; - target_apps : string Pos.marked StrMap.t; - target_args : (Com.Var.t * Pos.t) list; - target_result : (Com.Var.t * Pos.t) option; - target_tmp_vars : (Com.Var.t * Pos.t * int option) StrMap.t; - target_nb_tmps : int; - target_sz_tmps : int; - target_nb_refs : int; - target_prog : m_instruction list; -} +type target = (Com.Var.t, Com.Error.t) Com.target type stats = { - nb_calculated : int; + nb_computed : int; nb_base : int; nb_input : int; nb_vars : int; nb_all_tmps : int; nb_all_refs : int; - sz_calculated : int; + sz_computed : int; sz_base : int; sz_input : int; sz_vars : int; sz_all_tmps : int; + nb_all_tables : int; + sz_all_tables : int; + max_nb_args : int; + table_map : Com.Var.t IntMap.t; } type program = { @@ -65,13 +60,20 @@ type program = { program_var_categories : Com.CatVar.data Com.CatVar.Map.t; program_rule_domains : Com.rule_domain Com.DomainIdMap.t; program_verif_domains : Com.verif_domain Com.DomainIdMap.t; + program_dict : Com.Var.t IntMap.t; program_vars : Com.Var.t StrMap.t; + program_alias : Com.Var.t StrMap.t; + program_var_spaces : int StrMap.t; + program_var_spaces_idx : Com.variable_space IntMap.t; + program_var_space_def : Com.variable_space; + 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; program_errors : Com.Error.t StrMap.t; - program_functions : target_data Com.TargetMap.t; - program_targets : target_data Com.TargetMap.t; + program_functions : target StrMap.t; + program_targets : target StrMap.t; program_main_target : string; program_stats : stats; } @@ -96,7 +98,7 @@ let find_var_name_by_alias (p : program) (alias : string Pos.marked) : string = | None -> Errors.raise_spanned_error (Format.asprintf "alias not found: %s" (Pos.unmark alias)) - (Pos.get_position alias) + (Pos.get alias) let find_var_by_name (p : program) (name : string Pos.marked) : Com.Var.t = try StrMap.find (Pos.unmark name) p.program_vars @@ -105,34 +107,45 @@ let find_var_by_name (p : program) (name : string Pos.marked) : Com.Var.t = let name = find_var_name_by_alias p name in StrMap.find name p.program_vars with Not_found -> - Errors.raise_spanned_error "unknown variable" (Pos.get_position name)) + Errors.raise_spanned_error "unknown variable" (Pos.get name)) 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 m_a -> + let a' = expand_functions_access (Pos.unmark m_a) in + Com.VarValue (Pos.same a' m_a) + | value -> value + in + List.map map values + in + Pos.same (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 - Pos.same_pos_as (Comparison (op, new_e1, new_e2)) e + Pos.same (Comparison (op, new_e1, new_e2)) e | Binop (op, e1, e2) -> let new_e1 = expand_functions_expr e1 in let new_e2 = expand_functions_expr e2 in - Pos.same_pos_as (Binop (op, new_e1, new_e2)) e + Pos.same (Binop (op, new_e1, new_e2)) e | Unop (op, e1) -> let new_e1 = expand_functions_expr e1 in - Pos.same_pos_as (Unop (op, new_e1)) e + Pos.same (Unop (op, new_e1)) e | Conditional (e1, e2, e3) -> let new_e1 = expand_functions_expr e1 in 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) -> - let new_e1 = expand_functions_expr e1 in - Pos.same_pos_as (Index (var, new_e1)) e + Pos.same (Conditional (new_e1, new_e2, new_e3)) e + | Var access -> + let e' = Var (expand_functions_access access) in + Pos.same e' e | Literal _ -> e - | Var _ -> e - | FuncCall ((SumFunc, _), args) -> + | FuncCall (Pos.Mark (SumFunc, _), args) -> let expr_opt = List.fold_left (fun acc_opt arg -> @@ -141,82 +154,97 @@ let rec expand_functions_expr (e : 'var Com.expression Pos.marked) : | Some acc -> Some (Binop - ( Pos.same_pos_as Com.Add e, - Pos.same_pos_as acc e, + ( Pos.same Com.Add e, + Pos.same acc e, expand_functions_expr arg ))) None args in let expr = match expr_opt with None -> Literal (Float 0.0) | Some expr -> expr in - Pos.same_pos_as expr e - | FuncCall ((GtzFunc, _), [ arg ]) -> - Pos.same_pos_as + Pos.same expr e + | FuncCall (Pos.Mark (GtzFunc, _), [ arg ]) -> + Pos.same (Comparison - ( Pos.same_pos_as Com.Gt e, + ( Pos.same Com.Gt e, expand_functions_expr arg, - Pos.same_pos_as (Literal (Float 0.0)) e )) + Pos.same (Literal (Float 0.0)) e )) e - | FuncCall ((GtezFunc, _), [ arg ]) -> - Pos.same_pos_as + | FuncCall (Pos.Mark (GtezFunc, _), [ arg ]) -> + Pos.same (Comparison - ( Pos.same_pos_as Com.Gte e, + ( Pos.same Com.Gte e, expand_functions_expr arg, - Pos.same_pos_as (Literal (Float 0.0)) e )) + Pos.same (Literal (Float 0.0)) e )) e - | FuncCall ((((MinFunc | MaxFunc) as f), pos), [ arg1; arg2 ]) -> + | FuncCall ((Pos.Mark ((MinFunc | MaxFunc), _) as fn), [ arg1; arg2 ]) -> let earg1 = expand_functions_expr arg1 in let earg2 = expand_functions_expr arg2 in - Pos.same_pos_as (FuncCall ((f, pos), [ earg1; earg2 ])) e - | FuncCall ((AbsFunc, pos), [ arg ]) -> - Pos.same_pos_as - (FuncCall ((AbsFunc, pos), [ expand_functions_expr arg ])) - e - | FuncCall ((NullFunc, _), [ arg ]) -> - Pos.same_pos_as + Pos.same (FuncCall (fn, [ earg1; earg2 ])) e + | FuncCall ((Pos.Mark (AbsFunc, _) as fn), [ arg ]) -> + Pos.same (FuncCall (fn, [ expand_functions_expr arg ])) e + | FuncCall (Pos.Mark (NullFunc, _), [ arg ]) -> + Pos.same (Comparison - ( Pos.same_pos_as Com.Eq e, + ( Pos.same Com.Eq e, 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 ])) + Pos.same (Literal (Float 0.0)) e )) 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 (FuncCall (fn, List.map expand_functions_expr args)) e + | Attribut (m_a, attr) -> + let a' = expand_functions_access (Pos.unmark m_a) in + let e' = Attribut (Pos.same a' m_a, attr) in + Pos.same e' e + | Size m_a -> + let a' = expand_functions_access (Pos.unmark m_a) in + let e' = Size (Pos.same a' m_a) in + Pos.same e' e + | IsVariable (m_a, name) -> + let a' = expand_functions_access (Pos.unmark m_a) in + let e' = IsVariable (Pos.same a' m_a, name) in + Pos.same e' e + | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes + | FuncCallLoop _ | Loop _ | NbCategory _ -> + e + +and expand_functions_access (access : 'var Com.access) : 'var Com.access = + match access with + | VarAccess _ -> access + | TabAccess (m_v, i) -> + let i' = expand_functions_expr i in + TabAccess (m_v, i') + | ConcAccess (m_v, m_if, i) -> + let i' = expand_functions_expr i in + ConcAccess (m_v, m_if, i') + | FieldAccess (v_i, f, i_f) -> + let m_i = expand_functions_expr v_i in + FieldAccess (m_i, f, i_f) let expand_functions (p : program) : program = let open Com in let update_instrs p_procs = 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) -> - let m_idx_opt = - match v_idx_opt with - | Some v_idx -> Some (expand_functions_expr v_idx) - | None -> None - in + match Pos.unmark m_instr with + | Affectation (Pos.Mark (SingleFormula (VarDecl (m_a, v_expr)), pos)) -> let m_expr = expand_functions_expr v_expr in - (Affectation (SingleFormula (v_id, m_idx_opt, m_expr), pos), instr_pos) - | Affectation _ -> assert false + let m_a' = + let a' = expand_functions_access (Pos.unmark m_a) in + Pos.same a' m_a + in + let form = SingleFormula (VarDecl (m_a', m_expr)) in + Pos.same (Affectation (Pos.mark form pos)) m_instr + | Affectation + (Pos.Mark (SingleFormula (EventFieldRef (v_idx, f, i, v_id)), pos)) -> + let m_idx = expand_functions_expr v_idx in + let form = SingleFormula (EventFieldRef (m_idx, f, i, v_id)) in + Pos.same (Affectation (Pos.mark form pos)) m_instr + | Affectation (Pos.Mark (MultipleFormulaes _, _)) -> assert false | IfThenElse (i, t, e) -> let i' = expand_functions_expr i in let t' = List.map map_instr t in let e' = List.map map_instr e in - (IfThenElse (i', t', e'), instr_pos) + Pos.same (IfThenElse (i', t', e')) m_instr | WhenDoElse (wdl, ed) -> let map_wdl (expr, dl, pos) = let expr' = expand_functions_expr expr in @@ -224,29 +252,31 @@ let expand_functions (p : program) : program = (expr', dl', pos) in let wdl' = List.map map_wdl wdl in - let ed' = Pos.map_under_mark (List.map map_instr) ed in - (WhenDoElse (wdl', ed'), instr_pos) + let ed' = Pos.map (List.map map_instr) ed in + Pos.same (WhenDoElse (wdl', ed')) m_instr | ComputeTarget _ -> m_instr | VerifBlock instrs -> let instrs' = List.map map_instr instrs in - (VerifBlock instrs', instr_pos) + Pos.same (VerifBlock instrs') m_instr | Print (out, pr_args) -> let pr_args' = List.map (fun m_arg -> - let arg, arg_pos = m_arg in - match arg with + match Pos.unmark m_arg with + | Com.PrintAccess (info, m_a) -> + let a' = expand_functions_access (Pos.unmark m_a) in + let m_a' = Pos.same a' m_a in + Pos.same (Com.PrintAccess (info, m_a')) m_arg | Com.PrintIndent e -> let e' = expand_functions_expr e in - (Com.PrintIndent e', arg_pos) + Pos.same (Com.PrintIndent e') m_arg | Com.PrintExpr (e, mi, ma) -> let e' = expand_functions_expr e in - (Com.PrintExpr (e', mi, ma), arg_pos) - | Com.PrintString _ | Com.PrintName _ | Com.PrintAlias _ -> - m_arg) + Pos.same (Com.PrintExpr (e', mi, ma)) m_arg + | Com.PrintString _ -> m_arg) pr_args in - (Print (out, pr_args'), instr_pos) + Pos.same (Print (out, pr_args')) m_instr | Iterate (v_id, vars, var_params, instrs) -> let var_params' = List.map @@ -256,19 +286,53 @@ let expand_functions (p : program) : program = var_params in let instrs' = List.map map_instr instrs in - (Iterate (v_id, vars, var_params', instrs'), instr_pos) - | Restore (vars, filters, instrs) -> - let filters' = + Pos.same (Iterate (v_id, vars, var_params', instrs')) m_instr + | Iterate_values (v_id, var_intervals, instrs) -> + let var_intervals' = List.map - (fun (v, cs, e) -> (v, cs, expand_functions_expr e)) - filters + (fun (e0, e1, step) -> + let e0' = expand_functions_expr e0 in + let e1' = expand_functions_expr e1 in + let step' = expand_functions_expr step in + (e0', e1', step')) + var_intervals + in + let instrs' = List.map map_instr instrs in + Pos.same (Iterate_values (v_id, var_intervals', instrs')) m_instr + | Restore (vars, var_params, evts, evtfs, instrs) -> + let var_params' = + let map (v, cs, e) = (v, cs, expand_functions_expr e) in + List.map map 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 + let instr' = Restore (vars, var_params', evts', evtfs', instrs') in + Pos.same instr' m_instr + | ArrangeEvents (sort, filter, add, 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 add' = Option.map expand_functions_expr add in let instrs' = List.map map_instr instrs in - (Restore (vars, filters', instrs'), instr_pos) + Pos.same (ArrangeEvents (sort', filter', add', instrs')) m_instr | RaiseError _ | CleanErrors | ExportErrors | FinalizeErrors -> m_instr | ComputeDomain _ | ComputeChaining _ | ComputeVerifs _ -> assert false in - Com.TargetMap.map + StrMap.map (fun t -> let target_prog = List.map map_instr t.target_prog in { t with target_prog }) diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 1674a879e..d1f19768e 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -18,35 +18,30 @@ type set_value = Com.Var.t Com.set_value type expression = Com.Var.t Com.expression +type m_expression = expression Pos.marked + type instruction = (Com.Var.t, Com.Error.t) Com.instruction type m_instruction = instruction Pos.marked -type target_data = { - target_name : string Pos.marked; - target_file : string option; - target_apps : string Pos.marked StrMap.t; - target_args : (Com.Var.t * Pos.t) list; - target_result : (Com.Var.t * Pos.t) option; - target_tmp_vars : (Com.Var.t * Pos.t * int option) StrMap.t; - target_nb_tmps : int; - target_sz_tmps : int; - target_nb_refs : int; - target_prog : m_instruction list; -} +type target = (Com.Var.t, Com.Error.t) Com.target type stats = { - nb_calculated : int; + nb_computed : int; nb_base : int; nb_input : int; nb_vars : int; nb_all_tmps : int; nb_all_refs : int; - sz_calculated : int; + sz_computed : int; sz_base : int; sz_input : int; sz_vars : int; sz_all_tmps : int; + nb_all_tables : int; + sz_all_tables : int; + max_nb_args : int; + table_map : Com.Var.t IntMap.t; } type program = { @@ -55,13 +50,20 @@ type program = { program_var_categories : Com.CatVar.data Com.CatVar.Map.t; program_rule_domains : Com.rule_domain Com.DomainIdMap.t; program_verif_domains : Com.verif_domain Com.DomainIdMap.t; + program_dict : Com.Var.t IntMap.t; program_vars : Com.Var.t StrMap.t; + program_alias : Com.Var.t StrMap.t; + program_var_spaces : int StrMap.t; + program_var_spaces_idx : Com.variable_space IntMap.t; + program_var_space_def : Com.variable_space; + 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; program_errors : Com.Error.t StrMap.t; - program_functions : target_data Com.TargetMap.t; - program_targets : target_data Com.TargetMap.t; + program_functions : target StrMap.t; + program_targets : target StrMap.t; program_main_target : string; program_stats : stats; } diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index bb0dd080e..1628090fc 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -29,14 +29,22 @@ module type S = sig type print_ctx = { mutable indent : int; mutable is_newline : bool } + type ctx_var_space = { + input : value Array.t; + computed : value Array.t; + base : value Array.t; + } + type ctx = { - ctx_tgv : value Array.t; + ctx_prog : Mir.program; + mutable ctx_target : Mir.target; + ctx_var_spaces : ctx_var_space Array.t; ctx_tmps : value Array.t; + ctx_tmps_var : Com.Var.t Array.t; mutable ctx_tmps_org : int; - ctx_ref : (Com.Var.t * int) Array.t; + ctx_ref : (Com.Var.t * (Com.Var.t * int)) Array.t; mutable ctx_ref_org : int; - mutable ctx_args : value Array.t list; - mutable ctx_res : value list; + ctx_tab_map : Com.Var.t Array.t; ctx_pr_out : print_ctx; ctx_pr_err : print_ctx; mutable ctx_anos : (Com.Error.t * string option) list; @@ -47,6 +55,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 : (value, Com.Var.t) Com.event_value Array.t Array.t list; } val empty_ctx : Mir.program -> ctx @@ -57,6 +66,9 @@ module type S = sig val update_ctx_with_inputs : ctx -> Com.literal Com.Var.Map.t -> unit + val update_ctx_with_events : + ctx -> (Com.literal, Com.Var.t) Com.event_value StrMap.t list -> unit + type run_error = | NanOrInf of string * Mir.expression Pos.marked | StructuredError of @@ -68,9 +80,9 @@ module type S = sig val compare_numbers : Com.comp_op -> custom_float -> custom_float -> bool - val evaluate_expr : ctx -> Mir.program -> Mir.expression Pos.marked -> value + val evaluate_expr : ctx -> Mir.expression Pos.marked -> value - val evaluate_program : Mir.program -> ctx -> unit + val evaluate_program : ctx -> unit end module Make (N : Mir_number.NumberInterface) (RF : Mir_roundops.RoundOpsFunctor) = @@ -105,14 +117,22 @@ struct type print_ctx = { mutable indent : int; mutable is_newline : bool } + type ctx_var_space = { + input : value Array.t; + computed : value Array.t; + base : value Array.t; + } + type ctx = { - ctx_tgv : value Array.t; + ctx_prog : Mir.program; + mutable ctx_target : Mir.target; + ctx_var_spaces : ctx_var_space Array.t; ctx_tmps : value Array.t; + ctx_tmps_var : Com.Var.t Array.t; mutable ctx_tmps_org : int; - ctx_ref : (Com.Var.t * int) Array.t; + ctx_ref : (Com.Var.t * (Com.Var.t * int)) Array.t; mutable ctx_ref_org : int; - mutable ctx_args : value Array.t list; - mutable ctx_res : value list; + ctx_tab_map : Com.Var.t Array.t; ctx_pr_out : print_ctx; ctx_pr_err : print_ctx; mutable ctx_anos : (Com.Error.t * string option) list; @@ -123,20 +143,48 @@ 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 : (value, Com.Var.t) Com.event_value Array.t Array.t list; } let empty_ctx (p : Mir.program) : ctx = - let dummy_ref = - (Com.Var.new_ref ~name:("", Pos.no_pos) ~loc_int:(-1), -1) + let dummy_var = Com.Var.new_ref ~name:(Pos.without "") in + let dummy_ref = (dummy_var, (dummy_var, -1)) in + let ctx_tab_map = + let init i = IntMap.find i p.program_stats.table_map in + Array.init (IntMap.cardinal p.program_stats.table_map) init + in + let ctx_var_spaces = + let init i = + let vsd = IntMap.find i p.program_var_spaces_idx in + let input = + if Com.CatVar.LocMap.mem Com.CatVar.LocInput vsd.vs_cats then + Array.make p.program_stats.sz_input Undefined + else Array.make 0 Undefined + in + let computed = + if Com.CatVar.LocMap.mem Com.CatVar.LocComputed vsd.vs_cats then + Array.make p.program_stats.sz_computed Undefined + else Array.make 0 Undefined + in + let base = + if Com.CatVar.LocMap.mem Com.CatVar.LocBase vsd.vs_cats then + Array.make p.program_stats.sz_base Undefined + else Array.make 0 Undefined + in + { input; computed; base } + in + Array.init (IntMap.cardinal p.program_var_spaces_idx) init in { - ctx_tgv = Array.make p.program_stats.sz_vars Undefined; + ctx_prog = p; + ctx_target = snd (StrMap.min_binding p.program_targets); + ctx_var_spaces; ctx_tmps = Array.make p.program_stats.sz_all_tmps Undefined; + ctx_tmps_var = Array.make p.program_stats.sz_all_tmps dummy_var; ctx_tmps_org = 0; ctx_ref = Array.make p.program_stats.nb_all_refs dummy_ref; ctx_ref_org = 0; - ctx_args = []; - ctx_res = []; + ctx_tab_map; ctx_pr_out = { indent = 0; is_newline = true }; ctx_pr_err = { indent = 0; is_newline = true }; ctx_anos = []; @@ -147,6 +195,7 @@ struct ctx_nb_bloquantes = 0; ctx_finalized_anos = []; ctx_exported_anos = []; + ctx_events = []; } let literal_to_value (l : Com.literal) : value = @@ -169,11 +218,72 @@ struct | Com.Float f -> Number (N.of_float_input v f)) inputs in + let default_space = + ctx.ctx_var_spaces.(ctx.ctx_prog.program_var_space_def.vs_id) + in Com.Var.Map.iter (fun (var : Com.Var.t) value -> - ctx.ctx_tgv.(Com.Var.loc_int var) <- value) + match Com.Var.cat_var_loc var with + | LocInput -> default_space.input.(Com.Var.loc_idx var) <- value + | LocComputed -> default_space.computed.(Com.Var.loc_idx var) <- value + | LocBase -> default_space.base.(Com.Var.loc_idx var) <- value) value_inputs + let update_ctx_with_events (ctx : ctx) + (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 StrMap.t) = + let nbProgFields = StrMap.cardinal ctx.ctx_prog.program_event_fields in + let map = Array.make nbProgFields (Com.Numeric Undefined) in + for id = 0 to nbProgFields - 1 do + let fname = IntMap.find id ctx.ctx_prog.program_event_field_idxs in + let ef = StrMap.find fname ctx.ctx_prog.program_event_fields in + if ef.is_var then + map.(id) <- + Com.RefVar (snd (StrMap.min_binding ctx.ctx_prog.program_vars)) + done; + let iter' fname ev = + match StrMap.find_opt fname ctx.ctx_prog.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 + 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)) + ctx.ctx_prog.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 ctx.ctx_prog.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 = | NanOrInf of string * Mir.expression Pos.marked | StructuredError of @@ -187,7 +297,7 @@ struct Errors.raise_spanned_error (Format.asprintf "Expression evaluated to %s: %a" v Format_mir.format_expression (Pos.unmark e)) - (Pos.get_position e) + (Pos.get e) | StructuredError (msg, pos, kont) -> raise (Errors.StructuredError (msg, pos, kont)) @@ -209,58 +319,193 @@ struct | Eq -> N.(N.abs (i1 -. i2) <. epsilon) | Neq -> N.(N.abs (i1 -. i2) >=. epsilon) - let get_var ctx (var : Com.Var.t) = - match var.loc with - | LocRef (_, i) -> ctx.ctx_ref.(ctx.ctx_ref_org + i) - | LocTgv (_, { loc_int; _ }) -> (var, loc_int) - | LocTmp (_, i) -> (var, ctx.ctx_tmps_org + i) - | LocArg (_, i) -> (var, i) - | LocRes _ -> (var, -1) - - let get_var_value ctx (var : Com.Var.t) (i : int) = - let var, vi = get_var ctx var in + let get_var (ctx : ctx) (var : Com.Var.t) : Com.Var.t * int = + match var.scope with + | Com.Var.Tgv _ -> (var, 0) + | Com.Var.Temp _ -> (var, ctx.ctx_tmps_org) + | Com.Var.Ref -> snd ctx.ctx_ref.(ctx.ctx_ref_org + Com.Var.loc_idx var) + + let get_var_tab (ctx : ctx) (var : Com.Var.t) (idx : int) : Com.Var.t * int = + let v, vorg = get_var ctx var in + match Com.Var.get_table v with + | Some _ -> + let v' = ctx.ctx_tab_map.(Com.Var.loc_tab_idx v + 1 + idx) in + (v', vorg) + | None -> assert false + + let get_var_value_org (ctx : ctx) (var : Com.Var.t) (org : int) : value = + let vi = org + Com.Var.loc_idx var in match var.scope with - | Com.Var.Tgv _ -> ctx.ctx_tgv.(vi + i) - | Com.Var.Temp _ -> ctx.ctx_tmps.(vi + i) + | Com.Var.Tgv _ -> ( + let var_space = + ctx.ctx_var_spaces.(ctx.ctx_prog.program_var_space_def.vs_id) + in + match Com.Var.cat_var_loc var with + | LocInput -> var_space.input.(vi) + | LocComputed -> var_space.computed.(vi) + | LocBase -> var_space.base.(vi)) + | Com.Var.Temp _ -> ctx.ctx_tmps.(vi) | Com.Var.Ref -> assert false - | Com.Var.Arg -> (List.hd ctx.ctx_args).(vi) - | Com.Var.Res -> List.hd ctx.ctx_res - - let get_var_tab ctx var idx = - match idx with - | Undefined -> Undefined - | Number f -> - let var, _vi = get_var ctx (Pos.unmark var) in - let idx_f = roundf f in - let sz = Com.Var.size var in - if N.(idx_f >=. N.of_int (Int64.of_int sz)) then Undefined - else if N.(idx_f <. N.zero ()) then Number (N.zero ()) - else - let i = Int64.to_int (N.to_int idx_f) in - get_var_value ctx var i + + let get_var_value (ctx : ctx) (var : Com.Var.t) : value = + let var, vorg = get_var ctx var in + let var = + if Com.Var.is_table var then ctx.ctx_tab_map.(Com.Var.loc_tab_idx var + 2) + else var + in + get_var_value_org ctx var vorg + + let set_var_ref (ctx : ctx) (var : Com.Var.t) (ref_val : Com.Var.t * int) : + unit = + match var.loc with + | LocRef (_, i) -> ctx.ctx_ref.(ctx.ctx_ref_org + i) <- (var, ref_val) + | _ -> assert false exception BlockingError - let rec evaluate_expr (ctx : ctx) (p : Mir.program) - (e : Mir.expression Pos.marked) : value = + let get_var_by_name ctx name = + match StrMap.find_opt name ctx.ctx_prog.program_vars with + | Some v -> Some v + | None -> ( + let rec searchTmp i = + if i < ctx.ctx_target.target_nb_tmps then + let v = ctx.ctx_tmps_var.(ctx.ctx_tmps_org - 1 - i) in + if Com.Var.name_str v = name then Some v else searchTmp (i + 1) + else None + in + match searchTmp 0 with + | Some v -> Some v + | None -> + let rec searchRef i = + if i < ctx.ctx_target.target_nb_refs then + let v = fst @@ ctx.ctx_ref.(ctx.ctx_ref_org - 1 - i) in + if Com.Var.name_str v = name then Some v else searchRef (i + 1) + else None + in + searchRef 0) + + let rec get_access_value ctx access = + match access with + | Com.VarAccess v -> get_var_value ctx v + | Com.TabAccess (m_v, m_idx) -> ( + match evaluate_expr ctx m_idx with + | Number z -> + let v, vorg = get_var ctx m_v in + let i = Int64.to_int @@ N.to_int z in + let sz = Com.Var.size v in + if i < 0 then Number (N.zero ()) + else if sz <= i then Undefined + else + let v' = + if Com.Var.is_table v then + ctx.ctx_tab_map.(Com.Var.loc_tab_idx v + 1 + i) + else v + in + get_var_value_org ctx v' vorg + | Undefined -> Undefined) + | Com.ConcAccess (m_vn, m_idxf, idx) -> ( + match evaluate_expr ctx idx with + | Number z -> + let i = Int64.to_int N.(to_int z) in + if 0 <= i then + let prefix = Com.get_normal_var @@ Pos.unmark m_vn in + let name = Strings.concat_int prefix (Pos.unmark m_idxf) i in + match get_var_by_name ctx name with + | Some v -> get_var_value ctx v + | None -> Undefined + else Undefined + | _ -> Undefined) + | Com.FieldAccess (e, _, j) -> ( + match evaluate_expr ctx e with + | Number z -> + 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 -> get_var_value ctx v + else Undefined + | _ -> Undefined) + + and get_access_var ctx access = + match access with + | Com.VarAccess v -> Some v + | Com.TabAccess (m_v, m_i) -> ( + match evaluate_expr ctx m_i with + | Number z -> + let v = fst @@ get_var ctx m_v in + let i = Int64.to_int @@ N.to_int z in + if 0 <= i && i < Com.Var.size v then + if Com.Var.is_table v then + Some ctx.ctx_tab_map.(Com.Var.loc_tab_idx v + 1 + i) + else Some v + else None + | Undefined -> None) + | Com.ConcAccess (m_vn, m_if, m_i) -> ( + match evaluate_expr ctx m_i with + | Number z -> + let i = Int64.to_int @@ N.to_int z in + if 0 <= i then + let prefix = Com.get_normal_var @@ Pos.unmark m_vn in + let name = Strings.concat_int prefix (Pos.unmark m_if) i in + get_var_by_name ctx name + else None + | _ -> None) + | Com.FieldAccess (m_e, _, j) -> ( + match evaluate_expr ctx m_e with + | Number z -> + 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 -> Some v + | Com.Numeric _ -> None + else None + | _ -> None) + + and set_var_value_org (ctx : ctx) (var : Com.Var.t) (org : int) + (value : value) : unit = + let vi = org + Com.Var.loc_idx var in + match var.scope with + | Com.Var.Tgv _ -> ( + let var_space = + ctx.ctx_var_spaces.(ctx.ctx_prog.program_var_space_def.vs_id) + in + match Com.Var.cat_var_loc var with + | LocInput -> var_space.input.(vi) <- value + | LocComputed -> var_space.computed.(vi) <- value + | LocBase -> var_space.base.(vi) <- value) + | Com.Var.Temp _ -> ctx.ctx_tmps.(vi) <- value + | Com.Var.Ref -> assert false + + and set_var_value (ctx : ctx) (var : Com.Var.t) (value : value) : unit = + let v, vorg = get_var ctx var in + if Com.Var.is_table v then + for i = 0 to Com.Var.size v - 1 do + let v' = ctx.ctx_tab_map.(Com.Var.loc_tab_idx v + 1 + i) in + set_var_value_org ctx v' vorg value + done + else set_var_value_org ctx v vorg value + + and set_access ctx access vexpr = + match get_access_var ctx access with + | Some v -> set_var_value ctx v @@ evaluate_expr ctx vexpr + | None -> () + + and evaluate_expr (ctx : ctx) (e : Mir.expression Pos.marked) : value = let comparison op new_e1 new_e2 = match (op, new_e1, new_e2) with - | Com.Gt, _, Undefined | Com.Gt, Undefined, _ -> Undefined - | Com.Gte, _, Undefined | Com.Gte, Undefined, _ -> Undefined - | Com.Lt, _, Undefined | Com.Lt, Undefined, _ -> Undefined - | Com.Lte, _, Undefined | Com.Lte, Undefined, _ -> Undefined - | Com.Eq, _, Undefined | Com.Eq, Undefined, _ -> Undefined - | Com.Neq, _, Undefined | Com.Neq, Undefined, _ -> Undefined + | Com.(Gt | Gte | Lt | Lte | Eq | Neq), _, Undefined + | Com.(Gt | Gte | Lt | Lte | Eq | Neq), Undefined, _ -> + Undefined | op, Number i1, Number i2 -> - Number (real_of_bool (compare_numbers op i1 i2)) + Number (real_of_bool @@ compare_numbers op i1 i2) in let unop op new_e1 = - let open Com in match (op, new_e1) with - | Not, Number b1 -> Number (real_of_bool (not (bool_of_real b1))) - | Minus, Number f1 -> Number N.(zero () -. f1) - | Not, Undefined -> Undefined - | Minus, Undefined -> Undefined + | Com.Not, Number b1 -> Number (real_of_bool (not (bool_of_real b1))) + | Com.Minus, Number f1 -> Number N.(zero () -. f1) + | Com.(Not | Minus), Undefined -> Undefined in let binop op new_e1 new_e2 = let open Com in @@ -278,6 +523,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 @@ -290,162 +538,163 @@ struct try match Pos.unmark e with | Com.TestInSet (positive, e0, values) -> - let new_e0 = evaluate_expr ctx p e0 in + let value0 = evaluate_expr ctx e0 in let or_chain = List.fold_left (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 (Pos.Mark (access, _)) -> + let value = get_access_value ctx access in + comparison Com.Eq value0 value | 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) -> - let val_bn = - Number (N.of_float (float_of_int (Pos.unmark bn))) + let value_i = Number (N.of_float @@ Pos.unmark i) in + comparison Com.Eq value0 value_i + | Com.IntervalValue (bn, en) -> + let value_bn = + Number (N.of_float @@ float_of_int @@ Pos.unmark bn) in - let val_en = - Number (N.of_float (float_of_int (Pos.unmark en))) + let value_en = + Number (N.of_float @@ float_of_int @@ Pos.unmark en) in binop Com.And - (comparison Com.Gte new_e0 val_bn) - (comparison Com.Lte new_e0 val_en) + (comparison Com.Gte value0 value_bn) + (comparison Com.Lte value0 value_en) in binop Com.Or or_chain equal_test) Undefined values in if positive then or_chain else unop Com.Not or_chain | Comparison (op, e1, e2) -> - let new_e1 = evaluate_expr ctx p e1 in - let new_e2 = evaluate_expr ctx p e2 in - comparison (Pos.unmark op) new_e1 new_e2 + let value1 = evaluate_expr ctx e1 in + let value2 = evaluate_expr ctx e2 in + comparison (Pos.unmark op) value1 value2 | Binop (op, e1, e2) -> - let new_e1 = evaluate_expr ctx p e1 in - let new_e2 = evaluate_expr ctx p e2 in - binop (Pos.unmark op) new_e1 new_e2 - | Unop (op, e1) -> - let new_e1 = evaluate_expr ctx p e1 in - unop op new_e1 + let value1 = evaluate_expr ctx e1 in + let value2 = evaluate_expr ctx e2 in + binop (Pos.unmark op) value1 value2 + | Unop (op, e1) -> unop op @@ evaluate_expr ctx e1 | Conditional (e1, e2, e3_opt) -> ( - let new_e1 = evaluate_expr ctx p e1 in - match new_e1 with + match evaluate_expr ctx e1 with | Number z when N.(z =. zero ()) -> ( match e3_opt with | None -> Undefined - | Some e3 -> evaluate_expr ctx p e3) - | Number _ -> evaluate_expr ctx p e2 (* the float is not zero *) + | Some e3 -> evaluate_expr ctx e3) + | Number _ -> evaluate_expr ctx e2 | 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 - | Var var -> get_var_value ctx var 0 - | FuncCall ((ArrFunc, _), [ arg ]) -> ( - let new_arg = evaluate_expr ctx p arg in - match new_arg with + | Var access -> get_access_value ctx access + | FuncCall (Pos.Mark (ArrFunc, _), [ arg ]) -> ( + match evaluate_expr ctx arg with | Number x -> Number (roundf x) - | Undefined -> Undefined - (*nope:Float 0.*)) - | FuncCall ((InfFunc, _), [ arg ]) -> ( - let new_arg = evaluate_expr ctx p arg in - match new_arg with + | Undefined -> Undefined (*nope:Float 0.*)) + | FuncCall (Pos.Mark (InfFunc, _), [ arg ]) -> ( + match evaluate_expr ctx arg with | Number x -> Number (truncatef x) - | Undefined -> Undefined - (*Float 0.*)) - | FuncCall ((PresentFunc, _), [ arg ]) -> ( - match evaluate_expr ctx p arg with + | Undefined -> Undefined (*Float 0.*)) + | FuncCall (Pos.Mark (PresentFunc, _), [ arg ]) -> ( + match evaluate_expr ctx arg with | Undefined -> false_value () | _ -> true_value ()) - | FuncCall ((Supzero, _), [ arg ]) -> ( - match evaluate_expr ctx p arg with + | FuncCall (Pos.Mark (Supzero, _), [ arg ]) -> ( + match evaluate_expr ctx arg with | Undefined -> Undefined | Number f as n -> if compare_numbers Com.Lte f (N.zero ()) then Undefined else n) - | FuncCall ((AbsFunc, _), [ arg ]) -> ( - match evaluate_expr ctx p arg with + | FuncCall (Pos.Mark (AbsFunc, _), [ arg ]) -> ( + match evaluate_expr ctx arg with | Undefined -> Undefined | Number f -> Number (N.abs f)) - | FuncCall ((MinFunc, _), [ arg1; arg2 ]) -> ( - match (evaluate_expr ctx p arg1, evaluate_expr ctx p arg2) with + | FuncCall (Pos.Mark (MinFunc, _), [ arg1; arg2 ]) -> ( + match (evaluate_expr ctx arg1, evaluate_expr ctx arg2) with | Undefined, Undefined -> Undefined | Undefined, Number f | Number f, Undefined -> Number (N.min (N.zero ()) f) | Number fl, Number fr -> Number (N.min fl fr)) - | FuncCall ((MaxFunc, _), [ arg1; arg2 ]) -> ( - match (evaluate_expr ctx p arg1, evaluate_expr ctx p arg2) with + | FuncCall (Pos.Mark (MaxFunc, _), [ arg1; arg2 ]) -> ( + match (evaluate_expr ctx arg1, evaluate_expr ctx arg2) with | Undefined, Undefined -> Undefined | Undefined, Number f | Number f, Undefined -> Number (N.max (N.zero ()) f) | Number fl, Number fr -> Number (N.max fl fr)) - | FuncCall ((Multimax, _), [ arg1; arg2 ]) -> ( - match evaluate_expr ctx p arg1 with + | FuncCall (Pos.Mark (Multimax, _), [ arg1; arg2 ]) -> ( + match evaluate_expr ctx 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 v -> (v, Pos.get_position e) - | _ -> assert false - (* todo: rte *) + | Var access -> get_access_var ctx access + | _ -> 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))) - | 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 - ctx.ctx_args <- atab :: ctx.ctx_args; - ctx.ctx_res <- Undefined :: ctx.ctx_res; - evaluate_target false p ctx fn fd; - ctx.ctx_args <- List.tl ctx.ctx_args; - let res = List.hd ctx.ctx_res in - ctx.ctx_res <- List.tl ctx.ctx_res; - res + | 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 access_index (i : int) : Int64.t option = + let ei = + Pos.same (Com.Literal (Float (float_of_int i))) arg2 + in + let instr = + Pos.same (Com.Var (TabAccess (var_arg2, ei))) arg2 + in + cast_to_int @@ evaluate_expr ctx instr + 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 (Pos.Mark (NbEvents, _), _) -> + let card = Array.length (List.hd ctx.ctx_events) in + Number (N.of_int @@ Int64.of_int @@ card) + | FuncCall (Pos.Mark (Func fn, _), args) -> + let fd = StrMap.find fn ctx.ctx_prog.program_functions in + evaluate_function ctx fd args | 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))) + | Attribut (m_acc, a) -> ( + match get_access_var ctx (Pos.unmark m_acc) with + | Some v -> ( + let v' = fst @@ get_var ctx v in + match StrMap.find_opt (Pos.unmark a) (Com.Var.attrs v') with + | Some l -> Number (N.of_float (float (Pos.unmark l))) + | None -> Undefined) + | None -> Undefined) + | Size m_acc -> ( + match get_access_var ctx (Pos.unmark m_acc) with + | Some v -> + let v' = fst @@ get_var ctx v in + Number (N.of_float @@ float @@ Com.Var.size v') | 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)) + | IsVariable (m_acc, m_name) -> ( + match get_access_var ctx (Pos.unmark m_acc) with + | Some v -> ( + let v' = fst @@ get_var ctx v in + let name = Pos.unmark m_name in + if Com.Var.name_str v' = name then Number (N.one ()) + else + match Com.Var.alias v' with + | Some m_a when Pos.unmark m_a = name -> Number (N.one ()) + | _ -> Number (N.zero ())) + | None -> Number (N.zero ())) | 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)) | 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 @@ -455,10 +704,7 @@ struct raise (Errors.StructuredError ( msg, - pos - @ [ - (Some "Expression raising the error:", Pos.get_position e); - ], + pos @ [ (Some "Expression raising the error:", Pos.get e) ], kont )) else raise (RuntimeError (StructuredError (msg, pos, kont), ctx)) in @@ -475,87 +721,45 @@ struct else raise (RuntimeError (e, ctx)) else out - and set_var_value (p : Mir.program) (ctx : ctx) ((var, vi) : Com.Var.t * int) - (vexpr : Mir.expression Pos.marked) : unit = - let value = evaluate_expr ctx p vexpr in - match Com.Var.is_table var with - | None -> ( - match var.scope with - | Com.Var.Tgv _ -> ctx.ctx_tgv.(vi) <- value - | Com.Var.Temp _ -> ctx.ctx_tmps.(vi) <- value - | Com.Var.Ref -> assert false - | Com.Var.Arg -> (List.hd ctx.ctx_args).(vi) <- value - | Com.Var.Res -> ctx.ctx_res <- value :: List.tl ctx.ctx_res) - | Some sz -> ( - match var.scope with - | Com.Var.Tgv _ -> - for i = 0 to sz - 1 do - ctx.ctx_tgv.(vi + i) <- value - done - | Com.Var.Temp _ -> - for i = 0 to sz - 1 do - ctx.ctx_tmps.(vi + i) <- value - done - | Com.Var.Ref -> assert false - | Com.Var.Arg -> (List.hd ctx.ctx_args).(vi) <- value - | Com.Var.Res -> ctx.ctx_res <- value :: List.tl ctx.ctx_res) - - and set_var_value_tab (p : Mir.program) (ctx : ctx) - ((var, vi) : Com.Var.t * int) (ei : Mir.expression Pos.marked) - (vexpr : Mir.expression Pos.marked) : unit = - match evaluate_expr ctx p ei with - | Undefined -> () - | Number f -> ( - let i = int_of_float (N.to_float f) in - let sz = Com.Var.size var in - if 0 <= i && i < sz then - let value = evaluate_expr ctx p vexpr in - match var.scope with - | Com.Var.Tgv _ -> ctx.ctx_tgv.(vi + i) <- value - | Com.Var.Temp _ -> ctx.ctx_tmps.(vi + i) <- value - | Com.Var.Ref -> assert false - | 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 (canBlock : bool) (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 (Pos.Mark (SingleFormula (VarDecl (m_acc, vexpr)), _)) -> + set_access ctx (Pos.unmark m_acc) vexpr + | Com.Affectation + (Pos.Mark (SingleFormula (EventFieldRef (idx, _, j, var)), _)) -> ( + match evaluate_expr ctx 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 var + | Com.Numeric _ -> ()) + | _ -> ()) + | Com.Affectation (Pos.Mark (Com.MultipleFormulaes _, _)) -> 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 + match evaluate_expr ctx b with + | Number z when N.(z =. zero ()) -> evaluate_stmts canBlock ctx f + | Number _ -> evaluate_stmts canBlock ctx t | Undefined -> ()) | Com.WhenDoElse (wdl, ed) -> let rec aux = function | (expr, dl, _) :: l -> ( - match evaluate_expr ctx p expr with + match evaluate_expr ctx expr with | Number z when N.(z =. zero ()) -> - evaluate_stmts canBlock p ctx (Pos.unmark ed) + evaluate_stmts canBlock ctx (Pos.unmark ed) | Number _ -> - evaluate_stmts canBlock p ctx dl; + evaluate_stmts canBlock ctx dl; aux l | Undefined -> aux l) | [] -> () in aux wdl - | Com.VerifBlock stmts -> evaluate_stmts true p ctx stmts - | Com.ComputeTarget ((tn, _), args) -> - let tf = Com.TargetMap.find tn p.program_targets in - let rec set_args n = function - | [] -> () - | m_a :: al' -> - let a = m_a |> Pos.unmark |> get_var ctx in - ctx.ctx_ref.(ctx.ctx_ref_org + n) <- a; - set_args (n + 1) al' - in - set_args 0 args; - evaluate_target canBlock p ctx tn tf + | Com.VerifBlock stmts -> evaluate_stmts true ctx stmts + | Com.ComputeTarget (Pos.Mark (tn, _), args) -> + let tf = StrMap.find tn ctx.ctx_prog.program_targets in + evaluate_target canBlock ctx tf args | Com.Print (std, args) -> begin let std_fmt, ctx_pr = match std with @@ -586,25 +790,29 @@ struct in aux 0 in + let pr_info info ctx_pr var = + let v = fst @@ get_var ctx var in + match info with + | Com.Name -> pr_raw ctx_pr (Com.Var.name_str v) + | Com.Alias -> pr_raw ctx_pr (Com.Var.alias_str v) + in List.iter (fun (arg : Com.Var.t Com.print_arg Pos.marked) -> match Pos.unmark arg with | PrintString s -> pr_raw ctx_pr s - | PrintName (var, _) -> - let var, _ = get_var ctx var in - pr_raw ctx_pr (Pos.unmark var.name) - | PrintAlias (var, _) -> - let var, _ = get_var ctx var in - pr_raw ctx_pr (Com.Var.alias_str var) + | PrintAccess (info, m_a) -> ( + match get_access_var ctx @@ Pos.unmark m_a with + | Some var -> pr_info info ctx_pr var + | None -> ()) | PrintIndent e -> let diff = - match evaluate_expr ctx p e with + match evaluate_expr ctx e with | Undefined -> 0 - | Number x -> Int64.to_int (N.to_int (roundf x)) + | Number x -> Int64.to_int @@ N.to_int @@ roundf x in ctx_pr.indent <- max 0 (ctx_pr.indent + diff) | PrintExpr (e, mi, ma) -> - let value = evaluate_expr ctx p e in + let value = evaluate_expr ctx e in pr_indent ctx_pr; format_value_prec mi ma std_fmt value) args; @@ -612,84 +820,210 @@ struct | Com.StdOut -> () | Com.StdErr -> Format.pp_print_flush Format.err_formatter () end - | Com.Iterate ((m_var : Com.Var.t Pos.marked), vars, var_params, stmts) -> - let var = Pos.unmark m_var in - let var_i = - match var.loc with LocRef (_, i) -> i | _ -> assert false - in + | Com.Iterate ((var : Com.Var.t), vars, var_params, stmts) -> List.iter - (fun (v, _) -> - ctx.ctx_ref.(ctx.ctx_ref_org + var_i) <- get_var ctx v; - evaluate_stmts canBlock p ctx stmts) + (fun v -> + set_var_ref ctx var (get_var ctx v); + evaluate_stmts canBlock ctx stmts) vars; List.iter (fun (vcs, expr) -> let eval vc _ = StrMap.iter (fun _ v -> - if Com.CatVar.compare (Com.Var.cat v) vc = 0 then ( - ctx.ctx_ref.(ctx.ctx_ref_org + var_i) <- get_var ctx v; - match evaluate_expr ctx p expr with + if + Com.CatVar.compare (Com.Var.cat v) vc = 0 + && not (Com.Var.is_table v) + then ( + set_var_ref ctx var (get_var ctx v); + match evaluate_expr ctx expr with | Number z when N.(z =. one ()) -> - evaluate_stmts canBlock p ctx stmts + evaluate_stmts canBlock ctx stmts | _ -> ())) - p.program_vars + ctx.ctx_prog.program_vars in Com.CatVar.Map.iter eval vcs) var_params - | Com.Restore (vars, var_params, stmts) -> - let backup = - List.fold_left - (fun backup (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 - else - let value = get_var_value ctx v i in - aux ((v, vi + i, value) :: backup) (i + 1) - in - aux backup 0) - [] vars + | Com.Iterate_values ((var : Com.Var.t), var_intervals, stmts) -> + List.iter + (fun (e0, e1, step) -> + match evaluate_expr ctx e0 with + | Number z0 -> ( + match evaluate_expr ctx e1 with + | Number z1 -> ( + match evaluate_expr ctx step with + | Number zStep when not N.(is_zero zStep) -> + let cmp = + if N.(zStep > zero ()) then N.( <=. ) else N.( >=. ) + in + let rec loop i = + if cmp i z1 then ( + set_var_value ctx var (Number i); + evaluate_stmts canBlock ctx stmts; + loop N.(i +. zStep)) + in + loop z0 + | _ -> ()) + | Undefined -> ()) + | Undefined -> ()) + var_intervals + | Com.Restore (vars, var_params, evts, evtfs, stmts) -> + let backup backup_vars var = + let var, vorg = get_var ctx var in + if Com.Var.is_table var then + let sz = Com.Var.size var in + let rec loop backup_vars i = + if i = sz then backup_vars + else + let v = fst @@ get_var_tab ctx var i in + let value = get_var_value_org ctx v vorg in + loop ((v, vorg, value) :: backup_vars) (i + 1) + in + loop backup_vars 0 + else + let value = get_var_value ctx var in + (var, vorg, value) :: backup_vars in - let backup = + let backup_vars = List.fold_left backup [] vars in + let backup_vars = List.fold_left - (fun backup ((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 + (fun backup_vars ((var : Com.Var.t), vcs, expr) -> 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 - else - let value = get_var_value ctx var i in - aux ((v, vi + i, value) :: backup) (i + 1) - in - aux backup 0 - | _ -> backup) - else backup) - p.program_vars backup) - vcs backup) - backup var_params + set_var_ref ctx var (get_var ctx v); + match evaluate_expr ctx expr with + | Number z when N.(z =. one ()) -> backup backup_vars v + | _ -> backup_vars) + else backup_vars) + ctx.ctx_prog.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 expr with + | Number z -> + let i = Int64.to_int @@ N.to_int z in + let events0 = List.hd ctx.ctx_events in + 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 in - evaluate_stmts canBlock p ctx stmts; + let backup_evts = + List.fold_left + (fun backup_evts ((var : Com.Var.t), expr) -> + let events0 = List.hd ctx.ctx_events in + let rec aux backup_evts i = + if i < Array.length events0 then ( + let vi = N.of_int @@ Int64.of_int i in + set_var_value ctx var (Number vi); + match evaluate_expr ctx expr with + | Number z when N.(z =. one ()) -> + 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 + aux backup_evts 0) + backup_evts evtfs + in + evaluate_stmts canBlock ctx stmts; List.iter - (fun ((v : Com.Var.t), i, value) -> - match v.scope with - | Com.Var.Tgv _ -> ctx.ctx_tgv.(i) <- value - | Com.Var.Temp _ -> ctx.ctx_tmps.(i) <- value - | 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 + (fun (v, vorg, value) -> set_var_value_org ctx v vorg value) + backup_vars; + 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 expr with + | Number z when N.(z >. zero ()) -> + let nb = Int64.to_int @@ N.to_int z in + if nb > 0 then + let nbProgFields = + IntMap.cardinal ctx.ctx_prog.program_event_field_idxs + in + let defEvt = + let init id = + let fname = + IntMap.find id ctx.ctx_prog.program_event_field_idxs + in + let ef = + StrMap.find fname ctx.ctx_prog.program_event_fields + in + match ef.is_var with + | true -> + let defVar = + snd + @@ StrMap.min_binding ctx.ctx_prog.program_vars + in + Com.RefVar defVar + | false -> Com.Numeric Undefined + in + Array.init nbProgFields init + in + let init = function + | 0 -> defEvt + | _ -> Array.copy defEvt + in + (List.init nb init, nb) + else ([], 0) + | _ -> ([], 0)) + | None -> ([], 0) + in + let events = + match filter with + | Some (var, expr) -> + 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 + let vi = Number (N.of_int @@ Int64.of_int i) in + set_var_value ctx var vi; + let res' = + match evaluate_expr ctx expr with + | Number z when N.(z =. one ()) -> events0.(i) :: res + | _ -> res + in + aux res' (i + 1) + in + 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 (var0, var1, expr) -> + let sort_fun i _ j _ = + let vi = Number (N.of_int @@ Int64.of_int i) in + set_var_value ctx var0 vi; + let vj = Number (N.of_int @@ Int64.of_int j) in + set_var_value ctx var1 vj; + match evaluate_expr ctx expr with + | Number z when N.(z =. zero ()) -> false + | Number _ -> true + | Undefined -> false + in + Sorting.mergeSort sort_fun nbAdd (Array.length events) events + | None -> ()); + evaluate_stmts canBlock ctx stmts; + ctx.ctx_events <- List.tl ctx.ctx_events | Com.RaiseError (m_err, var_opt) -> let err = Pos.unmark m_err in (match err.typ with @@ -734,34 +1068,71 @@ struct | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> assert false - and evaluate_stmts canBlock (p : Mir.program) (ctx : ctx) - (stmts : Mir.m_instruction list) : unit = - try List.iter (evaluate_stmt canBlock p ctx) stmts + and evaluate_stmts canBlock (ctx : ctx) (stmts : Mir.m_instruction list) : + unit = + try List.iter (evaluate_stmt canBlock ctx) stmts with BlockingError as b_err -> if canBlock then raise b_err - 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; - ctx.ctx_ref_org <- ctx.ctx_ref_org - tf.target_nb_refs; - ctx.ctx_tmps_org <- ctx.ctx_tmps_org - tf.target_sz_tmps - - let evaluate_program (p : Mir.program) (ctx : ctx) : unit = + and evaluate_function (ctx : ctx) (target : Mir.target) + (args : Mir.m_expression list) : value = + let rec set_args n vl el = + match (vl, el) with + | [], [] -> () + | v :: vl', e :: el' -> + let i = ctx.ctx_tmps_org + n + 1 in + ctx.ctx_tmps.(i) <- evaluate_expr ctx e; + ctx.ctx_tmps_var.(i) <- v; + set_args (n + 1) vl' el' + | _ -> assert false + in + set_args 0 target.target_args args; + ctx.ctx_tmps.(ctx.ctx_tmps_org) <- Undefined; + ctx.ctx_tmps_var.(ctx.ctx_tmps_org) <- Option.get target.target_result; + evaluate_target_aux false ctx target; + ctx.ctx_tmps.(ctx.ctx_tmps_org) + + and evaluate_target (canBlock : bool) (ctx : ctx) (target : Mir.target) + (args : Com.Var.t list) : unit = + let rec set_args n = function + | [] -> () + | v :: vl -> + ctx.ctx_ref.(ctx.ctx_ref_org + n) <- (v, get_var ctx v); + set_args (n + 1) vl + in + set_args 0 args; + evaluate_target_aux canBlock ctx target + + and evaluate_target_aux (canBlock : bool) (ctx : ctx) (target : Mir.target) : + unit = + let sav_target = ctx.ctx_target in + ctx.ctx_target <- target; + ctx.ctx_tmps_org <- ctx.ctx_tmps_org + target.target_sz_tmps; + StrMap.iter + (fun _ v -> + let i = ctx.ctx_tmps_org + Com.Var.loc_idx v in + ctx.ctx_tmps.(i) <- Undefined; + ctx.ctx_tmps_var.(i) <- v) + target.target_tmp_vars; + ctx.ctx_ref_org <- ctx.ctx_ref_org + target.target_nb_refs; + evaluate_stmts canBlock ctx target.target_prog; + ctx.ctx_ref_org <- ctx.ctx_ref_org - target.target_nb_refs; + ctx.ctx_tmps_org <- ctx.ctx_tmps_org - target.target_sz_tmps; + ctx.ctx_target <- sav_target + + let evaluate_program (ctx : ctx) : unit = try let main_target = match - Com.TargetMap.find_opt p.program_main_target p.program_targets + StrMap.find_opt ctx.ctx_prog.program_main_target + ctx.ctx_prog.program_targets with | Some t -> t | None -> 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) + ctx.ctx_target <- main_target; + evaluate_target false ctx main_target []; + evaluate_stmt false ctx (Pos.without Com.ExportErrors) with RuntimeError (e, ctx) -> if !exit_on_rte then raise_runtime_as_structured e else raise (RuntimeError (e, ctx)) @@ -861,34 +1232,40 @@ 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 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 Interp.update_ctx_with_inputs ctx inputs; - Interp.evaluate_program p ctx; + Interp.update_ctx_with_events ctx events; + Interp.evaluate_program ctx; let varMap = - let fold name (var : Com.Var.t) res = + let default_space = + ctx.ctx_var_spaces.(ctx.ctx_prog.program_var_space_def.vs_id) + in + 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 + let litt = + match Com.Var.cat_var_loc var with + | LocInput -> default_space.input.(Com.Var.loc_idx var) + | LocComputed -> default_space.computed.(Com.Var.loc_idx var) + | LocBase -> default_space.base.(Com.Var.loc_idx var) in - StrMap.add name fVal res + 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 ctx.ctx_prog.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) let evaluate_expr (p : Mir.program) (e : Mir.expression Pos.marked) (sort : Cli.value_sort) (roundops : Cli.round_ops) : Com.literal = let module Interp = (val get_interp sort roundops : S) in - Interp.value_to_literal (Interp.evaluate_expr (Interp.empty_ctx p) p e) + Interp.value_to_literal (Interp.evaluate_expr (Interp.empty_ctx p) e) diff --git a/src/mlang/m_ir/mir_interpreter.mli b/src/mlang/m_ir/mir_interpreter.mli index 8a087b81c..060380c65 100644 --- a/src/mlang/m_ir/mir_interpreter.mli +++ b/src/mlang/m_ir/mir_interpreter.mli @@ -50,14 +50,22 @@ module type S = sig type print_ctx = { mutable indent : int; mutable is_newline : bool } + type ctx_var_space = { + input : value Array.t; + computed : value Array.t; + base : value Array.t; + } + type ctx = { - ctx_tgv : value Array.t; + ctx_prog : Mir.program; + mutable ctx_target : Mir.target; + ctx_var_spaces : ctx_var_space Array.t; ctx_tmps : value Array.t; + ctx_tmps_var : Com.Var.t Array.t; mutable ctx_tmps_org : int; - ctx_ref : (Com.Var.t * int) Array.t; + ctx_ref : (Com.Var.t * (Com.Var.t * int)) Array.t; mutable ctx_ref_org : int; - mutable ctx_args : value Array.t list; - mutable ctx_res : value list; + ctx_tab_map : Com.Var.t Array.t; ctx_pr_out : print_ctx; ctx_pr_err : print_ctx; mutable ctx_anos : (Com.Error.t * string option) list; @@ -68,6 +76,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 : (value, Com.Var.t) Com.event_value Array.t Array.t list; } (** Interpretation context *) @@ -79,6 +88,9 @@ module type S = sig val update_ctx_with_inputs : ctx -> Com.literal Com.Var.Map.t -> unit + val update_ctx_with_events : + ctx -> (Com.literal, Com.Var.t) Com.event_value StrMap.t list -> unit + (** Interpreter runtime errors *) type run_error = | NanOrInf of string * Mir.expression Pos.marked @@ -94,9 +106,9 @@ module type S = sig (** Returns the comparison between two numbers in the rounding and precision context of the interpreter. *) - val evaluate_expr : ctx -> Mir.program -> Mir.expression Pos.marked -> value + val evaluate_expr : ctx -> Mir.expression Pos.marked -> value - val evaluate_program : Mir.program -> ctx -> unit + val evaluate_program : ctx -> unit end module FloatDefInterp : @@ -156,9 +168,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 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/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 6932d3e58..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 @@ -79,7 +81,7 @@ module IntervalNumber : NumberInterface module RationalNumber : NumberInterface module BigIntFixedPointNumber : functor - (_ : sig + (P : sig val scaling_factor_bits : int ref end) -> NumberInterface diff --git a/src/mlang/m_ir/mir_roundops.mli b/src/mlang/m_ir/mir_roundops.mli index 4b4f8656a..304131bc8 100644 --- a/src/mlang/m_ir/mir_roundops.mli +++ b/src/mlang/m_ir/mir_roundops.mli @@ -38,7 +38,7 @@ module MultiRoundOps : RoundOpsFunctor behavior depends on the sie of the `long` type, this size must be given as an argument (and should be either 32 or 64). *) module MainframeRoundOps : functor - (_ : sig + (L : sig val max_long : Int64.t ref end) -> RoundOpsFunctor diff --git a/src/mlang/test_framework/irj_ast.ml b/src/mlang/test_framework/irj_ast.ml index 785f93c0d..629368596 100644 --- a/src/mlang/test_framework/irj_ast.ml +++ b/src/mlang/test_framework/irj_ast.ml @@ -14,8 +14,7 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -let mk_position sloc : Pos.t = - Pos.make_position (fst sloc).Lexing.pos_fname sloc +let mk_position sloc : Pos.t = Pos.make (fst sloc).Lexing.pos_fname sloc type literal = I of int | F of float diff --git a/src/mlang/test_framework/irj_parser.mly b/src/mlang/test_framework/irj_parser.mly index 3131aee3f..4f0cfada7 100644 --- a/src/mlang/test_framework/irj_parser.mly +++ b/src/mlang/test_framework/irj_parser.mly @@ -108,10 +108,10 @@ rappels: { ignore (entrees_rappels, controles_attendus, resultats_attendus) ; None } variable_and_value: -| var = SYMBOL SLASH value = value NL { ((var, mk_position $loc(var)), (value, mk_position $loc(value))) } +| var = SYMBOL SLASH value = value NL { (Pos.mark var (mk_position $loc(var)), Pos.mark value (mk_position $loc(value))) } calc_error: -| error = SYMBOL NL { (error, mk_position $sloc) } +| error = SYMBOL NL { Pos.mark error (mk_position $sloc) } rappel: | event_nb = integer SLASH @@ -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 189e412f8..dd49135ca 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -15,76 +15,194 @@ 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) : - float StrMap.t * StrSet.t * Com.literal Com.Var.Map.t = - let input_file = - 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 + instance list = + let vars = + let map_init = + try + let ancsded = find_var_of_name program (Pos.without "V_ANCSDED") in + let ancsded_val = Com.Float (float_of_int (!Cli.income_year + 1)) in + Com.Var.Map.one ancsded ancsded_val + with _ -> Com.Var.Map.empty + in List.fold_left - (fun in_f ((var, var_pos), (value, _value_pos)) -> - let var = find_var_of_name program (var, var_pos) in + (fun in_f (Pos.Mark (var, var_pos), Pos.Mark (value, _value_pos)) -> + let var = find_var_of_name program (Pos.mark 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) - (Com.Var.Map.one ancsded ancsded_val) - t.prim.entrees + map_init t.prim.entrees + in + let eventsList rappels = + let from_var vn = + match StrMap.find_opt vn program.program_alias with + | Some var -> Com.RefVar var + | None -> ( + match StrMap.find_opt vn program.program_vars with + | Some var -> Com.RefVar var + | None -> + Cli.error_print "Variable inconnue: %s" vn; + let msg = "Fichier de test incorrect" in + raise (Errors.StructuredError (msg, [], None))) + in + let fromDirection = function + | "R" -> Com.Numeric (Com.Float 0.0) + | "C" -> Com.Numeric (Com.Float 1.0) + | "M" -> Com.Numeric (Com.Float 2.0) + | "P" -> Com.Numeric (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 toNum p = Com.Numeric (Com.Float (float p)) in + let optToNum = function + | Some p -> Com.Numeric (Com.Float (float p)) + | None -> Com.Numeric Com.Undefined + in + let toEvent (rappel : Irj_ast.rappel) = + 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 = - let fold res ((var, _), (value, _)) = + let expVars vars_init = + let fold res (Pos.Mark (var, _), Pos.Mark (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 expAnos 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 Pos.unmark anos_init) in - (expectedVars, expectedAnos, input_file) + let set_trait f vars = + try + let ind_trait = find_var_of_name program (Pos.without "V_IND_TRAIT") in + Com.Var.Map.add ind_trait (Com.Float f) vars + with _ -> vars + in + match t.rapp with + | None -> + let vars = set_trait 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 = set_trait 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 = set_trait 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 expVars, expAnos, input_file = to_MIR_function_and_inputs program t 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 - 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 @@ -102,6 +220,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*) @@ -130,9 +250,9 @@ let check_all_tests (p : Mir.program) (test_dir : string) Errors.format_structured_error (msg, pos); (match kont with None -> () | Some kont -> kont ()); (successes, failures) - | Interp.NanOrInf (msg, (_, pos)) -> + | Interp.NanOrInf (msg, Pos.Mark (_, pos)) -> Cli.error_print "Runtime error in test %s: NanOrInf (%s, %a)" name - msg Pos.format_position pos; + msg Pos.format pos; (successes, failures)) | e -> Cli.error_print "Uncatched exception: %s" (Printexc.to_string e); @@ -142,10 +262,13 @@ let check_all_tests (p : Mir.program) (test_dir : string) 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)) + (* + Array.fold_left (fun acc name -> process name acc) ([], StrMap.empty) arr +*) 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!" @@ -154,3 +277,52 @@ let check_all_tests (p : Mir.program) (test_dir : string) StrMap.iter (fun name nbErr -> Cli.error_print "\t%d errors in files %s" nbErr name) f) + +let check_one_test (p : Mir.program) (name : string) + (value_sort : Cli.value_sort) (round_ops : Cli.round_ops) = + Mir_interpreter.exit_on_rte := false; + (* sort by increasing size, hoping that small files = simple tests *) + 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*) + let is_ok = + let module Interp = (val Mir_interpreter.get_interp value_sort round_ops + : Mir_interpreter.S) + in + try + Cli.debug_flag := false; + check_test p name value_sort round_ops; + Cli.debug_flag := true; + Cli.result_print "%s" name; + None + with + | InterpError nbErr -> Some nbErr + | Errors.StructuredError (msg, pos, kont) -> + Cli.error_print "Error in test %s: %a" name + Errors.format_structured_error (msg, pos); + (match kont with None -> () | Some kont -> kont ()); + Some 0 + | Interp.RuntimeError (run_error, _) -> ( + match run_error with + | Interp.StructuredError (msg, pos, kont) -> + Cli.error_print "Error in test %s: %a" name + Errors.format_structured_error (msg, pos); + (match kont with None -> () | Some kont -> kont ()); + Some 0 + | Interp.NanOrInf (msg, Pos.Mark (_, pos)) -> + Cli.error_print "Runtime error in test %s: NanOrInf (%s, %a)" name + msg Pos.format pos; + Some 0) + | e -> + Cli.error_print "Uncatched exception: %s" (Printexc.to_string e); + raise e + in + (* finish "done!"; *) + Cli.warning_flag := dbg_warning; + Cli.display_time := dbg_time; + match is_ok with + | None -> Cli.result_print "No failure!" + | Some 0 -> Cli.error_print "Unexpected failure" + | Some nbErr -> Cli.error_print "Failure: %d errors in file %s" nbErr name diff --git a/src/mlang/test_framework/test_interpreter.mli b/src/mlang/test_framework/test_interpreter.mli index ab00f3b43..8b7f0dd1f 100644 --- a/src/mlang/test_framework/test_interpreter.mli +++ b/src/mlang/test_framework/test_interpreter.mli @@ -28,3 +28,6 @@ val check_all_tests : (string -> bool) -> unit (** Similar to [check_test] but tests a whole folder full of test files *) + +val check_one_test : + Mir.program -> string -> Cli.value_sort -> Cli.round_ops -> unit diff --git a/src/mlang/utils/errors.ml b/src/mlang/utils/errors.ml index 78a8ef74f..feffb2c51 100644 --- a/src/mlang/utils/errors.ml +++ b/src/mlang/utils/errors.ml @@ -38,7 +38,7 @@ let format_structured_error_gnu_format fmt Format.pp_print_list ~pp_sep:(fun fmt () -> Format.pp_print_newline fmt ()) (fun fmt (pos_msg, pos) -> - Format.fprintf fmt "%a: %s %a\n" Pos.format_position_gnu pos msg + Format.fprintf fmt "%a: %s %a\n" Pos.format_gnu pos msg (fun fmt pos_msg -> match pos_msg with | None -> () diff --git a/src/mlang/utils/mapExt.ml b/src/mlang/utils/mapExt.ml index f3a7bea64..e04b61bed 100644 --- a/src/mlang/utils/mapExt.ml +++ b/src/mlang/utils/mapExt.ml @@ -7,6 +7,10 @@ module type T = sig val from_assoc_list : (key * 'a) list -> 'a t + val union_fst : 'a t -> 'a t -> 'a t + + val union_snd : 'a t -> 'a t -> 'a t + val pp : ?sep:string -> ?pp_key:(Pp.t -> key -> unit) -> @@ -35,6 +39,17 @@ functor let fold map (k, v) = add k v map in List.fold_left fold empty l + let union_fst map0 map1 = + let merge_fun _ vo0 vo1 = + match (vo0, vo1) with + | None, None -> None + | None, Some v | Some v, None -> Some v + | Some v0, Some _v1 -> Some v0 + in + merge merge_fun map0 map1 + + let union_snd map0 map1 = union_fst map1 map0 + let pp ?(sep = "; ") ?(pp_key = Pp.nil) ?(assoc = " => ") (pp_val : Pp.t -> 'a -> unit) (fmt : Pp.t) (map : 'a t) : unit = let pp_content fmt map = diff --git a/src/mlang/utils/mapExt.mli b/src/mlang/utils/mapExt.mli index 018e291f5..f159b7d77 100644 --- a/src/mlang/utils/mapExt.mli +++ b/src/mlang/utils/mapExt.mli @@ -7,6 +7,10 @@ module type T = sig val from_assoc_list : (key * 'a) list -> 'a t + val union_fst : 'a t -> 'a t -> 'a t + + val union_snd : 'a t -> 'a t -> 'a t + val pp : ?sep:string -> ?pp_key:(Pp.t -> key -> unit) -> diff --git a/src/mlang/utils/pos.ml b/src/mlang/utils/pos.ml index d831686f6..f7b8dc9d3 100644 --- a/src/mlang/utils/pos.ml +++ b/src/mlang/utils/pos.ml @@ -19,10 +19,10 @@ type t = { pos_filename : string; pos_loc : Lexing.position * Lexing.position } (** A position in the source code is a file, as well as begin and end location of the form col:line *) -let make_position (f : string) (loc : Lexing.position * Lexing.position) = +let make (f : string) (loc : Lexing.position * Lexing.position) = { pos_filename = f; pos_loc = loc } -let make_position_between (p1 : t) (p2 : t) : t = +let make_between (p1 : t) (p2 : t) : t = if p1.pos_filename <> p2.pos_filename then begin Cli.error_print "Conflicting position filenames: %s <> %s" p1.pos_filename p2.pos_filename; @@ -36,7 +36,7 @@ let make_position_between (p1 : t) (p2 : t) : t = let pos_loc = (b, e) in { p1 with pos_loc } -let format_position_gnu fmt pos = +let format_gnu fmt pos = let s, e = pos.pos_loc in if s.Lexing.pos_lnum = e.Lexing.pos_lnum then Format.fprintf fmt "%s:%d.%d-%d" @@ -52,7 +52,7 @@ let format_position_gnu fmt pos = e.Lexing.pos_lnum (e.Lexing.pos_cnum - e.Lexing.pos_bol + 1) -let format_position_short fmt pos = +let format_short fmt pos = let s, e = pos.pos_loc in if s.Lexing.pos_lnum = e.Lexing.pos_lnum then Format.fprintf fmt "in file %s:%d:%d-%d" @@ -68,7 +68,7 @@ let format_position_short fmt pos = e.Lexing.pos_lnum (e.Lexing.pos_cnum - e.Lexing.pos_bol + 1) -let format_position fmt (pos : t) = +let format fmt (pos : t) = let s, e = pos.pos_loc in Format.fprintf fmt "in file %s, from %d:%d to %d:%d" pos.pos_filename s.Lexing.pos_lnum @@ -76,12 +76,13 @@ let format_position fmt (pos : t) = e.Lexing.pos_lnum (e.Lexing.pos_cnum - e.Lexing.pos_bol + 1) -type 'a marked = 'a * t -(** Everything related to the source code should keep its t stored, to improve +type 'a marked = + | Mark of 'a * t + (** Everything related to the source code should keep its t stored, to improve error messages *) (** Placeholder t *) -let no_pos : t = +let none : t = let zero_pos = { Lexing.pos_fname = ""; @@ -92,15 +93,19 @@ let no_pos : t = in { pos_filename = "unknown t"; pos_loc = (zero_pos, zero_pos) } -let mark pos value = (value, pos) +let without (x : 'a) : 'a marked = Mark (x, none) -let unmark ((x, _) : 'a marked) : 'a = x +let mark value pos = Mark (value, pos) -let get_position ((_, x) : 'a marked) : t = x +let unmark (Mark (x, _) : 'a marked) : 'a = x -let map_under_mark (f : 'a -> 'b) ((x, y) : 'a marked) : 'b marked = (f x, y) +let get (Mark (_, x) : 'a marked) : t = x -let same_pos_as (x : 'a) ((_, y) : 'b marked) : 'a marked = (x, y) +let to_couple (Mark (x, p) : 'a marked) : 'a * t = (x, p) + +let map (f : 'a -> 'b) (Mark (x, y) : 'a marked) : 'b marked = Mark (f x, y) + +let same (x : 'a) (Mark (_, y) : 'b marked) : 'a marked = Mark (x, y) let unmark_option (x : 'a marked option) : 'a option = match x with Some x -> Some (unmark x) | None -> None diff --git a/src/mlang/utils/pos.mli b/src/mlang/utils/pos.mli index c81b68d69..502738268 100644 --- a/src/mlang/utils/pos.mli +++ b/src/mlang/utils/pos.mli @@ -20,33 +20,38 @@ type t -val make_position : string -> Lexing.position * Lexing.position -> t +val make : string -> Lexing.position * Lexing.position -> t -val make_position_between : t -> t -> t +val make_between : t -> t -> t -val format_position_short : Format.formatter -> t -> unit +val format_short : Format.formatter -> t -> unit -val format_position_gnu : Format.formatter -> t -> unit +val format_gnu : Format.formatter -> t -> unit (** Respects https://www.gnu.org/prep/standards/standards.html#Formatting-Error-Messages *) -val format_position : Format.formatter -> t -> unit +val format : Format.formatter -> t -> unit -type 'a marked = 'a * t -(** Everything related to the source code should keep its t stored, to improve +type 'a marked = + | Mark of 'a * t + (** Everything related to the source code should keep its t stored, to improve error messages *) -val no_pos : t +val none : t (** Placeholder t *) -val mark : t -> 'a -> 'a marked +val without : 'a -> 'a marked + +val mark : 'a -> t -> 'a marked val unmark : 'a marked -> 'a -val get_position : 'a marked -> t +val get : 'a marked -> t + +val to_couple : 'a marked -> 'a * t -val map_under_mark : ('a -> 'b) -> 'a marked -> 'b marked +val map : ('a -> 'b) -> 'a marked -> 'b marked -val same_pos_as : 'a -> 'b marked -> 'a marked +val same : 'a -> 'b marked -> 'a marked val unmark_option : 'a marked option -> 'a option 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 diff --git a/src/mlang/utils/sorting.ml b/src/mlang/utils/sorting.ml new file mode 100644 index 000000000..dd703d0e4 --- /dev/null +++ b/src/mlang/utils/sorting.ml @@ -0,0 +1,30 @@ +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 i a.(i) j 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 rec aux a b width = + if width < aEnd then ( + let rec aux' i = + if i < aEnd then ( + merge a i (min (i + width) aEnd) (min (i + (2 * width)) aEnd) b; + aux' (i + (2 * width))) + in + aux' aBeg; + Array.blit b aBeg a aBeg (aEnd - aBeg); + aux a b (2 * width)) + in + aux a b 1 diff --git a/src/mlang/utils/sorting.mli b/src/mlang/utils/sorting.mli new file mode 100644 index 000000000..b716d8a36 --- /dev/null +++ b/src/mlang/utils/sorting.mli @@ -0,0 +1,2 @@ +val mergeSort : + (int -> 'a -> int -> 'a -> bool) -> int -> int -> 'a Array.t -> 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 5ecb5b379..b1bde0473 100644 --- a/src/mlang/utils/strings.ml +++ b/src/mlang/utils/strings.ml @@ -14,6 +14,15 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) +let concat_int str f i = + let is = Pp.spr "%d" (abs i) in + let lis = String.length is in + let lf = String.length f in + if lis >= lf then str ^ is + else + let f' = String.sub f 0 (lf - lis) in + str ^ f' ^ is + (* let sanitize_str (s, p) = String.map (fun c -> @@ -26,6 +35,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 = @@ -53,3 +83,15 @@ let compare_ebcdic str1 str2 = if r <> 0 then r else ebcdic_compare_aux (i + 1) in ebcdic_compare_aux 0 + +let starts_with ~prefix s = + let lp = String.length prefix in + let ls = String.length s in + let rec aux i = i = lp || (prefix.[i] = s.[i] && aux (i + 1)) in + lp <= ls && aux 0 + +let ends_with ~suffix s = + let fp = String.length suffix - 1 in + let fs = String.length s - 1 in + let rec aux i = i = fp + 1 || (suffix.[fs - i] = s.[fp - i] && aux (i + 1)) in + fp <= fs && aux 0 diff --git a/src/mlang/utils/strings.mli b/src/mlang/utils/strings.mli index 9bf044897..a13a6f69c 100644 --- a/src/mlang/utils/strings.mli +++ b/src/mlang/utils/strings.mli @@ -19,6 +19,14 @@ backend compilers such as Java and Python, this function transforms illegal characters with a space. - not useful anymore (for now) *) +val concat_int : string -> string -> int -> string + +val sanitize_c_str : string -> string + val compare_default : string -> string -> int val compare_ebcdic : string -> string -> int + +val starts_with : prefix:string -> string -> bool + +val ends_with : suffix:string -> string -> bool diff --git a/tests/0/test b/tests/0/test new file mode 100644 index 000000000..31c446bda --- /dev/null +++ b/tests/0/test @@ -0,0 +1,16 @@ +#NOM +Test +#ENTREES-PRIMITIF +#CONTROLES-PRIMITIF +#RESULTATS-PRIMITIF +RESULTAT/0 +#ENTREES-RAPPELS +20241015/2/RESULTAT/1/R/17//102024/ +20241015/3/RESULTAT/1980/R/17//102024/ +20241015/7/RESULTAT/1000000/R/17//102024/ +20241115/8/RESULTAT/80000/R/03//112024/ +#CONTROLES-RAPPELS +#RESULTATS-RAPPELS +RESULTAT/0 +## + 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 +## +