Accesseurs pour les événements.

examples/dgfip_c/ml_primitif/ml_driver/m.ml

@@ -148,4 +148,5 @@ external get_err_list : TGV.t -> string list = "ml_get_err_list"
 external annee_calc : unit -> int = "ml_annee_calc"
 external export_errs : TGV.t -> unit = "ml_export_errs"
 external enchainement_primitif : TGV.t -> unit = "ml_enchainement_primitif"
+external set_evt_list : TGV.t -> (float * float * string * float * float * float * float * float * float) list-> unit = "ml_set_evt_list" 
 

examples/dgfip_c/ml_primitif/ml_driver/main.ml

@@ -3,29 +3,30 @@ open Common
 let read_test filename =
   let test = Read_test.read_test filename in
   let tgv = M.TGV.alloc_tgv () in
-  let res_prim, ctl_prim =
-    let fold_prim (res_prim, ctl_prim) s =
+  let evt_list, res_prim, ctl_prim =
+    let fold_prim (evt_list, res_prim, ctl_prim) s =
       match s with
       | `EntreesPrimitif pl ->
           List.iter (fun (code, montant) -> M.TGV.set tgv code montant) pl;
-          res_prim, ctl_prim
+          evt_list, res_prim, ctl_prim
       | `ResultatsPrimitif pl ->
           let res_prim =
             let fold res (code, montant) = StrMap.add code montant res in
             List.fold_left fold res_prim pl
           in
-          res_prim, ctl_prim
+          evt_list, res_prim, ctl_prim
       | `ControlesPrimitif el ->
           let ctl_prim =
             let fold err e = StrSet.add e err in
             List.fold_left fold ctl_prim el
           in
-          res_prim, ctl_prim
-      | _ -> res_prim, ctl_prim
+          evt_list, res_prim, ctl_prim
+      | `EntreesRappels evt_list -> evt_list, res_prim, ctl_prim
+      | _ -> evt_list, res_prim, ctl_prim
     in
-    List.fold_left fold_prim (StrMap.empty, StrSet.empty) test
+    List.fold_left fold_prim ([], StrMap.empty, StrSet.empty) test
   in
-  tgv, res_prim, ctl_prim
+  tgv, evt_list, res_prim, ctl_prim
 
 let check_result tgv err expected_tgv expected_err =
   let result = ref true in
@@ -130,7 +131,8 @@ let compare_dump out outexp =
 let run_test test_file annee_exec =
   Printf.printf "Testing %s...\n%!" test_file;
   let annee_calc = M.annee_calc () in
-  let tgv, res_prim, ctl_prim = read_test test_file in
+  let tgv, evt_list, res_prim, ctl_prim = read_test test_file in
+  M.set_evt_list tgv evt_list;
   let annee_revenu = M.TGV.get_int_def tgv "ANREV" annee_calc in
   if annee_revenu <> annee_calc then (
     Printf.eprintf

examples/dgfip_c/ml_primitif/ml_driver/read_test.ml

@@ -55,16 +55,25 @@ let parse_entree_corr s =
   | _ -> failwith (Printf.sprintf "Ligne entree correctif invalide: '%s'" s)
 
 let parse_entree_rap s =
+  let err () = failwith (Printf.sprintf "Ligne entree rappel invalide: '%s'" s) in
   let sl = String.split_on_char '/' s in
   match sl with
   | [ num_evt; num_rappel; code; montant; sens;
       penalite; base_tl; date_evt; ind20 ] ->
-      let date_evt = convert_int date_evt in
-      (convert_int num_evt, convert_int num_rappel,
-       code, convert_float montant, sens.[0],
-       convert_int penalite, convert_float base_tl,
-       (date_evt mod 10000, date_evt / 10000), String.equal ind20 "1") (* TODO: improve *)
-  | _ -> failwith (Printf.sprintf "Ligne entree rappel invalide: '%s'" s)
+      let sens_float =
+        if String.length sens = 0 then err ();
+        match sens.[0] with
+        | 'R' -> 0.0
+        | 'C' -> 1.0
+        | 'M' -> 2.0
+        | 'P' -> 3.0
+        | _ -> err ()
+      in
+      (convert_float num_evt, convert_float num_rappel,
+       code, convert_float montant, sens_float,
+       convert_float penalite, convert_float base_tl,
+       convert_float date_evt, convert_float ind20) (* TODO: improve *)
+  | _ -> err ()
 
 let read_section_contents f parsefun =
   let rec aux contents =

examples/dgfip_c/ml_primitif/ml_driver/stubs.c

@@ -213,3 +213,49 @@ CAMLprim value ml_enchainement_primitif(value mlTgv) {
   CAMLreturn(mlErrListOut);
 }
 
+CAMLprim value ml_set_evt_list(value mlTgv, value mlEvtList) {
+  CAMLparam2(mlTgv, mlEvtList);
+  CAMLlocal2(mlList, mlEvt);
+
+  T_irdata *tgv = Tgv_val(mlTgv);
+  int len = 0;
+  mlList = mlEvtList;
+  while (mlList != Val_emptylist) {
+    len++;
+    mlList = Field(mlList, 1);
+  }
+  if (len > 0) {
+    tgv->events = (T_event *)malloc(len * sizeof (T_event));
+  } else {
+    tgv->events = NULL;
+  }
+  tgv->nb_events = len;
+
+  int i = 0;
+  mlList = mlEvtList;
+  while (mlList != Val_emptylist) {
+    mlEvt = Field(mlList, 0);
+    tgv->events[i].field_numero_def = 1;
+    tgv->events[i].field_numero_val = Double_val(Field(mlEvt, 0));
+    tgv->events[i].field_rappel_def = 1;
+    tgv->events[i].field_rappel_val = Double_val(Field(mlEvt, 1));
+    tgv->events[i].field_code_var = cherche_var(tgv, String_val(Field(mlEvt, 2)));
+    tgv->events[i].field_montant_def = 1;
+    tgv->events[i].field_montant_val = Double_val(Field(mlEvt, 3));
+    tgv->events[i].field_sens_def = 1;
+    tgv->events[i].field_sens_val = Double_val(Field(mlEvt, 4));
+    tgv->events[i].field_penalite_def = 1;
+    tgv->events[i].field_penalite_val = Double_val(Field(mlEvt, 5));
+    tgv->events[i].field_base_tl_def = 1;
+    tgv->events[i].field_base_tl_val = Double_val(Field(mlEvt, 6));
+    tgv->events[i].field_date_def = 1;
+    tgv->events[i].field_date_val = Double_val(Field(mlEvt, 7));
+    tgv->events[i].field_2042_rect_def = 1;
+    tgv->events[i].field_2042_rect_val = Double_val(Field(mlEvt, 8));
+    i++;
+    mlList = Field(mlList, 1);
+  }
+  CAMLreturn(Val_unit);
+}
+
+

m_ext/2023/cibles.m

@@ -773,7 +773,6 @@ si nb_discordances() + nb_informatives() > 0 alors
   exporte_erreurs;
 finsi
 
-
 fonction truc:
 application: iliad;
 argument: A0, A1;
@@ -823,6 +822,38 @@ si nb_discordances() + nb_informatives() > 0 alors
 A1 = 3.6;
 calculer cible test_boucle : avec A0, A1;
 afficher_erreur "nb_evenements() = " (nb_evenements()) "\n";
+iterer
+: variable I
+: 0 .. (nb_evenements() - 1) increment 1
+: dans (
+  afficher_erreur (I) ": ";
+  si (present(champ_evenement(I, numero))) alors afficher_erreur (champ_evenement(I, numero)); finsi
+  afficher_erreur "/";
+  si (present(champ_evenement(I, rappel))) alors afficher_erreur (champ_evenement(I, rappel)); finsi
+  afficher_erreur "/" alias(I, code) "," nom(I, code) "/";
+  si (present(champ_evenement(I, montant))) alors afficher_erreur (champ_evenement(I, montant)); finsi
+  afficher_erreur "/";
+  si (present(champ_evenement(I, sens))) alors
+    si (champ_evenement(I, sens) = 0) alors
+      afficher_erreur "R";
+    sinon_si (champ_evenement(I, sens) = 1) alors
+        afficher_erreur "C";
+    sinon_si (champ_evenement(I, sens) = 2) alors
+      afficher_erreur "M";
+    sinon_si (champ_evenement(I, sens) = 3) alors
+      afficher_erreur "P";
+    finsi
+  finsi
+  afficher_erreur "/";
+  si (present(champ_evenement(I, penalite))) alors afficher_erreur (champ_evenement(I, penalite)); finsi
+  afficher_erreur "/";
+  si (present(champ_evenement(I, base_tl))) alors afficher_erreur (champ_evenement(I, base_tl)); finsi
+  afficher_erreur "/";
+  si (present(champ_evenement(I, date))) alors afficher_erreur (champ_evenement(I, date)); finsi
+  afficher_erreur "/";
+  si (present(champ_evenement(I, 2042_rect))) alors afficher_erreur (champ_evenement(I, 2042_rect)); finsi
+  afficher_erreur "\n";
+)
 
 cible enchainement_primitif:
 application: iliad;

src/mlang/backend_compilers/bir_to_dgfip_c.ml

@@ -288,6 +288,10 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) :
         D.dfun "multimax" [ bound.value_comp; D.m_var v2 PassPointer Val ]
       in
       D.build_transitive_composition { set_vars; def_test; value_comp }
+  | FuncCall ((NbEvents, _), _) ->
+      let def_test = D.dinstr "1.0" in
+      let value_comp = D.dinstr "nb_evenements(irdata)" in
+      D.build_transitive_composition { set_vars = []; def_test; value_comp }
   | FuncCall ((Func fn, _), args) ->
       let res = fresh_c_local "result" in
       let def_res = Pp.spr "def_%s" res in
@@ -343,6 +347,33 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) :
           (Format.sprintf "attribut_%s((T_varinfo *)%s)" (Pos.unmark a) ptr)
       in
       D.build_transitive_composition { set_vars = []; def_test; value_comp }
+  | EventField (me, f) ->
+      let fn = Format.sprintf "event_field_%s" (Pos.unmark f) in
+      let res = fresh_c_local "result" in
+      let def_res = Pp.spr "def_%s" res in
+      let val_res = Pp.spr "val_%s" res in
+      let def_res_ptr = Pp.spr "&%s" def_res in
+      let val_res_ptr = Pp.spr "&%s" val_res in
+      let set_vars, arg_exprs =
+        let e = generate_c_expr me in
+        (e.set_vars, [ e.def_test; e.value_comp ])
+      in
+      let d_fun =
+        D.dfun fn
+          ([
+             D.dlow_level "irdata";
+             D.dlow_level def_res_ptr;
+             D.dlow_level val_res_ptr;
+           ]
+          @ arg_exprs)
+      in
+      let set_vars =
+        set_vars
+        @ [ (D.Def, def_res, d_fun); (D.Val, val_res, D.dlow_level val_res) ]
+      in
+      let def_test = D.dinstr def_res in
+      let value_comp = D.dinstr val_res in
+      D.build_transitive_composition { set_vars; def_test; value_comp }
   | Size var ->
       let ptr = VID.gen_info_ptr (Pos.unmark var) in
       let def_test = D.dinstr "1.0" in
@@ -364,8 +395,7 @@ let rec generate_c_expr (e : Mir.expression Pos.marked) :
       let def_test = D.dinstr "1.0" in
       let value_comp = D.dinstr "nb_bloquantes(irdata)" in
       D.build_transitive_composition { set_vars = []; def_test; value_comp }
-  | NbCategory _ -> assert false
-  | FuncCallLoop _ | Loop _ -> assert false
+  | NbCategory _ | FuncCallLoop _ | Loop _ -> assert false
 
 let generate_m_assign (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t)
     (offset : D.offset) (oc : Format.formatter) (se : D.expression_composition)
@@ -517,6 +547,26 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags)
       in
       let print_val = fresh_c_local "mpp_print" in
       let print_def = print_val ^ "_d" in
+      let print_name_or_alias name_or_alias e f =
+        let locals, set, def, value = D.build_expression @@ generate_c_expr e in
+        Format.fprintf oc "@[<v 2>{%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 "@[<v 2>{@;int idx = (int)floor(%s);@; /* prout */"
+          print_val;
+        Format.fprintf oc
+          "@[<v 2>if(%s && 0 <= idx && idx < irdata->nb_events){@;" print_def;
+        Format.fprintf oc
+          "print_string(%s, %s, irdata->events[idx].field_%s_var->%s);@]@;"
+          print_std pr_ctx (Pos.unmark f) name_or_alias;
+        Format.fprintf oc "}@]@;";
+        Format.fprintf oc "}@;"
+      in
       Format.fprintf oc "@[<v 2>{@,char %s;@;double %s;@;" print_def print_val;
       List.iter
         (fun (arg : Com.Var.t Com.print_arg Pos.marked) ->
@@ -532,6 +582,8 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags)
               let ptr = VID.gen_info_ptr var in
               Format.fprintf oc "print_string(%s, %s, %s->alias);@;" print_std
                 pr_ctx ptr
+          | PrintEventName (e, f) -> print_name_or_alias "name" e f
+          | PrintEventAlias (e, f) -> print_name_or_alias "alias" e f
           | PrintIndent e ->
               let locals, set, def, value =
                 D.build_expression @@ generate_c_expr e