Amélioration de la gestion des événements.

examples/dgfip_c/ml_primitif/ml_driver/m.ml

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

examples/dgfip_c/ml_primitif/ml_driver/read_test.ml

@@ -21,14 +21,17 @@ 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
              (String.index_from s
                 ((String.index s '.') + 1) '.'))
     with _ -> 0.0
 
+let convert_float_opt s =
+  let rec isSpc i = i < 0 || (s.[i] = ' ' && isSpc (i - 1)) in
+  if isSpc (String.length s - 1) then None else Some (convert_float s)
+
 let parse_generic s =
   let sl = String.split_on_char '/' s in
   match sl with
@@ -60,6 +63,7 @@ let parse_entree_rap s =
   match sl with
   | [ num_evt; num_rappel; code; montant; sens;
       penalite; base_tl; date_evt; ind20 ] ->
+      if String.length code = 0 then err ();
       let sens_float =
         if String.length sens = 0 then err ();
         match sens.[0] with
@@ -69,10 +73,17 @@ let parse_entree_rap s =
         | 'P' -> 3.0
         | _ -> err ()
       in
-      (convert_float num_evt, convert_float num_rappel,
-       code, convert_float montant, sens_float,
-       convert_float penalite, convert_float base_tl,
-       convert_float date_evt, convert_float ind20) (* TODO: improve *)
+      (
+        convert_float num_evt,
+        convert_float num_rappel,
+        code,
+        convert_float montant,
+        sens_float,
+        convert_float_opt penalite,
+        convert_float_opt base_tl,
+        convert_float date_evt,
+        convert_float_opt ind20
+      ) (* TODO: improve *)
   | _ -> err ()
 
 let read_section_contents f parsefun =

examples/dgfip_c/ml_primitif/ml_driver/stubs.c

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

src/mlang/backend_compilers/bir_to_dgfip_c.ml

@@ -499,7 +499,7 @@ let generate_event_field_def (dgfip_flags : Dgfip_options.flags)
     def_expr
     (D.format_assign dgfip_flags expr_val)
     value_expr;
-  pr "ecris_varinfo(irdata, irdata->events[%s].field_%s_var, %s, %s);" idx_val
+  pr "ecris_varinfo(irdata, irdata->events[%s]->field_%s_var, %s, %s);" idx_val
     (Pos.unmark field) expr_def expr_val;
   pr "@]@;}@;";
   pr "@]@;}";
@@ -605,7 +605,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags)
         Format.fprintf oc
           "@[<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_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 "}@;"

src/mlang/backend_compilers/dgfip_gen_files.ml

@@ -386,7 +386,7 @@ struct S_irdata {
   int sz_err_archive;
   char **err_archive;
   int nb_err_archive;
-  T_event *events;
+  T_event **events;
   int nb_events;
   T_print_context ctx_pr_out;
   T_print_context ctx_pr_err;
@@ -1178,6 +1178,13 @@ void detruis_irdata(T_irdata *irdata) {
   if (irdata->err_finalise != NULL) free(irdata->err_finalise);
   if (irdata->err_sortie != NULL) free(irdata->err_sortie);
   if (irdata->err_archive != NULL) free(irdata->err_archive);
+  if (irdata->events != NULL) {
+    int i = 0;
+    for (i = 0; i < irdata->nb_events; i++) {
+      if (irdata->events[i] != NULL) free(irdata->events[i]);
+    }
+    free(irdata->events);
+  }
   free(irdata);
 }
 
@@ -1618,12 +1625,12 @@ void pr_err_var(T_irdata *irdata, char *nom) {
       Format.fprintf fmt "    return 0;\n";
       Format.fprintf fmt "  }\n";
       if ef.is_var then (
-        Format.fprintf fmt "  info = irdata->events[idx].field_%s_var;\n" f;
+        Format.fprintf fmt "  info = irdata->events[idx]->field_%s_var;\n" f;
         Format.fprintf fmt "  *res_def = lis_varinfo_def(irdata, info);\n";
         Format.fprintf fmt "  *res_val = lis_varinfo_val(irdata, info);\n")
       else (
-        Format.fprintf fmt "  *res_def = irdata->events[idx].field_%s_def;\n" f;
-        Format.fprintf fmt "  *res_val = irdata->events[idx].field_%s_val;\n" f);
+        Format.fprintf fmt "  *res_def = irdata->events[idx]->field_%s_def;\n" f;
+        Format.fprintf fmt "  *res_val = irdata->events[idx]->field_%s_val;\n" f);
       Format.fprintf fmt "  return *res_def;\n";
       Format.fprintf fmt "}\n\n")
     cprog.program_event_fields

src/mlang/test_framework/irj_parser.mly

@@ -124,11 +124,18 @@ rappel:
   month_year = integer SLASH
   decl_2042_rect = INTEGER? NL
   {
+    if String.length variable_code = 0 then
+        error $loc(variable_code) "Invalid value for 'variable_code' (must be non-empty)";
     if direction <> "R" && direction <> "C" && direction <> "M" && direction <> "P" then
       error $loc(direction) ("Unknown value for 'direction' (type of the 'rappel', should be R, C, M or P) : " ^ direction);
-    let p = match penalty_code with Some p -> p | _ -> 0 in
-    if p < 0 || p > 99 then
-      error $loc(direction) ("Invalid value for 'penalty_code' (out of range 0-99) : " ^ (string_of_int p));
+    (match penalty_code with
+    | Some p when p < 0 || 99 < p ->
+        error $loc(penalty_code) ("Invalid value for 'penalty_code' (out of range 0-99) : " ^ (string_of_int p));
+    | _ -> ());
+    (match decl_2042_rect with
+    | Some p when p < 0 || 1 < p ->
+        error $loc(decl_2042_rect) ("Invalid value for 'decl_2042_rect' (out of range 0-1) : " ^ (string_of_int p));
+    | _ -> ());
     {event_nb;
      rappel_nb;
      variable_code;

src/mlang/test_framework/test_interpreter.ml

@@ -46,49 +46,31 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) :
         | None -> vn
       in
       match StrMap.find_opt name program.program_vars with
-      | Some var -> var
+      | Some var -> Com.RefVar var
       | None ->
           Cli.error_print "Variable inconnue: %s" vn;
           raise (Errors.StructuredError ("Fichier de test incorrect", [], None))
     in
     let fromDirection = function
-      | "R" -> Some 0.0
-      | "C" -> Some 1.0
-      | "M" -> Some 2.0
-      | "P" -> Some 3.0
-      | s ->
-          Cli.error_print "Sens du rappel: %s, devrait être parmi R, C, M et P"
-            s;
-          raise (Errors.StructuredError ("Fichier de test incorrect", [], None))
-    in
-    let fromPenalty = function
-      | None -> Some 0.0 (* None *)
-      | Some p when 0 <= p && p <= 99 -> Some (float p)
-      | Some p ->
-          Cli.error_print "Code de pénalité: %d, devrait être entre 0 et 99" p;
-          raise (Errors.StructuredError ("Fichier de test incorrect", [], None))
-    in
-    let from_2042_rect = function
-      | None -> Some 0.0 (* None *)
-      | Some 0 -> Some 0.0
-      | Some 1 -> Some 1.0
-      | Some r ->
-          Cli.error_print
-            "Indicateur de déclaration rectificative: %d, devrait être 0 ou 1" r;
-          raise (Errors.StructuredError ("Fichier de test incorrect", [], None))
+      | "R" -> Com.Numeric (Some 0.0)
+      | "C" -> Com.Numeric (Some 1.0)
+      | "M" -> Com.Numeric (Some 2.0)
+      | "P" -> Com.Numeric (Some 3.0)
+      | _ -> assert false
     in
+    let toNum p = Com.Numeric (Some (float p)) in
+    let optToNum p = Com.Numeric (Option.map float p) in
     let toEvent (rappel : Irj_ast.rappel) =
       IntMap.empty
-      |> IntMap.add 0 (Com.Numeric (Some (float rappel.event_nb)))
-      |> IntMap.add 1 (Com.Numeric (Some (float rappel.rappel_nb)))
-      |> IntMap.add 2 (Com.RefVar (from_var rappel.variable_code))
-      |> IntMap.add 3 (Com.Numeric (Some (float rappel.change_value)))
-      |> IntMap.add 4 (Com.Numeric (fromDirection rappel.direction))
-      |> IntMap.add 5 (Com.Numeric (fromPenalty rappel.penalty_code))
-      |> IntMap.add 6
-           (Com.Numeric (Option.map float rappel.base_tolerance_legale))
-      |> IntMap.add 7 (Com.Numeric (Some (float rappel.month_year)))
-      |> IntMap.add 8 (Com.Numeric (from_2042_rect rappel.decl_2042_rect))
+      |> IntMap.add 0 (toNum rappel.event_nb)
+      |> IntMap.add 1 (toNum rappel.rappel_nb)
+      |> IntMap.add 2 (from_var rappel.variable_code)
+      |> IntMap.add 3 (toNum rappel.change_value)
+      |> IntMap.add 4 (fromDirection rappel.direction)
+      |> IntMap.add 5 (optToNum rappel.penalty_code)
+      |> IntMap.add 6 (optToNum rappel.base_tolerance_legale)
+      |> IntMap.add 7 (toNum rappel.month_year)
+      |> IntMap.add 8 (optToNum rappel.decl_2042_rect)
     in
     List.map toEvent rappels
   in