Ajout du mot-clé "evenement"

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
+

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" 
 

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

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,14 +23,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
@@ -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 =