diff --git a/examples/dgfip_c/ml_primitif/ml_driver/m.ml b/examples/dgfip_c/ml_primitif/ml_driver/m.ml index e15dee7d2..54bd75785 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/m.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/m.ml @@ -148,5 +148,19 @@ external get_err_list : TGV.t -> string list = "ml_get_err_list" external annee_calc : unit -> int = "ml_annee_calc" external export_errs : TGV.t -> unit = "ml_export_errs" external enchainement_primitif : TGV.t -> unit = "ml_enchainement_primitif" -external set_evt_list : TGV.t -> (float * float * string * float * float * float * float * float * float) list-> unit = "ml_set_evt_list" +external set_evt_list : + TGV.t + -> ( + float + * float + * string + * float + * float + * float option + * float option + * float + * float option + ) list + -> unit += "ml_set_evt_list" diff --git a/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml b/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml index 2384728f2..ea326eed5 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/read_test.ml @@ -21,7 +21,6 @@ let convert_int s = try int_of_string s with _ -> 0 let convert_float s = try Float.of_string s - (* with _ -> 0.0 *) with _ -> (* to cope with badly formatted tests *) try Float.of_string (String.sub s 0 @@ -29,6 +28,10 @@ let convert_float s = ((String.index s '.') + 1) '.')) with _ -> 0.0 +let convert_float_opt s = + let rec isSpc i = i < 0 || (s.[i] = ' ' && isSpc (i - 1)) in + if isSpc (String.length s - 1) then None else Some (convert_float s) + let parse_generic s = let sl = String.split_on_char '/' s in match sl with @@ -60,6 +63,7 @@ let parse_entree_rap s = match sl with | [ num_evt; num_rappel; code; montant; sens; penalite; base_tl; date_evt; ind20 ] -> + if String.length code = 0 then err (); let sens_float = if String.length sens = 0 then err (); match sens.[0] with @@ -69,10 +73,17 @@ let parse_entree_rap s = | 'P' -> 3.0 | _ -> err () in - (convert_float num_evt, convert_float num_rappel, - code, convert_float montant, sens_float, - convert_float penalite, convert_float base_tl, - convert_float date_evt, convert_float ind20) (* TODO: improve *) + ( + convert_float num_evt, + convert_float num_rappel, + code, + convert_float montant, + sens_float, + convert_float_opt penalite, + convert_float_opt base_tl, + convert_float date_evt, + convert_float_opt ind20 + ) (* TODO: improve *) | _ -> err () let read_section_contents f parsefun = diff --git a/examples/dgfip_c/ml_primitif/ml_driver/stubs.c b/examples/dgfip_c/ml_primitif/ml_driver/stubs.c index fff6ca7eb..6f2373a0c 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/stubs.c +++ b/examples/dgfip_c/ml_primitif/ml_driver/stubs.c @@ -215,7 +215,7 @@ CAMLprim value ml_enchainement_primitif(value mlTgv) { CAMLprim value ml_set_evt_list(value mlTgv, value mlEvtList) { CAMLparam2(mlTgv, mlEvtList); - CAMLlocal2(mlList, mlEvt); + CAMLlocal3(mlList, mlEvt, mlField); T_irdata *tgv = Tgv_val(mlTgv); int len = 0; @@ -225,7 +225,7 @@ CAMLprim value ml_set_evt_list(value mlTgv, value mlEvtList) { mlList = Field(mlList, 1); } if (len > 0) { - tgv->events = (T_event *)malloc(len * sizeof (T_event)); + tgv->events = (T_event **)malloc(len * sizeof (T_event *)); } else { tgv->events = NULL; } @@ -234,24 +234,54 @@ CAMLprim value ml_set_evt_list(value mlTgv, value mlEvtList) { int i = 0; mlList = mlEvtList; while (mlList != Val_emptylist) { + T_event *evt = (T_event *)malloc(sizeof (T_event)); + tgv->events[i] = evt; mlEvt = Field(mlList, 0); - tgv->events[i].field_numero_def = 1; - tgv->events[i].field_numero_val = Double_val(Field(mlEvt, 0)); - tgv->events[i].field_rappel_def = 1; - tgv->events[i].field_rappel_val = Double_val(Field(mlEvt, 1)); - tgv->events[i].field_code_var = cherche_var(tgv, String_val(Field(mlEvt, 2))); - tgv->events[i].field_montant_def = 1; - tgv->events[i].field_montant_val = Double_val(Field(mlEvt, 3)); - tgv->events[i].field_sens_def = 1; - tgv->events[i].field_sens_val = Double_val(Field(mlEvt, 4)); - tgv->events[i].field_penalite_def = 1; - tgv->events[i].field_penalite_val = Double_val(Field(mlEvt, 5)); - tgv->events[i].field_base_tl_def = 1; - tgv->events[i].field_base_tl_val = Double_val(Field(mlEvt, 6)); - tgv->events[i].field_date_def = 1; - tgv->events[i].field_date_val = Double_val(Field(mlEvt, 7)); - tgv->events[i].field_2042_rect_def = 1; - tgv->events[i].field_2042_rect_val = Double_val(Field(mlEvt, 8)); + + evt->field_numero_def = 1; + evt->field_numero_val = Double_val(Field(mlEvt, 0)); + + evt->field_rappel_def = 1; + evt->field_rappel_val = Double_val(Field(mlEvt, 1)); + + evt->field_code_var = cherche_var(tgv, String_val(Field(mlEvt, 2))); + + evt->field_montant_def = 1; + evt->field_montant_val = Double_val(Field(mlEvt, 3)); + + evt->field_sens_def = 1; + evt->field_sens_val = Double_val(Field(mlEvt, 4)); + + mlField = Field(mlEvt, 5); + if (mlField == Val_none) { + evt->field_penalite_def = 0; + evt->field_penalite_val = 0.0; + } else { + evt->field_penalite_def = 1; + evt->field_penalite_val = Double_val(Some_val(mlField)); + } + + mlField = Field(mlEvt, 6); + if (mlField == Val_none) { + evt->field_base_tl_def = 0; + evt->field_base_tl_val = 0.0; + } else { + evt->field_base_tl_def = 1; + evt->field_base_tl_val = Double_val(Some_val(mlField)); + } + + evt->field_date_def = 1; + evt->field_date_val = Double_val(Field(mlEvt, 7)); + + mlField = Field(mlEvt, 8); + if (mlField == Val_none) { + evt->field_2042_rect_def = 0; + evt->field_2042_rect_val = 0.0; + } else { + evt->field_2042_rect_def = 1; + evt->field_2042_rect_val = Double_val(Some_val(mlField)); + } + i++; mlList = Field(mlList, 1); } diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index ceba8c59a..c69750b27 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -499,7 +499,7 @@ let generate_event_field_def (dgfip_flags : Dgfip_options.flags) def_expr (D.format_assign dgfip_flags expr_val) value_expr; - pr "ecris_varinfo(irdata, irdata->events[%s].field_%s_var, %s, %s);" idx_val + pr "ecris_varinfo(irdata, irdata->events[%s]->field_%s_var, %s, %s);" idx_val (Pos.unmark field) expr_def expr_val; pr "@]@;}@;"; pr "@]@;}"; @@ -605,7 +605,7 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) Format.fprintf oc "@[if(%s && 0 <= idx && idx < irdata->nb_events){@;" print_def; Format.fprintf oc - "print_string(%s, %s, irdata->events[idx].field_%s_var->%s);@]@;" + "print_string(%s, %s, irdata->events[idx]->field_%s_var->%s);@]@;" print_std pr_ctx (Pos.unmark f) name_or_alias; Format.fprintf oc "}@]@;"; Format.fprintf oc "}@;" diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index 62efb06ca..d5278867d 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -386,7 +386,7 @@ struct S_irdata { int sz_err_archive; char **err_archive; int nb_err_archive; - T_event *events; + T_event **events; int nb_events; T_print_context ctx_pr_out; T_print_context ctx_pr_err; @@ -1178,6 +1178,13 @@ void detruis_irdata(T_irdata *irdata) { if (irdata->err_finalise != NULL) free(irdata->err_finalise); if (irdata->err_sortie != NULL) free(irdata->err_sortie); if (irdata->err_archive != NULL) free(irdata->err_archive); + if (irdata->events != NULL) { + int i = 0; + for (i = 0; i < irdata->nb_events; i++) { + if (irdata->events[i] != NULL) free(irdata->events[i]); + } + free(irdata->events); + } free(irdata); } @@ -1618,12 +1625,12 @@ void pr_err_var(T_irdata *irdata, char *nom) { Format.fprintf fmt " return 0;\n"; Format.fprintf fmt " }\n"; if ef.is_var then ( - Format.fprintf fmt " info = irdata->events[idx].field_%s_var;\n" f; + Format.fprintf fmt " info = irdata->events[idx]->field_%s_var;\n" f; Format.fprintf fmt " *res_def = lis_varinfo_def(irdata, info);\n"; Format.fprintf fmt " *res_val = lis_varinfo_val(irdata, info);\n") else ( - Format.fprintf fmt " *res_def = irdata->events[idx].field_%s_def;\n" f; - Format.fprintf fmt " *res_val = irdata->events[idx].field_%s_val;\n" f); + Format.fprintf fmt " *res_def = irdata->events[idx]->field_%s_def;\n" f; + Format.fprintf fmt " *res_val = irdata->events[idx]->field_%s_val;\n" f); Format.fprintf fmt " return *res_def;\n"; Format.fprintf fmt "}\n\n") cprog.program_event_fields diff --git a/src/mlang/test_framework/irj_parser.mly b/src/mlang/test_framework/irj_parser.mly index 3131aee3f..25f00fa6b 100644 --- a/src/mlang/test_framework/irj_parser.mly +++ b/src/mlang/test_framework/irj_parser.mly @@ -124,11 +124,18 @@ rappel: month_year = integer SLASH decl_2042_rect = INTEGER? NL { + if String.length variable_code = 0 then + error $loc(variable_code) "Invalid value for 'variable_code' (must be non-empty)"; if direction <> "R" && direction <> "C" && direction <> "M" && direction <> "P" then error $loc(direction) ("Unknown value for 'direction' (type of the 'rappel', should be R, C, M or P) : " ^ direction); - let p = match penalty_code with Some p -> p | _ -> 0 in - if p < 0 || p > 99 then - error $loc(direction) ("Invalid value for 'penalty_code' (out of range 0-99) : " ^ (string_of_int p)); + (match penalty_code with + | Some p when p < 0 || 99 < p -> + error $loc(penalty_code) ("Invalid value for 'penalty_code' (out of range 0-99) : " ^ (string_of_int p)); + | _ -> ()); + (match decl_2042_rect with + | Some p when p < 0 || 1 < p -> + error $loc(decl_2042_rect) ("Invalid value for 'decl_2042_rect' (out of range 0-1) : " ^ (string_of_int p)); + | _ -> ()); {event_nb; rappel_nb; variable_code; diff --git a/src/mlang/test_framework/test_interpreter.ml b/src/mlang/test_framework/test_interpreter.ml index e084ece05..30ff3886e 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -46,49 +46,31 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : | None -> vn in match StrMap.find_opt name program.program_vars with - | Some var -> var + | Some var -> Com.RefVar var | None -> Cli.error_print "Variable inconnue: %s" vn; raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) in let fromDirection = function - | "R" -> Some 0.0 - | "C" -> Some 1.0 - | "M" -> Some 2.0 - | "P" -> Some 3.0 - | s -> - Cli.error_print "Sens du rappel: %s, devrait être parmi R, C, M et P" - s; - raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) - in - let fromPenalty = function - | None -> Some 0.0 (* None *) - | Some p when 0 <= p && p <= 99 -> Some (float p) - | Some p -> - Cli.error_print "Code de pénalité: %d, devrait être entre 0 et 99" p; - raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) - in - let from_2042_rect = function - | None -> Some 0.0 (* None *) - | Some 0 -> Some 0.0 - | Some 1 -> Some 1.0 - | Some r -> - Cli.error_print - "Indicateur de déclaration rectificative: %d, devrait être 0 ou 1" r; - raise (Errors.StructuredError ("Fichier de test incorrect", [], None)) + | "R" -> Com.Numeric (Some 0.0) + | "C" -> Com.Numeric (Some 1.0) + | "M" -> Com.Numeric (Some 2.0) + | "P" -> Com.Numeric (Some 3.0) + | _ -> assert false in + let toNum p = Com.Numeric (Some (float p)) in + let optToNum p = Com.Numeric (Option.map float p) in let toEvent (rappel : Irj_ast.rappel) = IntMap.empty - |> IntMap.add 0 (Com.Numeric (Some (float rappel.event_nb))) - |> IntMap.add 1 (Com.Numeric (Some (float rappel.rappel_nb))) - |> IntMap.add 2 (Com.RefVar (from_var rappel.variable_code)) - |> IntMap.add 3 (Com.Numeric (Some (float rappel.change_value))) - |> IntMap.add 4 (Com.Numeric (fromDirection rappel.direction)) - |> IntMap.add 5 (Com.Numeric (fromPenalty rappel.penalty_code)) - |> IntMap.add 6 - (Com.Numeric (Option.map float rappel.base_tolerance_legale)) - |> IntMap.add 7 (Com.Numeric (Some (float rappel.month_year))) - |> IntMap.add 8 (Com.Numeric (from_2042_rect rappel.decl_2042_rect)) + |> IntMap.add 0 (toNum rappel.event_nb) + |> IntMap.add 1 (toNum rappel.rappel_nb) + |> IntMap.add 2 (from_var rappel.variable_code) + |> IntMap.add 3 (toNum rappel.change_value) + |> IntMap.add 4 (fromDirection rappel.direction) + |> IntMap.add 5 (optToNum rappel.penalty_code) + |> IntMap.add 6 (optToNum rappel.base_tolerance_legale) + |> IntMap.add 7 (toNum rappel.month_year) + |> IntMap.add 8 (optToNum rappel.decl_2042_rect) in List.map toEvent rappels in