diff --git a/Makefile b/Makefile index 755ed41af..965170ffd 100644 --- a/Makefile +++ b/Makefile @@ -39,3 +39,11 @@ clean: FORCE remise_a_zero_versionnage rm -f doc/doc.html dune clean +test: + _build/default/src/main.exe tests/mlang/${test}.m -A test --mpp_function test_args --dgfip_options='' --run_test tests/mlang/${test}.irj --debug + +c: + _build/default/src/main.exe tests/mlang/${test}.m -A app -b dgfip_c --mpp_function target --dgfip_options='' --output output/${test}.c --debug + +t: + dune exec src/main.exe --profile release -- -A iliad --display_time --precision double --income-year=2020 --comparison_error_margin=0.000001 --mpp_function=enchainement_primitif_interpreteur ir-calcul/sources2020m_6_5/tgvI.m ir-calcul/sources2020m_6_5/errI.m ir-calcul/sources2020m_6_5/chap-1.m ir-calcul/sources2020m_6_5/chap-2.m ir-calcul/sources2020m_6_5/chap-3.m ir-calcul/sources2020m_6_5/chap-4.m ir-calcul/sources2020m_6_5/chap-51.m ir-calcul/sources2020m_6_5/chap-52.m ir-calcul/sources2020m_6_5/chap-6.m ir-calcul/sources2020m_6_5/chap-7.m ir-calcul/sources2020m_6_5/chap-81.m ir-calcul/sources2020m_6_5/chap-82.m ir-calcul/sources2020m_6_5/chap-83.m ir-calcul/sources2020m_6_5/chap-84.m ir-calcul/sources2020m_6_5/chap-85.m ir-calcul/sources2020m_6_5/chap-86.m ir-calcul/sources2020m_6_5/chap-87.m ir-calcul/sources2020m_6_5/chap-88.m ir-calcul/sources2020m_6_5/chap-aff.m ir-calcul/sources2020m_6_5/chap-cinr.m ir-calcul/sources2020m_6_5/chap-cmajo.m ir-calcul/sources2020m_6_5/chap-cor.m ir-calcul/sources2020m_6_5/chap-ctl.m ir-calcul/sources2020m_6_5/chap-ini.m ir-calcul/sources2020m_6_5/chap-inr.m ir-calcul/sources2020m_6_5/chap-isf.m ir-calcul/sources2020m_6_5/chap-majo.m ir-calcul/sources2020m_6_5/chap-perp.m ir-calcul/sources2020m_6_5/chap-plaf.m ir-calcul/sources2020m_6_5/chap-taux.m ir-calcul/sources2020m_6_5/chap-teff.m ir-calcul/sources2020m_6_5/chap-thr.m ir-calcul/sources2020m_6_5/chap-tl.m ir-calcul/sources2020m_6_5/coc1.m ir-calcul/sources2020m_6_5/coc2.m ir-calcul/sources2020m_6_5/coc3.m ir-calcul/sources2020m_6_5/coc4.m ir-calcul/sources2020m_6_5/coc5.m ir-calcul/sources2020m_6_5/coc7.m ir-calcul/sources2020m_6_5/coi1.m ir-calcul/sources2020m_6_5/coi2.m ir-calcul/sources2020m_6_5/coi3.m ir-calcul/sources2020m_6_5/horizoc.m ir-calcul/sources2020m_6_5/horizoi.m ir-calcul/sources2020m_6_5/res-ser1.m ir-calcul/sources2020m_6_5/res-ser2.m m_ext/2020/cibles.m --run_test='tests/2020/fuzzing/fuzzer_1423.m_test' --dgfip_options='' --debug diff --git a/ir-calcul b/ir-calcul index 7af2b787a..f521842dc 160000 --- a/ir-calcul +++ b/ir-calcul @@ -1 +1 @@ -Subproject commit 7af2b787ac8aba998c5da59b6f1e7cc76320227c +Subproject commit f521842dcf83dea33df43f1068c13d24b90b9bd9 diff --git a/irj_checker.opam b/irj_checker.opam index a5f3c43f2..0d25f719a 100644 --- a/irj_checker.opam +++ b/irj_checker.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "1.1.0" +version: "%%VERSION%%" synopsis: "IRJ test validation tool" description: "This standalone module performs a syntactic validation of the DGFiP IRJ test format" @@ -10,7 +10,7 @@ license: "GPL-3.0-or-later" homepage: "https://github.com/MLanguage/mlang" bug-reports: "https://github.com/MLanguage/mlang/issues" depends: [ - "ocaml" {>= "4.13.0"} + "ocaml" {>= "4.11.2"} "dune" {build} "odoc" {>= "1.5.3"} "ocamlformat" {= "0.24.1"} diff --git a/mlang.opam b/mlang.opam index af79511af..4df20cb44 100644 --- a/mlang.opam +++ b/mlang.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "1.1.0" +version: "%%VERSION%%" synopsis: "Compiler for DGFiP's M language" description: """ The Direction Générale des Finances Publiques (DGFiP) diff --git a/src/dune b/src/dune index 07489c622..4a30ea5bf 100644 --- a/src/dune +++ b/src/dune @@ -24,3 +24,11 @@ (:standard (:include linking-flags-mlang.sexp))) (libraries mlang)) + +(executable + (name server) + (package mlang) + (public_name server) + (preprocess + (pps lwt_ppx ppx_yojson_conv)) + (libraries mlang dream)) diff --git a/src/irj_checker/irj_checker.ml b/src/irj_checker/irj_checker.ml index 6d7cbc640..9663e07d6 100644 --- a/src/irj_checker/irj_checker.ml +++ b/src/irj_checker/irj_checker.ml @@ -43,7 +43,7 @@ let irj_checker (f : string) (message_format : message_format_enum) if not (Sys.file_exists f && not (Sys.is_directory f)) then Errors.raise_error (Format.asprintf "%s: this path is not a valid file in the filesystem" f); - let test_data = Mlang.Irj_file.parse_file f in + let test_data = Mlang.Irj_file.parse_file (Filename f) in let test_data = match validation_mode with | Primitive -> diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index ba411932a..57db28395 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -16,6 +16,7 @@ module D = DecoupledExpr module VID = Dgfip_varid +module Dgfip_options = Config.Dgfip_options let str_escape str = let l = String.length str in @@ -397,9 +398,9 @@ and generate_c_expr (p : Mir.program) (e : Mir.expression Pos.marked) : 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) -> + | Literal { lit = Float f; _ } -> { set_vars = []; def_test = D.dtrue; value_comp = D.lit f } - | Literal Undefined -> + | Literal { lit = Undefined; _ } -> { set_vars = []; def_test = D.dfalse; value_comp = D.lit 0. } | Var (VarAccess (m_sp_opt, var)) -> let def_test = D.m_var m_sp_opt var Def in diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.mli b/src/mlang/backend_compilers/bir_to_dgfip_c.mli index 6a6fa57d6..d543309f2 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.mli +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.mli @@ -21,4 +21,4 @@ of the output, is built in {!DecoupledExpr}. *) val generate_c_program : - Dgfip_options.flags -> Mir.program -> (* filename *) string -> unit + Config.Dgfip_options.flags -> Mir.program -> (* filename *) string -> unit diff --git a/src/mlang/backend_compilers/decoupledExpr.ml b/src/mlang/backend_compilers/decoupledExpr.ml index 7cbcfaa9c..af8b26fd5 100644 --- a/src/mlang/backend_compilers/decoupledExpr.ml +++ b/src/mlang/backend_compilers/decoupledExpr.ml @@ -1,4 +1,5 @@ module VID = Dgfip_varid +module Dgfip_options = Config.Dgfip_options let generate_variable ?(def_flag = false) ?(trace_flag = false) (m_sp_opt : Com.var_space) (var : Com.Var.t) : string = diff --git a/src/mlang/backend_compilers/decoupledExpr.mli b/src/mlang/backend_compilers/decoupledExpr.mli index 166ffcd26..6313fbc51 100644 --- a/src/mlang/backend_compilers/decoupledExpr.mli +++ b/src/mlang/backend_compilers/decoupledExpr.mli @@ -151,7 +151,10 @@ val build_expression : val format_local_declarations : Format.formatter -> local_decls -> unit val format_assign : - Dgfip_options.flags -> string -> Format.formatter -> t -> unit + Config.Dgfip_options.flags -> string -> Format.formatter -> t -> unit val format_set_vars : - Dgfip_options.flags -> Format.formatter -> (dflag * string * t) list -> unit + Config.Dgfip_options.flags -> + Format.formatter -> + (dflag * string * t) list -> + unit diff --git a/src/mlang/backend_compilers/dgfip_compir_files.ml b/src/mlang/backend_compilers/dgfip_compir_files.ml index 0967de8bf..4b0212234 100644 --- a/src/mlang/backend_compilers/dgfip_compir_files.ml +++ b/src/mlang/backend_compilers/dgfip_compir_files.ml @@ -14,8 +14,10 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) +module Dgfip_options = Config.Dgfip_options + let open_file filename = - let folder = Filename.dirname !Cli.output_file in + let folder = Filename.dirname !Config.output_file in let oc = open_out (Filename.concat folder filename) in let fmt = Format.formatter_of_out_channel oc in (oc, fmt) diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index 77a616149..84e2958a0 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -14,8 +14,10 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) +module Dgfip_options = Config.Dgfip_options + let open_file filename = - let folder = Filename.dirname !Cli.output_file in + let folder = Filename.dirname !Config.output_file in let oc = open_out (Filename.concat folder filename) in let fmt = Format.formatter_of_out_channel oc in (oc, fmt) @@ -270,7 +272,7 @@ typedef struct S_varinfo_map { attrs let is_valid_app apps = - StrMap.exists (fun app _ -> List.mem app !Cli.application_names) apps + StrMap.exists (fun app _ -> List.mem app !Config.application_names) apps let gen_erreurs_c fmt flags (cprog : Mir.program) = Pp.fpr fmt {|/****** LICENCE CECIL *****/ @@ -347,7 +349,7 @@ let gen_conf_h fmt (cprog : Mir.program) flags = FLG_TRACE_IRDATA\n"; *) 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; + Pp.fpr fmt "#define EPSILON %f\n" !Config.comparison_error_margin; let count loc = StrMap.fold (fun _ var nb -> @@ -593,7 +595,7 @@ extern void free_erreur(); #define min(a,b) (((a) <= (b)) ? (a) : (b)) #define max(a,b) (((a) >= (b)) ? (a) : (b)) |}; - Pp.fpr fmt "#define EPSILON %f" !Cli.comparison_error_margin; + Pp.fpr fmt "#define EPSILON %f" !Config.comparison_error_margin; Pp.fpr fmt {| #define GT_E(a,b) ((a) > (b) + EPSILON) diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index 39eeda92f..46e202b81 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -14,12 +14,9 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -open Lexing -open Mlexer - exception Exit -let process_dgfip_options (backend : Cli.backend) +let process_dgfip_options (backend : Config.backend) ~(application_names : string list) (dgfip_options : string list option) = match backend with | Dgfip_c -> begin @@ -38,155 +35,44 @@ let process_dgfip_options (backend : Cli.backend) | Some flags -> flags end end - | UnknownBackend -> Dgfip_options.default_flags - -(* 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). *) -let patch_rule_1 (backend : Cli.backend) (dgfip_flags : Dgfip_options.flags) - (program : Mast.program) : Mast.program = - let open Mast in - let var_exists name = - List.exists - (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 m_access = - Pos.without (Com.VarAccess (None, 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 (VarDecl (m_access, Pos.without litt)) in - Pos.without cmd :: l - else l - in - let oceans, batch, iliad = - match backend with - | Dgfip_c -> - (dgfip_flags.flg_cfir, dgfip_flags.flg_gcos, dgfip_flags.flg_iliad) - | UnknownBackend -> (false, false, true) - in - List.map - (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 (Com.Affectation f) f) - ([] - |> mk_assign "APPLI_OCEANS" oceans - |> mk_assign "APPLI_BATCH" batch - |> mk_assign "APPLI_ILIAD" iliad) - in - let r' = { r with rule_formulaes = r.rule_formulaes @ fl } in - Pos.same (Rule r') m_item - | _ -> m_item)) - program - -let parse () = - let current_progress, finish = Cli.create_progress_bar "Parsing" in - - let parse filebuf source_file = - current_progress source_file; - let lex_curr_p = { filebuf.lex_curr_p with pos_fname = source_file } in - let filebuf = { filebuf with lex_curr_p } in - match Mparser.source_file token filebuf with - | commands -> commands - | exception Mparser.Error -> - Errors.raise_spanned_error "M syntax error" - (Parse_utils.mk_position (filebuf.lex_start_p, filebuf.lex_curr_p)) - in - - let parse_file source_file = - let input = open_in source_file in - let filebuf = Lexing.from_channel input in - try - parse filebuf source_file - (* We're catching exceptions to properly close the input channel *) - with Errors.StructuredError _ as e -> - close_in input; - raise e - in - - let parse_m_dgfip m_program = - if !Cli.without_dgfip_m then m_program - else - let parse_internal str = - let filebuf = Lexing.from_string str in - let source_file = Dgfip_m.internal_m in - parse filebuf source_file - in - let decs = parse_internal Dgfip_m.declarations in - let events = parse_internal Dgfip_m.event_declaration in - events :: decs :: m_program - in - - let parse_m_files m_program = - let parse_file_progress source_file = - current_progress source_file; - parse_file source_file - in - (*FIXME: use a fold here *) - let prog = - List.map parse_file_progress @@ Cli.get_files !Cli.source_files - in - List.rev prog @ m_program - in - - let m_program = - [] |> parse_m_dgfip |> parse_m_files |> List.rev - |> patch_rule_1 !Cli.backend !Cli.dgfip_flags - in - finish "completed!"; - m_program - -(** Entry function for the executable. Returns a negative number in case of - error. *) + | UnknownBackend -> Config.Dgfip_options.default_flags let set_opts (files : string list) (application_names : string list) (without_dgfip_m : bool) (debug : bool) (var_info_debug : string list) - (display_time : bool) (dep_graph_file : string) (print_cycles : bool) - (backend : string option) (output : string option) - (run_tests : string option) (dgfip_test_filter : bool) - (run_test : string option) (mpp_function : string) - (optimize_unsafe_float : bool) (precision : string option) - (roundops : string option) (comparison_error_margin : float option) - (income_year : int option) (m_clean_calls : bool) - (dgfip_options : string list option) = + (display_time : bool) (print_cycles : bool) (backend : string option) + (output : string option) (run_tests : string option) + (dgfip_test_filter : bool) (run_test : string option) + (mpp_function : string) (optimize_unsafe_float : bool) + (precision : string option) (roundops : string option) + (comparison_error_margin : float option) (income_year : int) + (m_clean_calls : bool) (dgfip_options : string list option) = let value_sort = let precision = Option.get precision in - if precision = "double" then Cli.RegularFloat + if precision = "double" then Config.RegularFloat else let mpfr_regex = Re.Pcre.regexp "^mpfr(\\d+)$" in if Re.Pcre.pmatch ~rex:mpfr_regex precision then let mpfr_prec = Re.Pcre.get_substring (Re.Pcre.exec ~rex:mpfr_regex precision) 1 in - Cli.MPFR (int_of_string mpfr_prec) - else if precision = "interval" then Cli.Interval + Config.MPFR (int_of_string mpfr_prec) + else if precision = "interval" then Config.Interval else let bigint_regex = Re.Pcre.regexp "^fixed(\\d+)$" in if Re.Pcre.pmatch ~rex:bigint_regex precision then let fixpoint_prec = Re.Pcre.get_substring (Re.Pcre.exec ~rex:bigint_regex precision) 1 in - Cli.BigInt (int_of_string fixpoint_prec) - else if precision = "mpq" then Cli.Rational + Config.BigInt (int_of_string fixpoint_prec) + else if precision = "mpq" then Config.Rational else Errors.raise_error (Format.asprintf "Unkown precision option: %s" precision) in let round_ops = match roundops with - | Some "default" -> Cli.RODefault - | Some "multi" -> Cli.ROMulti + | Some "default" -> Config.RODefault + | Some "multi" -> Config.ROMulti | Some roundops -> let mf_regex = Re.Pcre.regexp "^mainframe(\\d+)$" in if Re.Pcre.pmatch ~rex:mf_regex roundops then @@ -194,7 +80,7 @@ let set_opts (files : string list) (application_names : string list) Re.Pcre.get_substring (Re.Pcre.exec ~rex:mf_regex roundops) 1 in match int_of_string mf_long_size with - | (32 | 64) as sz -> Cli.ROMainframe sz + | (32 | 64) as sz -> Config.ROMainframe sz | _ -> Errors.raise_error (Format.asprintf "Invalid long size for mainframe: %s" @@ -205,69 +91,68 @@ let set_opts (files : string list) (application_names : string list) | None -> Errors.raise_error @@ Format.asprintf "Unspecified roundops@." in let backend = - match backend with Some "dgfip_c" -> Cli.Dgfip_c | _ -> UnknownBackend + match backend with Some "dgfip_c" -> Config.Dgfip_c | _ -> UnknownBackend in let execution_mode = match (run_tests, run_test) with - | Some s, _ -> Cli.MultipleTests s - | None, Some s -> Cli.SingleTest s - | None, None -> Cli.Extraction + | Some s, _ -> Config.MultipleTests s + | None, Some s -> Config.SingleTest s + | None, None -> Config.Extraction in let files = match List.length files with | 0 -> Errors.raise_error "please provide at least one M source file" - | _ -> Cli.NonEmpty files + | _ -> Config.NonEmpty files in let dgfip_flags = - process_dgfip_options backend ~application_names dgfip_options + process_dgfip_options !Config.backend ~application_names dgfip_options in - Cli.set_all_arg_refs files application_names without_dgfip_m debug - var_info_debug display_time dep_graph_file print_cycles output - optimize_unsafe_float m_clean_calls comparison_error_margin income_year - value_sort round_ops backend dgfip_test_filter mpp_function dgfip_flags - execution_mode + Config.set_all_arg_refs files application_names without_dgfip_m debug + var_info_debug display_time print_cycles output optimize_unsafe_float + m_clean_calls comparison_error_margin income_year value_sort round_ops + backend dgfip_test_filter mpp_function dgfip_flags execution_mode let run_single_test m_program test = Mir_interpreter.repl_debug := true; - ignore - (Test_interpreter.check_one_test m_program test !Cli.value_sort - !Cli.round_ops); - Test_interpreter.check_one_test m_program test !Cli.value_sort !Cli.round_ops; + Test_interpreter.check_one_test m_program test !Config.value_sort + !Config.round_ops; Cli.result_print "Test passed!" let run_multiple_tests m_program tests = let filter_function = - match !Cli.dgfip_test_filter with + match !Config.dgfip_test_filter with | false -> fun _ -> true | true -> ( fun x -> match x.[0] with 'A' .. 'Z' -> true | _ -> false) in - Test_interpreter.check_all_tests m_program tests !Cli.value_sort - !Cli.round_ops filter_function + Test_interpreter.check_all_tests m_program tests !Config.value_sort + !Config.round_ops filter_function let extract m_program = Cli.debug_print "Extracting the desired function from the whole program..."; - match !Cli.backend with - | Cli.Dgfip_c -> + match !Config.backend with + | Config.Dgfip_c -> Cli.debug_print "Compiling the codebase to DGFiP C..."; - if !Cli.output_file = "" then + if !Config.output_file = "" then Errors.raise_error "an output file must be defined with --output"; - Dgfip_gen_files.generate_auxiliary_files !Cli.dgfip_flags m_program; - Bir_to_dgfip_c.generate_c_program !Cli.dgfip_flags m_program - !Cli.output_file; - Cli.debug_print "Result written to %s" !Cli.output_file + Dgfip_gen_files.generate_auxiliary_files !Config.dgfip_flags m_program; + Bir_to_dgfip_c.generate_c_program !Config.dgfip_flags m_program + !Config.output_file; + Cli.debug_print "Result written to %s" !Config.output_file | UnknownBackend -> Errors.raise_error "No backend specified!" let driver () = try Cli.debug_print "Reading M files..."; - let m_program = parse () in + let progress_bar = Cli.create_progress_bar "Parsing" in + let files = Config.get_files !Config.source_files in + let m_program = Parsing.parse files progress_bar in Cli.debug_print "Elaborating..."; let m_program = Expander.proceed m_program in - let m_program = Validator.proceed !Cli.mpp_function m_program in + let m_program = Validator.proceed !Config.mpp_function m_program in let m_program = Mast_to_mir.translate m_program in let m_program = Mir.expand_functions m_program in Cli.debug_print "Creating combined program suitable for execution..."; - match !Cli.execution_mode with + match !Config.execution_mode with | SingleTest test -> run_single_test m_program test | MultipleTests tests -> run_multiple_tests m_program tests | Extraction -> extract m_program diff --git a/src/mlang/dune b/src/mlang/dune index 44f12dbe2..e8add767c 100644 --- a/src/mlang/dune +++ b/src/mlang/dune @@ -3,7 +3,7 @@ (library (public_name mlang) (libraries re ANSITerminal parmap cmdliner threads dune-build-info num gmp - menhirLib)) + menhirLib ocamlgraph yojson)) (documentation (package mlang) diff --git a/src/mlang/m_frontend/expander.ml b/src/mlang/m_frontend/expander.ml index 624ae3795..a5e78dd95 100644 --- a/src/mlang/m_frontend/expander.ml +++ b/src/mlang/m_frontend/expander.ml @@ -265,7 +265,7 @@ let elim_unselected_apps (p : Mast.program) : Mast.program = (apps_env, []) source_file in (apps_env, List.rev prog_file :: prog)) - (empty_apps_env !Cli.application_names, []) + (empty_apps_env !Config.application_names, []) p in check_apps_on_cmdline apps_env; @@ -308,7 +308,7 @@ let add_const (Pos.Mark (name, name_pos)) (Pos.Mark (cval, cval_pos)) const_map Err.constant_already_defined old_pos name_pos | None -> ( match cval with - | Com.AtomLiteral (Com.Float f) -> + | Com.AtomLiteral { lit = Com.Float f; _ } -> 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 @@ -335,7 +335,9 @@ let rec expand_variable (const_map : const_context) (loop_map : loop_context) match Pos.unmark m_var with | Com.Normal name -> ( match ConstMap.find_opt name const_map with - | Some (Pos.Mark (f, _)) -> Pos.same (Com.AtomLiteral (Float f)) m_var + | Some (Pos.Mark (f, pos)) -> + let atom = Com.mk_atomlit_from_const (Float f) @@ Pos.mark name pos in + Pos.same atom m_var | None -> Pos.same (Com.AtomVar m_var) m_var) | Com.Generic gen_name -> if List.length gen_name.Com.parameters == 0 then @@ -422,16 +424,16 @@ let var_or_int_value (const_map : const_context) match ConstMap.find_opt name const_map with | 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 + | Com.AtomLiteral { lit = Com.Float f; _ } -> IntIndex (int_of_float f) + | Com.AtomLiteral { lit = Com.Undefined; _ } -> assert false 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 + | Com.AtomLiteral { lit = Com.Float f; _ } -> RangeInt (int_of_float f) + | Com.AtomLiteral { lit = Com.Undefined; _ } -> assert false let loop_variables_size (lpvl : loop_param_value list) (pos : Pos.t) = let size_err p = Err.loop_variables_have_different_sizes p in @@ -554,7 +556,7 @@ let expand_loop_variables (lvs : Com.m_var_name Com.loop_variables Pos.marked) type 'v access_or_literal = | ExpAccess of 'v Com.m_access - | ExpLiteral of Com.literal + | ExpLiteral of Com.literal_with_orig let rec expand_access (const_map : const_context) (loop_map : loop_context) (Pos.Mark (a, a_pos) : Com.m_var_name Com.m_access) : @@ -619,7 +621,8 @@ and expand_expression (const_map : const_context) (loop_map : loop_context) match set_value with | 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) + | ExpLiteral { lit = Float f; _ } -> + FloatValue (Pos.mark f a_pos) | ExpAccess m_a -> VarValue m_a | _ -> assert false) | FloatValue _ | IntervalValue _ -> set_value) @@ -674,7 +677,7 @@ and expand_expression (const_map : const_context) (loop_map : loop_context) List.fold_left (fun res loop_expr -> Pos.same (Binop (Pos.same Or m_expr, res, loop_expr)) m_expr) - (Pos.same (Literal (Float 0.0)) m_expr) + (Pos.same (Com.mk_lit (Float 0.0)) m_expr) loop_exprs | Attribut (Pos.Mark (a, a_pos), attr) -> ( match expand_access const_map loop_map (Pos.same a m_expr) with @@ -710,7 +713,7 @@ let expand_formula (const_map : const_context) let v' = match expand_variable const_map ParamsMap.empty v with | Pos.Mark (AtomVar m_v, v_pos) -> Pos.mark (Pos.unmark m_v) v_pos - | Pos.Mark (AtomLiteral (Float _), v_pos) -> + | Pos.Mark (AtomLiteral { lit = Float _; _ }, v_pos) -> Err.constant_forbidden_as_lvalue v_pos | _ -> assert false in @@ -736,7 +739,7 @@ let expand_formula (const_map : const_context) let v' = match expand_variable const_map loop_map v with | Pos.Mark (AtomVar m_v, v_pos) -> Pos.mark (Pos.unmark m_v) v_pos - | Pos.Mark (AtomLiteral (Float _), v_pos) -> + | Pos.Mark (AtomLiteral { lit = Float _; _ }, v_pos) -> Err.constant_forbidden_as_lvalue v_pos | _ -> assert false in diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index 7fb1f0366..15b466997 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -658,13 +658,13 @@ let rec translate_expression (p : Validator.program) (dict : Com.Var.t IntMap.t) Attribut (Pos.mark access' pos, 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) + | Some l -> Com.mk_lit (Float (float (Pos.unmark l))) + | None -> Com.mk_lit 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) + | Some l -> Com.mk_lit (Float (float (Pos.unmark l))) + | None -> Com.mk_lit Undefined) | FieldAccess (m_sp_opt, e, f, _) -> let m_sp_opt' = Option.map @@ -684,8 +684,8 @@ let rec translate_expression (p : Validator.program) (dict : Com.Var.t IntMap.t) if Com.Var.is_ref var then let access' = translate_access p dict access in Size (Pos.mark access' pos) - else Literal (Float (float @@ Com.Var.size var)) - | TabAccess _ -> Literal (Float 1.0) + else Com.mk_lit (Float (float @@ Com.Var.size var)) + | TabAccess _ -> Com.mk_lit (Float 1.0) | FieldAccess (m_sp_opt, e, f, _) -> let m_sp_opt' = Option.map @@ -707,11 +707,11 @@ let rec translate_expression (p : Validator.program) (dict : Com.Var.t IntMap.t) IsVariable (Pos.mark access' pos, m_name) else let name = Pos.unmark m_name in - if Com.Var.name_str var = name then Literal (Float 1.0) + if Com.Var.name_str var = name then Com.mk_lit (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)) + | Some m_a when Pos.unmark m_a = name -> Com.mk_lit (Float 1.0) + | _ -> Com.mk_lit (Float 0.0)) | _ -> let access' = translate_access p dict access in IsVariable (Pos.mark access' pos, m_name)) diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index be48db696..670cc0247 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -28,7 +28,7 @@ along with this program. If not, see . let parse_to_atom (v: parse_val) (pos : Pos.t) : Com.m_var_name Com.atom = match v with | ParseVar v -> AtomVar (Pos.mark v pos) - | ParseInt v -> AtomLiteral (Float (float_of_int v)) + | ParseInt v -> Com.mk_atomlit (Float (float_of_int v)) (** Module generated automaticcaly by Menhir, the parser generator *) %} @@ -769,7 +769,7 @@ instruction: let expr = match eo with | Some expr -> expr - | None -> Pos.without (Com.Literal (Com.Float 1.0)) + | None -> Pos.without (Com.mk_lit (Com.Float 1.0)) in Some (ComputeVerifs (dom, expr, m_sp_opt)) } @@ -1007,7 +1007,7 @@ it_param: let expr = match eo with | Some expr -> expr - | None -> Pos.without (Com.Literal (Com.Float 1.0)) + | None -> Pos.without (Com.mk_lit (Com.Float 1.0)) in let m_sp_opt = match spo with Some m_sp -> Some (m_sp, -1) | None -> None in `VarCatsIt (vcats, expr, m_sp_opt) @@ -1059,7 +1059,7 @@ rest_param: let expr = match eo with | Some expr -> expr - | None -> Pos.without (Com.Literal (Com.Float 1.0)) + | None -> Pos.without (Com.mk_lit (Com.Float 1.0)) in let m_sp_opt = match spo with Some m_sp -> Some (m_sp, -1) | None -> None in `VarCatsRest (var, vcats, expr, m_sp_opt) @@ -1434,7 +1434,7 @@ factor: | Com.AtomVar v -> Com.Var (VarAccess (None, v)) | Com.AtomLiteral l -> Com.Literal l } -| UNDEFINED { Com.Literal Undefined } +| UNDEFINED { Com.mk_lit Undefined } | LPAREN e = expression RPAREN { e } loop_expression: diff --git a/src/mlang/m_frontend/parse_utils.ml b/src/mlang/m_frontend/parse_utils.ml index 3b6ac0bcb..f58ede8ad 100644 --- a/src/mlang/m_frontend/parse_utils.ml +++ b/src/mlang/m_frontend/parse_utils.ml @@ -16,8 +16,12 @@ module E = Errors +type loc = Lexing.position * Lexing.position + let mk_position sloc = Pos.make (fst sloc).Lexing.pos_fname sloc +let make_loc loc = loc + (** {1 Frontend variable names}*) let parse_variable_name sloc (s : string) : string = @@ -88,7 +92,7 @@ let parse_literal sloc (s : string) : Com.literal = with Failure _ -> E.raise_spanned_error "invalid literal" (mk_position sloc) let parse_atom sloc (s : string) : Com.m_var_name Com.atom = - try Com.AtomLiteral (Com.Float (float_of_string s)) + try Com.mk_atomlit (Com.Float (float_of_string s)) with Failure _ -> Com.AtomVar (Pos.mark (parse_variable sloc s) (mk_position sloc)) diff --git a/src/mlang/m_frontend/parse_utils.mli b/src/mlang/m_frontend/parse_utils.mli index 186ebc546..cd157a683 100644 --- a/src/mlang/m_frontend/parse_utils.mli +++ b/src/mlang/m_frontend/parse_utils.mli @@ -21,8 +21,12 @@ (** A parsed variable can be a regular variable or an integer literal *) type parse_val = ParseVar of Com.var_name | ParseInt of int +type loc = Lexing.position * Lexing.position + val mk_position : Lexing.position * Lexing.position -> Pos.t +val make_loc : loc -> loc + val parse_variable : Lexing.position * Lexing.position -> string -> Com.var_name (** Checks whether the variable contains parameters *) diff --git a/src/mlang/m_frontend/validator.ml b/src/mlang/m_frontend/validator.ml index ccee6b821..16ac13c06 100644 --- a/src/mlang/m_frontend/validator.ml +++ b/src/mlang/m_frontend/validator.ml @@ -583,7 +583,7 @@ let safe_prefix (p : Mast.program) : string = 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 + List.fold_left fold StrMap.empty !Config.application_names in { prog_prefix = safe_prefix p; @@ -2861,8 +2861,8 @@ let eval_expr_verif (prog : program) (verif : verif) in let rec aux expr = match Pos.unmark expr with - | Com.Literal (Com.Float f) -> Some f - | Literal Com.Undefined -> None + | Com.Literal { lit = Com.Float f; _ } -> Some f + | Literal { lit = 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 diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 5af0bfd95..d82ffe98a 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -432,6 +432,10 @@ type variable_space = { type literal = Float of float | Undefined +type origin = string Pos.marked option + +type literal_with_orig = { lit : literal; origin : origin } + (** Unary operators *) type unop = Not | Minus @@ -476,7 +480,7 @@ type 'v access = and 'v m_access = 'v access Pos.marked -and 'v atom = AtomVar of 'v | AtomLiteral of literal +and 'v atom = AtomVar of 'v | AtomLiteral of literal_with_orig and 'v set_value_loop = | Single of 'v atom Pos.marked @@ -505,7 +509,7 @@ and 'v expression = | 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 + | Literal of literal_with_orig | Var of 'v access | Loop of 'v loop_variables Pos.marked * 'v m_expression (** The loop is prefixed with the loop variables declarations *) @@ -520,6 +524,68 @@ and 'v expression = and 'v m_expression = 'v expression Pos.marked +type const = { id : string; value : literal; pos : Pos.t } + +type 'v dep = + | Tab of 'v * 'v m_expression + | V of 'v + | LiteralDep of literal + | Const of const + +(* This code was taken from Noe and adapted to the 2025 var architecture *) +let get_used_variables (e : 'v expression) : + ('v dep * 'v expression option) list = + let rec get_used_variables_ (e : 'v expression) + (acc : ('v dep * 'v expression option) list) = + match e with + | TestInSet (_, Mark (e, _), _) | Unop (_, Mark (e, _)) -> + let acc = get_used_variables_ e acc in + acc + | Comparison (_, Mark (e1, _), Mark (e2, _)) + | Binop (_, Mark (e1, _), Mark (e2, _)) -> + let acc = get_used_variables_ e1 acc in + let acc = get_used_variables_ e2 acc in + acc + | Conditional (Mark (e1, _), Mark (e2, _), e3) -> ( + let acc = get_used_variables_ e1 acc in + let acc = get_used_variables_ e2 acc in + match e3 with + | None -> acc + | Some (Mark (e3, _)) -> get_used_variables_ e3 acc) + | FuncCall (_, args) -> + List.fold_left + (fun acc arg -> get_used_variables_ (Pos.unmark arg) acc) + acc args + | FuncCallLoop _ | Loop _ -> assert false + | Var var + | Size (Mark (var, _)) + | Attribut (Mark (var, _), _) + | IsVariable (Mark (var, _), _) -> ( + match var with + | TabAccess (_, v, m_i) -> (Tab (v, m_i), None) :: acc + | VarAccess (_, v) -> (V v, None) :: acc + | FieldAccess (_, Mark (v, _), _, _) -> get_used_variables_ v acc) + | Literal { lit; origin = Some (Mark (id, pos)) } -> + (Const { id; value = lit; pos }, None) :: acc + | Literal { lit; origin = None } -> (LiteralDep lit, None) :: acc + | NbCategory _ | NbAnomalies | NbDiscordances | NbInformatives + | NbBloquantes -> + acc + in + get_used_variables_ e [] + +let mk_lit_with_orig lit origin = { lit; origin } + +let mk_lit lit = Literal (mk_lit_with_orig lit None) + +let mk_lit_from_const lit constname = + Literal (mk_lit_with_orig lit (Some constname)) + +let mk_atomlit lit = AtomLiteral (mk_lit_with_orig lit None) + +let mk_atomlit_from_const lit constname = + AtomLiteral (mk_lit_with_orig lit (Some constname)) + module Error = struct type typ = Anomaly | Discordance | Information @@ -1066,13 +1132,14 @@ let format_value_typ fmt t = | Real -> "REEL") let format_literal fmt l = - Format.pp_print_string fmt - (match l with Float f -> string_of_float f | Undefined -> "indefini") + match l with + | Float f -> Format.fprintf fmt "%g" f + | Undefined -> Format.pp_print_string fmt "indefini" let format_atom form_var fmt vl = match vl with | AtomVar v -> form_var fmt v - | AtomLiteral l -> format_literal fmt l + | AtomLiteral l -> format_literal fmt l.lit let format_set_value_loop form_var fmt sv = let form_atom = format_atom form_var in @@ -1213,7 +1280,7 @@ let rec format_expression form_var fmt = Format.fprintf fmt "%a(%a%a)" format_func (Pos.unmark f) (format_loop_variables form_var) (Pos.unmark lvs) form_expr (Pos.unmark e) - | Literal l -> format_literal fmt l + | Literal { lit; _ } -> format_literal fmt lit | Var acc -> format_access form_var form_expr fmt acc | Loop (lvs, e) -> Format.fprintf fmt "pour %a%a" diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 4484cb76b..e5b1e5130 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -212,6 +212,10 @@ type verif_domain = verif_domain_data domain type literal = Float of float | Undefined +type origin = string Pos.marked option + +type literal_with_orig = { lit : literal; origin : origin } + (** Unary operators *) type unop = Not | Minus @@ -268,7 +272,7 @@ type 'v access = and 'v m_access = 'v access Pos.marked (** Values that can be substituted for loop parameters *) -and 'v atom = AtomVar of 'v | AtomLiteral of literal +and 'v atom = AtomVar of 'v | AtomLiteral of literal_with_orig and 'v set_value_loop = | Single of 'v atom Pos.marked @@ -301,7 +305,7 @@ and 'v expression = | 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 + | Literal of literal_with_orig | Var of 'v access | Loop of 'v loop_variables Pos.marked * 'v m_expression (** The loop is prefixed with the loop variables declarations *) @@ -316,6 +320,30 @@ and 'v expression = and 'v m_expression = 'v expression Pos.marked +type const = { id : string; value : literal; pos : Pos.t } + +type 'v dep = + | Tab of 'v * 'v m_expression + | V of 'v + | LiteralDep of literal + | Const of const + +val get_used_variables : 'v expression -> ('v dep * 'v expression option) list + +val mk_atomlit : literal -> 'v atom +(** [mk_atomtit lit] makes a Literal expression with no origin *) + +val mk_atomlit_from_const : literal -> string Pos.marked -> 'v atom +(** [mk_atomlit_from_const] makes a Literal expression with + the name of the const as origin *) + +val mk_lit : literal -> 'v expression +(** [mk_lit lit] makes a Literal expression with no origin *) + +val mk_lit_from_const : literal -> string Pos.marked -> 'v expression +(** [mk_lit_from_const] makes a Literal expression with + the name of the const as origin *) + module Error : sig type typ = Anomaly | Discordance | Information diff --git a/src/mlang/m_ir/dbg_info.ml b/src/mlang/m_ir/dbg_info.ml new file mode 100644 index 000000000..1d830eb40 --- /dev/null +++ b/src/mlang/m_ir/dbg_info.ml @@ -0,0 +1,217 @@ +module Origin = struct + type code = Rule of int | Declared | Input | Target of string | Const + + type t = { filename : string; sline : int; eline : int; code_orig : code } + + let make filename sline eline code_orig = + { filename; sline; eline; code_orig } + + let make_from_pos pos code_orig = + let filename = Pos.get_file pos in + let sline = Pos.get_start_line pos in + let eline = Pos.get_end_line pos in + { filename; sline; eline; code_orig } + + let hash (t : t) = Hashtbl.hash t + + let to_json origin = + let code_orig = + match origin.code_orig with + | Rule i -> Format.asprintf "%d" i + | Input -> "input" + | Declared -> "Declared" + | Target s -> Format.asprintf "target-%s" s + | Const -> "const" + in + Format.asprintf + {|"origin": {"code_orig": "%s", "file": "%s", "sline": %d, "eline": %d }|} + code_orig origin.filename origin.sline origin.eline +end + +module Tick = struct + include Int + + let inner = ref (-1) + + let tick () = + incr inner; + !inner + + module Map = struct + include IntMap + end +end + +module Info = struct + type t = { + name : string; + var : Com.Var.t; + value : Com.literal; + origin : Origin.t; + } + (* We've removed idx_opt, it may be needed for tables. *) + + let make name var value origin = { name; var; value; origin } + + module Runtime = struct + type t = { hash : int; value : Com.literal; name : string option } + + let make origin value name = { hash = Origin.hash origin; value; name } + end + + module Static = struct + type t = { + name : string; + origin : Origin.t; + is_input : bool; + descr : string option; + } + + let make name origin is_input descr = { name; origin; is_input; descr } + end +end + +module Const = struct + type t = { name : string; value : Com.literal; origin : Origin.t } + + let make name value fname sline eline = + let origin = Origin.make fname sline eline Const in + { name; value; origin } + + let make_from_pos name value pos = + let origin = Origin.make_from_pos pos Const in + { name; value; origin } +end + +module Vertex = struct + type kind = Literal | Var + + include Tick + + (* Invariant (to be verified): All ticks are different *) + type t = Tick.t + + (* This feels weird, but String.hash was introduced in 5.0 *) + let hash t = Hashtbl.hash t +end + +module Graph = Graph.Persistent.Digraph.Concrete (Vertex) + +module TickMap = struct + include StrMap + + let find name map = + match StrMap.find_opt name map with + | None -> + let msg = + if StrMap.card map > 100 then + Format.asprintf "could not find %s in tick_map (too long).@." name + else + Format.asprintf "could not find %s in tick_map %a.@." name + (StrMap.pp (fun fmt -> Format.fprintf fmt "%d")) + map + in + raise @@ Failure msg + | Some tick -> tick +end + +type t = { + graph : Graph.t; + runtimes : Info.Runtime.t Tick.Map.t; + statics : Info.Static.t IntMap.t; + consts : Const.t IntMap.t; + literals : string IntMap.t; + ledger : Tick.t StrMap.t; +} + +let empty = + { + graph = Graph.empty; + runtimes = Tick.Map.empty; + statics = IntMap.empty; + consts = IntMap.empty; + literals = IntMap.empty; + ledger = StrMap.empty; + } + +let to_json (fmt : Format.formatter) info : unit = + let open Format in + let open Info.Static in + let open Info.Runtime in + let open Const in + let delim = ref "" in + Format.fprintf fmt {|{"graph":{@. "nodes": [|}; + let pp_vertex v = + let var = Graph.V.label v in + Format.fprintf fmt {|%s@.{"data": "%d"}|} !delim var; + (* Small hack to avoid trailing commas *) + delim := "," + in + Format.printf "writing vertices...@."; + Graph.iter_vertex pp_vertex info.graph; + fprintf fmt {|],@. "edges": [|}; + let print_edge (e : Graph.E.t) = + let src = Graph.E.src e in + let dst = Graph.E.dst e in + let src = Graph.V.label src in + let dst = Graph.V.label dst in + Format.fprintf fmt {|%s@.{"data": {"source": "%d", "target": "%d"}}|} !delim + src dst; + delim := "," + in + delim := ""; + Format.printf "writing edges...@."; + Graph.iter_edges_e print_edge info.graph; + let print_static_info hash { name; origin; is_input; descr } = + let origin = Origin.to_json origin in + let descr = + match descr with + | None -> "" + | Some descr -> + let descr = Yojson.Safe.to_string (`String descr) in + asprintf {|"descr": %s,|} descr + in + Format.fprintf fmt {|%s@."%d": {"name": %S, "is_input": %b, %s %s}|} !delim + hash name is_input descr origin; + delim := "," + in + Format.fprintf fmt "]},@."; + Format.printf "writing info...@."; + delim := ""; + Format.fprintf fmt {|"statics": {@.|}; + IntMap.iter print_static_info info.statics; + Format.fprintf fmt "},@."; + delim := ""; + Format.fprintf fmt {|"runtimes": {@.|}; + let print_runtime_info tick { value; hash; name } = + let name = + match name with + | None -> "" + | Some name -> asprintf {|, "name" : %S|} name + in + Format.fprintf fmt {|%s@."%d": {"value": "%a", "hash": %d %s}|} !delim tick + Com.format_literal value hash name; + delim := "," + in + Tick.Map.iter print_runtime_info info.runtimes; + let print_const id const = + Format.printf "Printing consts!!!!@."; + let origin = Origin.to_json const.origin in + Format.fprintf fmt + {|%s@."%d": {"name": %S, "value": "%a", "kind": "const", %s}|} !delim id + const.name Com.format_literal const.value origin; + delim := "," + in + IntMap.iter print_const info.consts; + let print_lit id lit = + Format.fprintf fmt {|%s@."%d": {"name": %S}|} !delim id lit; + delim := "," + in + IntMap.iter print_lit info.literals; + Format.fprintf fmt "}}@." + +let write_json_file filename info = + let filename = filename ^ ".json" in + let oc = open_out filename in + let fmt = Format.formatter_of_out_channel oc in + Format.fprintf fmt "%a@." to_json info diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 8c8548ac1..da48dd8ee 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -164,7 +164,7 @@ let rec expand_functions_expr (e : 'var Com.expression Pos.marked) : None args in let expr = - match expr_opt with None -> Literal (Float 0.0) | Some expr -> expr + match expr_opt with None -> Com.mk_lit (Float 0.0) | Some expr -> expr in Pos.same expr e | FuncCall (Pos.Mark (GtzFunc, _), [ arg ]) -> @@ -172,14 +172,14 @@ let rec expand_functions_expr (e : 'var Com.expression Pos.marked) : (Comparison ( Pos.same Com.Gt e, expand_functions_expr arg, - Pos.same (Literal (Float 0.0)) e )) + Pos.same (Com.mk_lit (Float 0.0)) e )) e | FuncCall (Pos.Mark (GtezFunc, _), [ arg ]) -> Pos.same (Comparison ( Pos.same Com.Gte e, expand_functions_expr arg, - Pos.same (Literal (Float 0.0)) e )) + Pos.same (Com.mk_lit (Float 0.0)) e )) e | FuncCall ((Pos.Mark ((MinFunc | MaxFunc), _) as fn), [ arg1; arg2 ]) -> let earg1 = expand_functions_expr arg1 in @@ -192,7 +192,7 @@ let rec expand_functions_expr (e : 'var Com.expression Pos.marked) : (Comparison ( Pos.same Com.Eq e, expand_functions_expr arg, - Pos.same (Literal (Float 0.0)) e )) + Pos.same (Com.mk_lit (Float 0.0)) e )) e | FuncCall (fn, args) -> Pos.same (FuncCall (fn, List.map expand_functions_expr args)) e diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index e2c1b01bc..be90389ad 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -44,6 +44,8 @@ module type S = sig base : value Array.t; } + type ctx_exec_ctx = CtxUndefined | CtxTarget of string | CtxRule of int + type ctx = { ctx_prog : Mir.program; mutable ctx_target : Mir.target; @@ -64,10 +66,13 @@ 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; + mutable ctx_events : + (value, Com.Var.t) Com.event_value Array.t Array.t list; + mutable ctx_dbg_info : Dbg_info.t option; + mutable ctx_exec_ctx : ctx_exec_ctx; } - val empty_ctx : Mir.program -> ctx + val empty_ctx : Mir.program -> Dbg_info.t option -> ctx val literal_to_value : Com.literal -> value @@ -141,6 +146,8 @@ struct base : value Array.t; } + type ctx_exec_ctx = CtxUndefined | CtxTarget of string | CtxRule of int + type ctx = { ctx_prog : Mir.program; mutable ctx_target : Mir.target; @@ -161,10 +168,13 @@ 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; + mutable ctx_events : + (value, Com.Var.t) Com.event_value Array.t Array.t list; + mutable ctx_dbg_info : Dbg_info.t option; + mutable ctx_exec_ctx : ctx_exec_ctx; } - let empty_ctx (p : Mir.program) : ctx = + let empty_ctx (p : Mir.program) (dbg_info : Dbg_info.t option) : ctx = let dummy_var = Com.Var.new_ref ~name:(Pos.without "") in let init_tmp_var _i = { var = dummy_var; value = Undefined } in let init_ref _i = @@ -201,6 +211,7 @@ struct in Array.init (IntMap.cardinal p.program_var_spaces_idx) init in + let ctx_dbg_info = dbg_info in { ctx_prog = p; ctx_target = snd (StrMap.min_binding p.program_targets); @@ -222,6 +233,8 @@ struct ctx_finalized_anos = []; ctx_exported_anos = []; ctx_events = []; + ctx_dbg_info; + ctx_exec_ctx = CtxUndefined; } let literal_to_value (l : Com.literal) : value = @@ -335,7 +348,7 @@ struct let bool_of_real (f : N.t) : bool = not N.(f =. zero ()) let compare_numbers op i1 i2 = - let epsilon = N.of_float !Cli.comparison_error_margin in + let epsilon = N.of_float !Config.comparison_error_margin in let open Com in match op with | Gt -> N.(i1 >. i2 +. epsilon) @@ -502,10 +515,138 @@ struct done else set_var_value_org ctx vsd v vorg value + and eval_m_index ctx m_i = + match evaluate_expr ctx m_i with + | Number z -> Int64.to_string @@ N.to_int z + | Undefined -> "indefini" + + and trace_deps deps dbg_info ctx = + let open Dbg_info in + let trace_dep (ticks, dbg_info) dep = + match fst dep with + | Com.V var -> + let name = Com.Var.name_str var in + (* For now, we add uninstantiated depedencies as undefined *) + begin + match TickMap.find name dbg_info.ledger with + | exception Failure msg -> + Format.fprintf Format.err_formatter "%s" msg; + let tick = Tick.tick () in + Format.fprintf Format.err_formatter "it will have tick: %d@." + tick; + let pos = Com.Var.name var |> Pos.get in + let origin = Origin.make_from_pos pos Declared in + let ledger = StrMap.add name tick dbg_info.ledger in + let runtime = Info.Runtime.make origin Undefined (Some name) in + let runtimes = Tick.Map.add tick runtime dbg_info.runtimes in + let static = Info.Static.make name origin false None in + let statics = IntMap.add runtime.hash static dbg_info.statics in + let dbg_info = { dbg_info with ledger; runtimes; statics } in + (tick :: ticks, dbg_info) + | tick -> (tick :: ticks, dbg_info) + end + | Const const -> + let name = const.Com.id in + begin + match TickMap.find name dbg_info.ledger with + | tick -> (tick :: ticks, dbg_info) + | exception Failure _ -> + let tick = Tick.tick () in + let const = + Const.make_from_pos name const.Com.value const.pos + in + let consts = Tick.Map.add tick const dbg_info.consts in + let ledger = StrMap.add name tick dbg_info.ledger in + let dbg_info = { dbg_info with consts; ledger } in + (tick :: ticks, dbg_info) + end + | Tab (var, m_i) -> + let name = Com.Var.name_str var in + let idx_str = eval_m_index ctx m_i in + let name = Format.asprintf "%s[%s]" name idx_str in + begin + match TickMap.find name dbg_info.ledger with + | exception Failure _ -> + let tick = Tick.tick () in + let pos = Com.Var.name var |> Pos.get in + let origin = Origin.make_from_pos pos Declared in + let ledger = StrMap.add name tick dbg_info.ledger in + let runtime = Info.Runtime.make origin Undefined (Some name) in + let runtimes = Tick.Map.add tick runtime dbg_info.runtimes in + let static = Info.Static.make name origin false None in + let statics = IntMap.add runtime.hash static dbg_info.statics in + let dbg_info = { dbg_info with ledger; runtimes; statics } in + (tick :: ticks, dbg_info) + | tick -> (tick :: ticks, dbg_info) + end + | LiteralDep _lit -> (ticks, dbg_info) + in + + List.fold_left trace_dep ([], dbg_info) deps + and set_access ctx access vexpr = match get_access_var ctx access with - | Some (vsd, v) -> set_var_value ctx vsd v @@ evaluate_expr ctx vexpr | None -> () + | Some (vsd, v) -> ( + let value = evaluate_expr ctx vexpr in + set_var_value ctx vsd v value; + match (ctx.ctx_dbg_info, ctx.ctx_exec_ctx) with + | None, _ -> () + (* | _, CtxTarget "effacer_base_etc" *) + (* | _, CtxTarget "effacer_avfisc_1" *) + (* | _, CtxTarget "effacer_calculee_etc" -> *) + (* () *) + | Some dbg_info, _ -> + let open Dbg_info in + let deps = Com.get_used_variables @@ Pos.unmark vexpr in + let ticks, dbg_info = trace_deps deps dbg_info ctx in + (* Create the tick for this variable after the deps so that they are + in the right order on marple side. *) + let tick = Tick.tick () in + let access_name name = + match access with + | Com.VarAccess _ -> name + | Com.TabAccess (_, v, m_i) -> + let name = Com.Var.name_str v in + let idx_str = eval_m_index ctx m_i in + Format.asprintf "%s[%s]" name idx_str + | Com.FieldAccess (_, _, _, _) -> Com.Var.name_str v + in + let name = access_name @@ Com.Var.name_str v in + let is_input = + match Com.Var.cat_var_loc v with + | Com.CatVar.LocInput -> true + | (exception Failure _) | _ -> false + in + let pos = Pos.get vexpr in + let rule_id = + match ctx.ctx_exec_ctx with + | CtxRule i -> Dbg_info.Origin.Rule i + | CtxTarget s -> Dbg_info.Origin.Target s + (* FIXME: This is a debug failure, do not release as-if *) + | CtxUndefined -> raise @@ Failure "no rule id" + in + let lit_value = value_to_literal value in + let descr = + match Com.Var.descr_str v with + | exception _ -> None + | descr -> Some descr + in + let origin = Origin.make_from_pos pos rule_id in + let runtime = Info.Runtime.make origin lit_value (Some name) in + let runtimes = Tick.Map.add tick runtime dbg_info.runtimes in + let static = Info.Static.make name origin is_input descr in + let statics = IntMap.add runtime.hash static dbg_info.statics in + let vert = Dbg_info.Graph.V.create tick in + let graph = dbg_info.graph in + let add_edge graph deptick = + let dep_vert = Dbg_info.Graph.V.create deptick in + Dbg_info.Graph.add_edge graph vert dep_vert + in + let graph = List.fold_left add_edge graph ticks in + let ledger = TickMap.add name tick dbg_info.ledger in + ctx.ctx_dbg_info <- + Some { dbg_info with graph; runtimes; statics; ledger }) and evaluate_expr (ctx : ctx) (e : Mir.expression Pos.marked) : value = let comparison op new_e1 new_e2 = @@ -597,8 +738,8 @@ struct | Some e3 -> evaluate_expr ctx e3) | Number _ -> evaluate_expr ctx e2 | Undefined -> Undefined) - | Literal Undefined -> Undefined - | Literal (Float f) -> Number (N.of_float f) + | Literal { lit = Undefined; _ } -> Undefined + | Literal { lit = Float f; _ } -> Number (N.of_float f) | Var access -> get_access_value ctx access | FuncCall (Pos.Mark (ArrFunc, _), [ arg ]) -> ( match evaluate_expr ctx arg with @@ -653,7 +794,7 @@ struct in let access_index (i : int) : Int64.t option = let ei = - Pos.same (Com.Literal (Float (float_of_int i))) arg2 + Pos.same (Com.mk_lit (Float (float_of_int i))) arg2 in let instr = let m_sp_opt = @@ -1150,6 +1291,22 @@ struct and evaluate_target (canBlock : bool) (ctx : ctx) (target : Mir.target) (args : Mir.m_access list) : unit = + (* We check if the current target is in the rule map. + If it is, we assume we're in a rule, and register it + to annotate the value we'll set later in the dbg_info. *) + let target_name = Pos.unmark target.target_name in + Format.printf "evaluating target: %s@." target_name; + let rule_id = + IntMap.fold + (fun i str acc -> + match acc with + | Some _ -> acc + | None -> if str = target_name then Some i else None) + ctx.ctx_prog.program_rules None + in + (match rule_id with + | None -> ctx.ctx_exec_ctx <- CtxTarget target_name + | Some rule_id -> ctx.ctx_exec_ctx <- CtxRule rule_id); let rec set_args n vl al = match (vl, al) with | v :: vl', m_a :: al' -> ( @@ -1259,7 +1416,8 @@ module RatMfInterp = (Mir_number.RationalNumber) (Mir_roundops.MainframeRoundOps (MainframeLongSize)) -let get_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : (module S) = +let get_interp (sort : Config.value_sort) (roundops : Config.round_ops) : + (module S) = match (sort, roundops) with | RegularFloat, RODefault -> (module FloatDefInterp) | RegularFloat, ROMulti -> (module FloatMultInterp) @@ -1277,7 +1435,8 @@ let get_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : (module S) = | Rational, ROMulti -> (module RatMultInterp) | Rational, ROMainframe _ -> (module RatMfInterp) -let prepare_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : unit = +let prepare_interp (sort : Config.value_sort) (roundops : Config.round_ops) : + unit = begin match sort with | MPFR prec -> Mpfr.set_default_prec prec @@ -1298,11 +1457,12 @@ 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) : - Com.literal Com.Var.Map.t * Com.Error.Set.t = + (sort : Config.value_sort) (roundops : Config.round_ops) + (dbg_info : Dbg_info.t option) : + Com.literal Com.Var.Map.t * Com.Error.Set.t * Dbg_info.t option = prepare_interp sort roundops; let module Interp = (val get_interp sort roundops : S) in - let ctx = Interp.empty_ctx p in + let ctx = Interp.empty_ctx p dbg_info in Interp.update_ctx_with_inputs ctx inputs; Interp.update_ctx_with_events ctx events; Interp.evaluate_program ctx; @@ -1330,9 +1490,11 @@ let evaluate_program (p : Mir.program) (inputs : Com.literal Com.Var.Map.t) 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 dbg_info = ctx.ctx_dbg_info in + (varMap, anoSet, dbg_info) let evaluate_expr (p : Mir.program) (e : Mir.expression Pos.marked) - (sort : Cli.value_sort) (roundops : Cli.round_ops) : Com.literal = + (sort : Config.value_sort) (roundops : Config.round_ops) + (dbg_info : Dbg_info.t option) : Com.literal = let module Interp = (val get_interp sort roundops : S) in - Interp.value_to_literal (Interp.evaluate_expr (Interp.empty_ctx p) e) + Interp.value_to_literal (Interp.evaluate_expr (Interp.empty_ctx p dbg_info) e) diff --git a/src/mlang/m_ir/mir_interpreter.mli b/src/mlang/m_ir/mir_interpreter.mli index c9225427f..d13f8b396 100644 --- a/src/mlang/m_ir/mir_interpreter.mli +++ b/src/mlang/m_ir/mir_interpreter.mli @@ -65,6 +65,11 @@ module type S = sig base : value Array.t; } + type ctx_exec_ctx = + | CtxUndefined + | CtxTarget of string + | CtxRule of int (** Marker to in which context are variables set *) + type ctx = { ctx_prog : Mir.program; mutable ctx_target : Mir.target; @@ -85,11 +90,14 @@ 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; + mutable ctx_events : + (value, Com.Var.t) Com.event_value Array.t Array.t list; + mutable ctx_dbg_info : Dbg_info.t option; + mutable ctx_exec_ctx : ctx_exec_ctx; } (** Interpretation context *) - val empty_ctx : Mir.program -> ctx + val empty_ctx : Mir.program -> Dbg_info.t option -> ctx val literal_to_value : Com.literal -> value @@ -140,53 +148,25 @@ module FloatDefInterp : - Multi: use the rouding operations of the PC/multi-thread context - Mf: use the rounding operations of the mainframe context *) -module FloatMultInterp : - S with type custom_float = Mir_number.RegularFloatNumber.t - -module FloatMfInterp : - S with type custom_float = Mir_number.RegularFloatNumber.t - -module MPFRDefInterp : S with type custom_float = Mir_number.MPFRNumber.t - -module MPFRMultInterp : S with type custom_float = Mir_number.MPFRNumber.t - -module MPFRMfInterp : S with type custom_float = Mir_number.MPFRNumber.t - -module BigIntDefInterp : S - -module BigIntMultInterp : S - -module BigIntMfInterp : S - -module IntvDefInterp : S with type custom_float = Mir_number.IntervalNumber.t - -module IntvMultInterp : S with type custom_float = Mir_number.IntervalNumber.t - -module IntvMfInterp : S with type custom_float = Mir_number.IntervalNumber.t - -module RatDefInterp : S with type custom_float = Mir_number.RationalNumber.t - -module RatMultInterp : S with type custom_float = Mir_number.RationalNumber.t - -module RatMfInterp : S with type custom_float = Mir_number.RationalNumber.t - (** {1 Generic interpretation API}*) -val get_interp : Cli.value_sort -> Cli.round_ops -> (module S) +val get_interp : Config.value_sort -> Config.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 -> - Com.literal Com.Var.Map.t * Com.Error.Set.t + Config.value_sort -> + Config.round_ops -> + Dbg_info.t option -> + Com.literal Com.Var.Map.t * Com.Error.Set.t * Dbg_info.t option (** Main interpreter function *) val evaluate_expr : Mir.program -> Mir.expression Pos.marked -> - Cli.value_sort -> - Cli.round_ops -> + Config.value_sort -> + Config.round_ops -> + Dbg_info.t option -> Com.literal (** Interprets only an expression *) diff --git a/src/mlang/m_ir/mir_roundops.ml b/src/mlang/m_ir/mir_roundops.ml index f39fad3ca..f6577e50e 100644 --- a/src/mlang/m_ir/mir_roundops.ml +++ b/src/mlang/m_ir/mir_roundops.ml @@ -29,7 +29,7 @@ module DefaultRoundOps (N : Mir_number.NumberInterface) : RoundOpsInterface with type t = N.t = struct type t = N.t - let epsilon = !Cli.comparison_error_margin + let epsilon = !Config.comparison_error_margin let truncatef (x : N.t) : N.t = N.floor N.(x +. N.of_float epsilon) @@ -45,7 +45,7 @@ module MultiRoundOps (N : Mir_number.NumberInterface) : RoundOpsInterface with type t = N.t = struct type t = N.t - let epsilon = !Cli.comparison_error_margin + let epsilon = !Config.comparison_error_margin let truncatef (x : N.t) : N.t = N.floor N.(x +. N.of_float epsilon) @@ -60,7 +60,7 @@ end) (N : Mir_number.NumberInterface) : RoundOpsInterface with type t = N.t = struct type t = N.t - let epsilon = !Cli.comparison_error_margin + let epsilon = !Config.comparison_error_margin let floor_g (x : N.t) : N.t = if N.abs x <= N.of_int !L.max_long then N.floor x else x diff --git a/src/mlang/parsing.ml b/src/mlang/parsing.ml new file mode 100644 index 000000000..64820ffd9 --- /dev/null +++ b/src/mlang/parsing.ml @@ -0,0 +1,108 @@ +open Lexing +open Mlexer + +(* 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). *) +let patch_rule_1 (backend : Config.backend) + (dgfip_flags : Config.Dgfip_options.flags) (program : Mast.program) : + Mast.program = + let open Mast in + let var_exists name = + List.exists + (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 m_access = + Pos.without (Com.VarAccess (None, Pos.without (Com.Normal name))) + in + let litt = Com.mk_lit (Com.Float (if value then 1.0 else 0.0)) in + let cmd = Com.SingleFormula (VarDecl (m_access, Pos.without litt)) in + Pos.without cmd :: l + else l + in + let oceans, batch, iliad = + match backend with + | Dgfip_c -> + (dgfip_flags.flg_cfir, dgfip_flags.flg_gcos, dgfip_flags.flg_iliad) + | UnknownBackend -> (false, false, true) + in + List.map + (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 (Com.Affectation f) f) + ([] + |> mk_assign "APPLI_OCEANS" oceans + |> mk_assign "APPLI_BATCH" batch + |> mk_assign "APPLI_ILIAD" iliad) + in + 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 + error. *) +let parse_lexbuf filebuf source_file = + let lex_curr_p = { filebuf.lex_curr_p with pos_fname = source_file } in + let filebuf = { filebuf with lex_curr_p } in + match Mparser.source_file token filebuf with + | commands -> commands + | exception Mparser.Error -> + let loc = + Parse_utils.make_loc (filebuf.lex_start_p, filebuf.lex_curr_p) + in + Errors.raise_spanned_error "M syntax error" (Parse_utils.mk_position loc) + +let parse_file source_file = + let input = open_in source_file in + let filebuf = Lexing.from_channel input in + try + parse_lexbuf filebuf source_file + (* We're catching exceptions to properly close the input channel *) + with Errors.StructuredError _ as e -> + close_in input; + raise e + +let parse_m_dgfip current_progress m_program = + let parse_internal str = + let filebuf = Lexing.from_string str in + let source_file = Dgfip_m.internal_m in + current_progress source_file; + parse_lexbuf filebuf source_file + in + let decs = parse_internal Dgfip_m.declarations in + let events = parse_internal Dgfip_m.event_declaration in + events :: decs :: m_program + +let parse_m_files files current_progress m_program = + let parse_file_progress source_file = + current_progress source_file; + parse_file source_file + in + (*FIXME: use a fold here *) + let prog = List.map parse_file_progress files in + List.rev prog @ m_program + +let parse files progress_bar = + let current_progress, finish = progress_bar in + let m_program = + [] + |> parse_m_dgfip current_progress + |> parse_m_files files current_progress + |> List.rev + |> patch_rule_1 !Config.backend !Config.dgfip_flags + in + finish "completed!"; + m_program diff --git a/src/mlang/test_framework/irj_file.ml b/src/mlang/test_framework/irj_file.ml index 04d053227..c0f5a2097 100644 --- a/src/mlang/test_framework/irj_file.ml +++ b/src/mlang/test_framework/irj_file.ml @@ -16,6 +16,8 @@ open Irj_ast +type input = Filename of string | Contents of string + (* Implement a parsing error handling following François Pottier’s example in https://gitlab.inria.fr/fpottier/menhir/blob/master/demos/calc-syntax-errors/calc.ml *) @@ -85,12 +87,15 @@ let fail text buffer (checkpoint : _ Irj_parser.MenhirInterpreter.checkpoint) = Errors.raise_spanned_error indication (mk_position (MenhirLib.ErrorReports.last buffer)) -let parse_file (test_name : string) : Irj_ast.irj_file = +let parse_file (test_name : input) : Irj_ast.irj_file = let text, filebuf = - try MenhirLib.LexerUtil.read test_name - with Sys_error msg -> - Errors.raise_error - (Format.asprintf "Unable to open file %s (%s)" test_name msg) + match test_name with + | Contents contents -> (contents, Lexing.from_string contents) + | Filename filename -> ( + try MenhirLib.LexerUtil.read filename + with Sys_error msg -> + Errors.raise_error + (Format.asprintf "Unable to open file %s (%s)" filename msg)) in let supplier = Irj_parser.MenhirInterpreter.lexer_lexbuf_to_supplier Irj_lexer.token diff --git a/src/mlang/test_framework/irj_file.mli b/src/mlang/test_framework/irj_file.mli index c0dab0c7f..0f6d831a2 100644 --- a/src/mlang/test_framework/irj_file.mli +++ b/src/mlang/test_framework/irj_file.mli @@ -14,6 +14,8 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -val parse_file : string -> Irj_ast.irj_file +type input = Filename of string | Contents of string + +val parse_file : input -> Irj_ast.irj_file (** [parse_file file] loads the content of a given IRJ [file] in a simple datastructure. *) diff --git a/src/mlang/test_framework/test_interpreter.ml b/src/mlang/test_framework/test_interpreter.ml index dd49135ca..b1642c716 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -36,7 +36,7 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : 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 + let ancsded_val = Com.Float (float_of_int (!Config.income_year + 1)) in Com.Var.Map.one ancsded ancsded_val with _ -> Com.Var.Map.empty in @@ -135,8 +135,11 @@ let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : exception InterpError of int -let check_test (program : Mir.program) (test_name : string) - (value_sort : Cli.value_sort) (round_ops : Cli.round_ops) : unit = +type target_dbg_info = { target : string; dbg_info : Dbg_info.t } + +let check_test (program : Mir.program) (test_input : Irj_file.input) + (value_sort : Config.value_sort) (round_ops : Config.round_ops) : + target_dbg_info list = let check_vars exp vars = let test_error_margin = 0.01 in let fold vname f nb = @@ -171,23 +174,56 @@ let check_test (program : Mir.program) (test_name : string) StrSet.iter (Cli.error_print "KO | unexpected error: %s") unexAnos; StrSet.cardinal missAnos + StrSet.cardinal unexAnos in - 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 + let dbg_warning = !Config.warning_flag in + let dbg_time = !Config.display_time in + Config.warning_flag := false; + Config.display_time := false; + Cli.debug_print "Parsing %s..." + (match test_input with Filename s -> s | Contents _ -> "given contents"); + let t = Irj_file.parse_file test_input 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 = + let dbg_info = Dbg_info.empty in + let add_input_var_to_info var lit dbg_info = + let open Dbg_info in + let name = Com.Var.name_str var in + let pos = Com.Var.name var |> Pos.get in + let origin = + Origin.make (Pos.get_file pos) (Pos.get_start_line pos) + (Pos.get_end_line pos) Origin.Declared + in + let tick = Tick.tick () in + let descr = + match Com.Var.descr_str var with + | exception _ -> None + | descr -> Some descr + in + let runtime = Info.Runtime.make origin lit (Some name) in + let runtimes = Tick.Map.add tick runtime dbg_info.runtimes in + let static = Info.Static.make name origin true descr in + let statics = IntMap.add runtime.hash static dbg_info.statics in + let ledger = StrMap.add name tick dbg_info.ledger in + { dbg_info with runtimes; statics; ledger } + in + let dbg_info = + Com.Var.Map.fold add_input_var_to_info inst.vars dbg_info + in + let varMap, anoSet, dbg_info = Mir_interpreter.evaluate_program program inst.vars inst.events - value_sort round_ops + value_sort round_ops (Some dbg_info) + in + let target_dbg_info = + match (!Config.platform, dbg_info) with + | Server _, Some dbg_info -> + let target_dbg_info = { dbg_info; target = inst.label } in + Some target_dbg_info + | _, _ -> None in let nbErrs = check_vars inst.expectedVars varMap @@ -195,19 +231,21 @@ let check_test (program : Mir.program) (test_name : string) in if nbErrs <= 0 then ( Cli.debug_print "OK!"; - check insts) + target_dbg_info :: check insts) else ( Cli.debug_print "KO!"; raise (InterpError nbErrs)) in - check insts; - Cli.warning_flag := dbg_warning; - Cli.display_time := dbg_time + let infos = check insts in + let clean_infos = List.filter_map (fun i -> i) infos in + Config.warning_flag := dbg_warning; + Config.display_time := dbg_time; + clean_infos type process_acc = string list * int StrMap.t let check_all_tests (p : Mir.program) (test_dir : string) - (value_sort : Cli.value_sort) (round_ops : Cli.round_ops) + (value_sort : Config.value_sort) (round_ops : Config.round_ops) (filter_function : string -> bool) = let arr = Sys.readdir test_dir in let arr = @@ -220,20 +258,21 @@ 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*) + let dbg_warning = !Config.warning_flag in + let dbg_time = !Config.display_time in + Config.warning_flag := false; + Config.display_time := false; + (* let _, finish = Config.create_progress_bar "Testing files" in*) let process (name : string) ((successes, failures) : process_acc) : process_acc = let module Interp = (val Mir_interpreter.get_interp value_sort round_ops : Mir_interpreter.S) in try - Cli.debug_flag := false; - check_test p (test_dir ^ name) value_sort round_ops; - Cli.debug_flag := true; + Config.debug_flag := false; + let file = Irj_file.Filename (test_dir ^ name) in + ignore @@ check_test p file value_sort round_ops; + Config.debug_flag := true; Cli.result_print "%s" name; (name :: successes, failures) with @@ -267,8 +306,8 @@ let check_all_tests (p : Mir.program) (test_dir : string) *) in (* finish "done!"; *) - Cli.warning_flag := dbg_warning; - Cli.display_time := dbg_time; + Config.warning_flag := dbg_warning; + Config.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!" @@ -279,22 +318,22 @@ let check_all_tests (p : Mir.program) (test_dir : string) f) let check_one_test (p : Mir.program) (name : string) - (value_sort : Cli.value_sort) (round_ops : Cli.round_ops) = + (value_sort : Config.value_sort) (round_ops : Config.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 dbg_warning = !Config.warning_flag in + let dbg_time = !Config.display_time in + Config.warning_flag := false; + Config.display_time := false; + (* let _, finish = Config.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; + Config.debug_flag := false; + ignore @@ check_test p (Irj_file.Filename name) value_sort round_ops; + Config.debug_flag := true; Cli.result_print "%s" name; None with @@ -320,8 +359,8 @@ let check_one_test (p : Mir.program) (name : string) raise e in (* finish "done!"; *) - Cli.warning_flag := dbg_warning; - Cli.display_time := dbg_time; + Config.warning_flag := dbg_warning; + Config.display_time := dbg_time; match is_ok with | None -> Cli.result_print "No failure!" | Some 0 -> Cli.error_print "Unexpected failure" diff --git a/src/mlang/test_framework/test_interpreter.mli b/src/mlang/test_framework/test_interpreter.mli index 5fe88b654..5b8f37e85 100644 --- a/src/mlang/test_framework/test_interpreter.mli +++ b/src/mlang/test_framework/test_interpreter.mli @@ -13,16 +13,27 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) +type target_dbg_info = { target : string; dbg_info : Dbg_info.t } + val check_all_tests : Mir.program -> string -> - Cli.value_sort -> - Cli.round_ops -> + Config.value_sort -> + Config.round_ops -> (string -> bool) -> unit (** [check_all_tests p folder vs ro filter] Executes [p] with all tests in [folder] whose name satisfy [filter]. *) +val check_test : + Mir.program -> + Irj_file.input -> + Config.value_sort -> + Config.round_ops -> + target_dbg_info list + val check_one_test : - Mir.program -> string -> Cli.value_sort -> Cli.round_ops -> unit + Mir.program -> string -> Config.value_sort -> Config.round_ops -> unit (** Same as [check_all_tests], but for one test. *) + +exception InterpError of int diff --git a/src/mlang/utils/cli.ml b/src/mlang/utils/cli.ml index e84b321b0..b965f4aff 100644 --- a/src/mlang/utils/cli.ml +++ b/src/mlang/utils/cli.ml @@ -23,6 +23,10 @@ (** The command line interface is declared using {!module Cmdliner} *) open Cmdliner +open Config +module Cmdliner = Cmdliner +module Term = Cmdliner.Term +module ANSITerminal = ANSITerminal let files = Arg.( @@ -54,15 +58,6 @@ let display_time = & info [ "display_time"; "t" ] ~doc:"Displays timing information (use with --debug)") -let dep_graph_file = - let doc = - "Name of the file where the variable dependency graph should be output \ - (use with --debug)" - in - Arg.( - value & opt file "dep_graph.dot" - & info [ "dep_graph_file"; "g" ] ~docv:"DEP_GRAPH" ~doc) - let no_print_cycles = let doc = "If set, disable the eventual circular dependencies repport" in Arg.(value & flag & info [ "no_print_cycles"; "c" ] ~doc) @@ -142,6 +137,11 @@ let roundops = running on a mainframe. In this case, the size of the long type has \ to be specified; it can be either 32 or 64.") +let plain_output = + Arg.( + value & flag + & info [ "plain_output" ] ~doc:"Do not print terminal characters.") + let comparison_error_margin_cli = Arg.( value @@ -160,7 +160,7 @@ let comparison_error_margin_cli = let income_year_cli = Arg.( value - & opt (some int) None + & opt int (1900 + (Unix.localtime (Unix.time ())).Unix.tm_year - 1) & info [ "income-year" ] ~docv:"INCOME_YEAR" ~doc:"Set the year of the income.") @@ -185,10 +185,10 @@ let dgfip_options = let mlang_t f = Term.( const f $ files $ applications $ without_dgfip_m $ debug $ var_info_debug - $ display_time $ dep_graph_file $ no_print_cycles $ backend $ output - $ run_all_tests $ dgfip_test_filter $ run_test $ mpp_function - $ optimize_unsafe_float $ precision $ roundops $ comparison_error_margin_cli - $ income_year_cli $ m_clean_calls $ dgfip_options) + $ display_time $ no_print_cycles $ backend $ output $ run_all_tests + $ dgfip_test_filter $ run_test $ mpp_function $ optimize_unsafe_float + $ precision $ roundops $ comparison_error_margin_cli $ income_year_cli + $ m_clean_calls $ dgfip_options $ plain_output) let info = let doc = @@ -232,115 +232,6 @@ let info = | Some v -> Build_info.V1.Version.to_string v) ~doc ~exits ~man -type value_sort = - | RegularFloat - | MPFR of int (* bitsize of the floats *) - | BigInt of int (* precision of the fixed point *) - | Interval - | Rational - -type round_ops = RODefault | ROMulti | ROMainframe of int -(* size of type long, either 32 or 64 *) - -type backend = Dgfip_c | UnknownBackend - -type execution_mode = - | SingleTest of string - | MultipleTests of string - | Extraction - -type files = NonEmpty of string list - -let get_files = function NonEmpty l -> l - -(* This feels weird to put here, but by construction it should not happen.*) -let source_files : files ref = ref (NonEmpty []) - -let application_names : string list ref = ref [] - -let without_dgfip_m = ref false - -let dep_graph_file : string ref = ref "dep_graph.dot" - -let verify_flag = ref false - -let debug_flag = ref false - -let var_info_flag = ref false - -let var_info_debug = ref [] - -let warning_flag = ref true - -let no_print_cycles_flag = ref false - -let display_time = ref false - -let output_file = ref "" - -let optimize_unsafe_float = ref false - -let m_clean_calls = ref false - -let value_sort = ref RegularFloat - -let round_ops = ref RODefault - -let backend = ref UnknownBackend - -let dgfip_test_filter = ref false - -let mpp_function = ref "" - -let dgfip_flags = ref Dgfip_options.default_flags - -let execution_mode = ref Extraction - -(* Default value for the epsilon slack when comparing things in the - interpreter *) -let comparison_error_margin = ref 0.000001 - -let income_year = ref 0 - -let set_all_arg_refs (files_ : files) applications_ (without_dgfip_m_ : bool) - (debug_ : bool) (var_info_debug_ : string list) (display_time_ : bool) - (dep_graph_file_ : string) (no_print_cycles_ : bool) - (output_file_ : string option) (optimize_unsafe_float_ : bool) - (m_clean_calls_ : bool) (comparison_error_margin_ : float option) - (income_year_ : int option) (value_sort_ : value_sort) - (round_ops_ : round_ops) (backend_ : backend) (dgfip_test_filter_ : bool) - (mpp_function_ : string) (dgfip_flags_ : Dgfip_options.flags) - (execution_mode_ : execution_mode) = - source_files := files_; - application_names := applications_; - without_dgfip_m := without_dgfip_m_; - debug_flag := debug_; - var_info_debug := var_info_debug_; - var_info_flag := !var_info_debug <> []; - display_time := display_time_; - dep_graph_file := dep_graph_file_; - no_print_cycles_flag := no_print_cycles_; - optimize_unsafe_float := optimize_unsafe_float_; - m_clean_calls := m_clean_calls_; - execution_mode := execution_mode_; - (income_year := - match income_year_ with - | Some y -> y - | None -> 1900 + (Unix.localtime (Unix.time ())).Unix.tm_year - 1); - value_sort := value_sort_; - round_ops := round_ops_; - backend := backend_; - dgfip_test_filter := dgfip_test_filter_; - mpp_function := mpp_function_; - dgfip_flags := dgfip_flags_; - match output_file_ with - | None -> () - | Some o -> ( - output_file := o; - match comparison_error_margin_ with - | None -> () - | Some m -> comparison_error_margin := m) - (**{1 Terminal formatting}*) let concat_with_line_depending_prefix_and_suffix (prefix : int -> string) @@ -387,8 +278,9 @@ let time_marker () = let format_with_style (styles : ANSITerminal.style list) (str : ('a, unit, string) format) = - if true (* can depend on a stylr flag *) then ANSITerminal.sprintf styles str - else Printf.sprintf str + if !Config.plain_output (* can depend on a stylr flag *) then + Printf.sprintf str + else ANSITerminal.sprintf styles str (** Prints [\[DEBUG\]] in purple on the terminal standard output as well as timing since last debug *) @@ -431,13 +323,13 @@ let debug_print ?(endline = "\n") kont = (fun str -> Format.printf "%a%s%s@?" (fun _ -> debug_marker) - !display_time str endline) + !Config.display_time str endline) kont else Format.ifprintf Format.std_formatter kont let var_info_print kont = ANSITerminal.erase ANSITerminal.Eol; - if !var_info_flag then + if !Config.var_info_flag then Format.kasprintf (fun str -> Format.printf "%a%s@." (fun _ -> var_info_marker) () str) kont @@ -492,3 +384,99 @@ let result_print kont = Format.kasprintf (fun str -> Format.printf "%a%s@." (fun _ -> result_marker) () str) kont + +let indent_number (s : string) : int = + try + let rec aux (i : int) = if s.[i] = ' ' then aux (i + 1) else i in + aux 0 + with Invalid_argument _ -> String.length s + +let format_matched_line pos (line : string) (line_no : int) : string = + let line_indent = indent_number line in + let error_indicator_style = [ ANSITerminal.red; ANSITerminal.Bold ] in + let sline = Pos.get_start_line pos in + let eline = Pos.get_end_line pos in + let line_start_col = + if line_no = sline then Pos.get_start_column pos else 1 + in + let line_end_col = + if line_no = eline then Pos.get_end_column pos else String.length line + 1 + in + let line_length = String.length line + 1 in + line + ^ + if line_no >= sline && line_no <= eline then + "\n" + ^ + if line_no = sline && line_no = eline then + format_with_style error_indicator_style "%*s" (line_end_col - 1) + (String.make (line_end_col - line_start_col) '^') + else if line_no = sline && line_no <> eline then + format_with_style error_indicator_style "%*s" (line_length - 1) + (String.make (line_length - line_start_col) '^') + else if line_no <> sline && line_no <> eline then + format_with_style error_indicator_style "%*s%s" line_indent "" + (String.make (line_length - line_indent) '^') + else if line_no <> sline && line_no = eline then + format_with_style error_indicator_style "%*s%*s" line_indent "" + (line_end_col - 1 - line_indent) + (String.make (line_end_col - line_indent) '^') + else assert false (* should not happen *) + else "" + +let format_lines pos lines = + let filename = Pos.get_file pos in + let sline = Pos.get_start_line pos in + let eline = Pos.get_end_line pos in + let blue_style = [ ANSITerminal.Bold; ANSITerminal.blue ] in + let spaces = int_of_float (log10 (float_of_int eline)) + 1 in + let lines = + List.mapi (fun i line -> format_matched_line pos line (i + sline)) lines + in + format_with_style blue_style "%*s--> %s\n%s" spaces "" filename + (add_prefix_to_each_line + (Printf.sprintf "\n%s" (String.concat "\n" lines)) + (fun i -> + let cur_line = sline + i - 1 in + if + cur_line >= sline + && cur_line <= sline + (2 * (eline - sline)) + && cur_line mod 2 = sline mod 2 + then + format_with_style blue_style "%*d | " spaces + (sline + ((cur_line - sline) / 2)) + else if cur_line >= sline && cur_line < sline then + format_with_style blue_style "%*d | " spaces cur_line + else if + cur_line <= sline + (2 * (eline - sline)) + 1 + && cur_line > sline + (2 * (eline - sline)) + 1 + then + format_with_style blue_style "%*d | " spaces + (cur_line - (eline - sline + 1)) + else format_with_style blue_style "%*s | " spaces "")) + +let retrieve_loc_text (pos : Pos.t) : string = + let filename = Pos.get_file pos in + if filename = "" then "No position information" + else + let lines = + match !Config.platform with + | Server filemap -> begin + match StrMap.find_opt filename filemap with + | None -> failwith "Pos error" + | Some contents -> + let lines = String.split_on_char '\n' contents in + [ List.nth lines (Pos.get_start_line pos - 1) ] + end + | Executable -> + let get_lines = + match File.open_file_for_text_extraction pos with + | exception Sys_error _ -> + error_print "File not found for displaying position : \"%s\"" + filename; + failwith "Pos error" + | get_lines -> get_lines + in + get_lines 1 + in + format_lines pos lines diff --git a/src/mlang/utils/cli.mli b/src/mlang/utils/cli.mli index 2ca786c71..b288fecaf 100644 --- a/src/mlang/utils/cli.mli +++ b/src/mlang/utils/cli.mli @@ -25,7 +25,6 @@ val mlang_t : bool -> string list -> bool -> - string -> bool -> string option -> string option -> @@ -37,9 +36,10 @@ val mlang_t : string option -> string option -> float option -> - int option -> + int -> bool -> string list option -> + bool -> 'a) -> 'a Cmdliner.Term.t (** Mlang binary command-line arguments parsing function *) @@ -47,122 +47,6 @@ val mlang_t : val info : Cmdliner.Cmd.info (** Command-line man page for --help *) -(**{2 Flags and parameters}*) - -(** According on the [value_sort], a specific interpreter will be called with - the right kind of floating-point value *) -type value_sort = - | RegularFloat - | MPFR of int (** bitsize of the floats *) - | BigInt of int (** precision of the fixed point *) - | Interval - | Rational - -(** Rounding operations to use in the interpreter. They correspond to the - rounding operations used by the DGFiP calculator in different execution - contexts. - - - RODefault: rounding operations used in the PC/single-thread context - - ROMulti: rouding operations used in the PC/multi-thread context - - ROMainframe rounding operations used in the mainframe context *) -type round_ops = - | RODefault - | ROMulti - | ROMainframe of int (** size of type long, either 32 or 64 *) - -type backend = Dgfip_c | UnknownBackend - -type execution_mode = - | SingleTest of string - | MultipleTests of string - | Extraction - -type files = NonEmpty of string list - -val get_files : files -> string list - -val source_files : files ref -(** M source files to be compiled *) - -val application_names : string list ref - -val dep_graph_file : string ref -(** Prefix for debug graph output files *) - -val without_dgfip_m : bool ref - -val verify_flag : bool ref -(** Use Z3 to check if verif rules hold all the time *) - -val debug_flag : bool ref -(** Prints debug information *) - -val var_info_flag : bool ref -(** Print infomation about variables declared, defined ou used incorrectly *) - -val var_info_debug : string list ref -(** Prints even more information but only about some variables members of a list -*) - -val warning_flag : bool ref -(** Print warning info *) - -val no_print_cycles_flag : bool ref -(** Dump circular definitions of variables *) - -val display_time : bool ref -(** Displays timing information *) - -val output_file : string ref -(** Output file *) - -val optimize_unsafe_float : bool ref -(** Activate unsafe floating point optimizations *) - -val m_clean_calls : bool ref -(** Clean regular variables between M calls *) - -val comparison_error_margin : float ref - -val income_year : int ref - -val value_sort : value_sort ref - -val round_ops : round_ops ref - -val backend : backend ref - -val dgfip_test_filter : bool ref - -val mpp_function : string ref - -val dgfip_flags : Dgfip_options.flags ref - -val execution_mode : execution_mode ref - -val set_all_arg_refs : - (* files *) files -> - (* applications *) string list -> - (* without_dgfip_m *) bool -> - (* debug *) bool -> - (* var_info_debug *) string list -> - (* display_time *) bool -> - (* dbg_graph_file *) string -> - (* prints_cycles *) bool -> - (* output_file *) string option -> - (* optimize_unsafe_float *) bool -> - (* m_clean_call *) bool -> - (* comparison_error_margin*) float option -> - (* income_year *) int option -> - value_sort -> - round_ops -> - backend -> - (* dgfip_test_filter *) bool -> - (* mpp_function *) string -> - (* dgfip_flags *) Dgfip_options.flags -> - (* execution_mode *) execution_mode -> - unit - val add_prefix_to_each_line : string -> (int -> string) -> string (** [add_prefix_to_each_line msg prefix] will print msg but each line with line number [i] starts with the string [prefix i]*) @@ -189,3 +73,9 @@ val create_progress_bar : string -> (string -> unit) * (string -> unit) (** Returns two functions: the first one, [current_progress], has to be called during the progress loop and the other one, [finish], has to be called at the end of the progressive task. *) + +val retrieve_loc_text : Pos.t -> string +(** [retrieve_loc_text pos] reads the source file associated with [pos] and + returns a formatted string of the code at that location, with the exact + columns highlighted. This is used to display code snippets in error + messages. *) diff --git a/src/mlang/utils/config.ml b/src/mlang/utils/config.ml new file mode 100644 index 000000000..568db3e6c --- /dev/null +++ b/src/mlang/utils/config.ml @@ -0,0 +1,178 @@ +module Dgfip_options = struct + type flags = { + (* -m *) annee_revenu : int; + (* -P *) flg_correctif : bool; + (* flg_correctif true by default, -P makes it false *) + (* -R *) flg_iliad : bool; + (* also implied by "iliad" in !Cli.application_names; disabled by -U *) + (* -R *) flg_pro : bool; + (* also implied by "pro" in !Cli.application_names; disabled by -U *) + (* -U *) flg_cfir : bool; + (* disabled by -R *) + (* -b *) flg_gcos : bool; + (* -b0 and -b1 ; disabled by -U and -R *) + (* -b *) flg_tri_ebcdic : bool; + (* -b1 only *) + (* -s *) flg_short : bool; + (* -r *) flg_register : bool; + (* -O *) flg_optim_min_max : bool; + (* -X *) flg_extraction : bool; + (* -D *) flg_genere_libelle_restituee : bool; + (* -S *) flg_controle_separe : bool; + (* -I *) flg_controle_immediat : bool; + (* unused *) + (* -o *) flg_overlays : bool; + (* -Z *) flg_colors : bool; + (* -L *) flg_ticket : bool; + (* -t *) flg_trace : bool; + (* -g *) flg_debug : bool; + (* also implied by -t *) + (* -k *) nb_debug_c : int; + (* -x *) + xflg : bool; + (* Flags to deal with in a particular way : -c compilation mode -l link + mode -v specify the variable file (tgv.m) -e specify the error file + (err.m) *) + (* Other flags, not used in makefiles -h dir_var_h -i flg_ident + -K flg_optim_cte -G flg_listing (+genere_cre = FALSE) -p + flag_phase -f flg_ench_init -E cvt_file -g flg_debug -a flg_api -T + flg_trace_irdata *) + } + + let default_flags = + { + annee_revenu = 1991; + flg_correctif = true; + flg_iliad = false; + flg_pro = false; + flg_cfir = false; + flg_gcos = false; + flg_tri_ebcdic = false; + flg_short = false; + flg_register = false; + flg_optim_min_max = false; + flg_extraction = false; + flg_genere_libelle_restituee = false; + flg_controle_separe = false; + flg_controle_immediat = false; + flg_overlays = false; + flg_colors = false; + flg_ticket = false; + flg_trace = false; + flg_debug = false; + nb_debug_c = 0; + xflg = false; + } +end + +type value_sort = + | RegularFloat + | MPFR of int (* bitsize of the floats *) + | BigInt of int (* precision of the fixed point *) + | Interval + | Rational + +type round_ops = RODefault | ROMulti | ROMainframe of int +(* size of type long, either 32 or 64 *) + +type backend = Dgfip_c | UnknownBackend + +type execution_mode = + | SingleTest of string + | MultipleTests of string + | Extraction + +type files = NonEmpty of string list + +type platform = Executable | Server of string StrMap.t + +(* Flags inherited from the old compiler *) + +let get_files = function NonEmpty l -> l + +(* This feels weird to put here, but by construction it should not happen.*) +let source_files : files ref = ref (NonEmpty []) + +let application_names : string list ref = ref [] + +let without_dgfip_m = ref false + +let verify_flag = ref false + +let debug_flag = ref false + +let var_info_flag = ref false + +let var_info_debug = ref [] + +let warning_flag = ref true + +let no_print_cycles_flag = ref false + +let display_time = ref false + +let output_file = ref "" + +let optimize_unsafe_float = ref false + +let m_clean_calls = ref false + +let value_sort = ref RegularFloat + +let round_ops = ref RODefault + +let backend = ref UnknownBackend + +let dgfip_test_filter = ref false + +let mpp_function = ref "" + +let dgfip_flags = ref Dgfip_options.default_flags + +let execution_mode = ref Extraction + +(* Default value for the epsilon slack when comparing things in the + interpreter *) +let comparison_error_margin = ref 0.000001 + +let income_year = ref 0 + +let platform = ref Executable + +let plain_output = ref true + +let set_all_arg_refs (files_ : files) applications_ (without_dgfip_m_ : bool) + (debug_ : bool) (var_info_debug_ : string list) (display_time_ : bool) + (no_print_cycles_ : bool) (output_file_ : string option) + (optimize_unsafe_float_ : bool) (m_clean_calls_ : bool) + (comparison_error_margin_ : float option) (income_year_ : int) + (value_sort_ : value_sort) (round_ops_ : round_ops) (backend_ : backend) + (dgfip_test_filter_ : bool) (mpp_function_ : string) + (dgfip_flags_ : Dgfip_options.flags) (execution_mode_ : execution_mode) + (plain_output_ : bool) = + source_files := files_; + application_names := applications_; + without_dgfip_m := without_dgfip_m_; + debug_flag := debug_; + var_info_debug := var_info_debug_; + var_info_flag := !var_info_debug <> []; + display_time := display_time_; + no_print_cycles_flag := no_print_cycles_; + optimize_unsafe_float := optimize_unsafe_float_; + m_clean_calls := m_clean_calls_; + execution_mode := execution_mode_; + income_year := income_year_; + value_sort := value_sort_; + round_ops := round_ops_; + backend := backend_; + dgfip_test_filter := dgfip_test_filter_; + mpp_function := mpp_function_; + dgfip_flags := dgfip_flags_; + plain_output := plain_output_; + match output_file_ with + | None -> () + | Some o -> ( + output_file := o; + match comparison_error_margin_ with + | None -> () + | Some m -> comparison_error_margin := m) diff --git a/src/mlang/utils/config.mli b/src/mlang/utils/config.mli new file mode 100644 index 000000000..5024f1d98 --- /dev/null +++ b/src/mlang/utils/config.mli @@ -0,0 +1,152 @@ +(**{2 Flags and parameters}*) + +(** Special dgfip options for the compirateur *) + +module Dgfip_options : sig + type flags = { + annee_revenu : int; + flg_correctif : bool; + flg_iliad : bool; + flg_pro : bool; + flg_cfir : bool; + flg_gcos : bool; + flg_tri_ebcdic : bool; + flg_short : bool; + flg_register : bool; + flg_optim_min_max : bool; + flg_extraction : bool; + flg_genere_libelle_restituee : bool; + flg_controle_separe : bool; + flg_controle_immediat : bool; + flg_overlays : bool; + flg_colors : bool; + flg_ticket : bool; + flg_trace : bool; + flg_debug : bool; + nb_debug_c : int; + xflg : bool; + } + + val default_flags : flags +end + +(** According on the [value_sort], a specific interpreter will be called with + the right kind of floating-point value *) +type value_sort = + | RegularFloat + | MPFR of int (** bitsize of the floats *) + | BigInt of int (** precision of the fixed point *) + | Interval + | Rational + +(** Rounding operations to use in the interpreter. They correspond to the + rounding operations used by the DGFiP calculator in different execution + contexts. + + - RODefault: rounding operations used in the PC/single-thread context + - ROMulti: rouding operations used in the PC/multi-thread context + - ROMainframe rounding operations used in the mainframe context *) +type round_ops = + | RODefault + | ROMulti + | ROMainframe of int (** size of type long, either 32 or 64 *) + +type backend = Dgfip_c | UnknownBackend + +type execution_mode = + | SingleTest of string + | MultipleTests of string + | Extraction + +type files = NonEmpty of string list + +type platform = + | Executable + | Server of string StrMap.t + (** This type represents how the interpreter is run. By default, it's as an + Executable *) + +val get_files : files -> string list + +val source_files : files ref +(** M source files to be compiled *) + +val application_names : string list ref + +val without_dgfip_m : bool ref + +val verify_flag : bool ref +(** Use Z3 to check if verif rules hold all the time *) + +val debug_flag : bool ref +(** Prints debug information *) + +val var_info_flag : bool ref +(** Print infomation about variables declared, defined ou used incorrectly *) + +val var_info_debug : string list ref +(** Prints even more information but only about some variables members of a list +*) + +val warning_flag : bool ref +(** Print warning info *) + +val no_print_cycles_flag : bool ref +(** Dump circular definitions of variables *) + +val display_time : bool ref +(** Displays timing information *) + +val output_file : string ref +(** Output file *) + +val optimize_unsafe_float : bool ref +(** Activate unsafe floating point optimizations *) + +val m_clean_calls : bool ref +(** Clean regular variables between M calls *) + +val comparison_error_margin : float ref + +val income_year : int ref + +val value_sort : value_sort ref + +val round_ops : round_ops ref + +val backend : backend ref + +val dgfip_test_filter : bool ref + +val mpp_function : string ref + +val dgfip_flags : Dgfip_options.flags ref + +val execution_mode : execution_mode ref + +val platform : platform ref + +val plain_output : bool ref + +val set_all_arg_refs : + (* files *) files -> + (* applications *) string list -> + (* without_dgfip_m *) bool -> + (* debug *) bool -> + (* var_info_debug *) string list -> + (* display_time *) bool -> + (* prints_cycles *) bool -> + (* output_file *) string option -> + (* optimize_unsafe_float *) bool -> + (* m_clean_call *) bool -> + (* comparison_error_margin*) float option -> + (* income_year *) int -> + value_sort -> + round_ops -> + backend -> + (* dgfip_test_filter *) bool -> + (* mpp_function *) string -> + (* dgfip_flags *) Dgfip_options.flags -> + (* execution_mode *) execution_mode -> + (* plain_output *) bool -> + unit diff --git a/src/mlang/utils/dgfip_options.ml b/src/mlang/utils/dgfip_options.ml index 9d5ffdd78..6e02ec4d1 100644 --- a/src/mlang/utils/dgfip_options.ml +++ b/src/mlang/utils/dgfip_options.ml @@ -97,106 +97,41 @@ let info = in Cmd.info "mlang --dgfip_options" ~doc ~man -(* Flags inherited from the old compiler *) -type flags = { - (* -m *) annee_revenu : int; - (* -P *) flg_correctif : bool; - (* flg_correctif true by default, -P makes it false *) - (* -R *) flg_iliad : bool; - (* also implied by "iliad" in !Cli.application_names; disabled by -U *) - (* -R *) flg_pro : bool; - (* also implied by "pro" in !Cli.application_names; disabled by -U *) - (* -U *) flg_cfir : bool; - (* disabled by -R *) - (* -b *) flg_gcos : bool; - (* -b0 and -b1 ; disabled by -U and -R *) - (* -b *) flg_tri_ebcdic : bool; - (* -b1 only *) - (* -s *) flg_short : bool; - (* -r *) flg_register : bool; - (* -O *) flg_optim_min_max : bool; - (* -X *) flg_extraction : bool; - (* -D *) flg_genere_libelle_restituee : bool; - (* -S *) flg_controle_separe : bool; - (* -I *) flg_controle_immediat : bool; - (* unused *) - (* -o *) flg_overlays : bool; - (* -Z *) flg_colors : bool; - (* -L *) flg_ticket : bool; - (* -t *) flg_trace : bool; - (* -g *) flg_debug : bool; - (* also implied by -t *) - (* -k *) nb_debug_c : int; - (* -x *) - xflg : bool; - (* Flags to deal with in a particular way : -c compilation mode -l link - mode -v specify the variable file (tgv.m) -e specify the error file - (err.m) *) - (* Other flags, not used in makefiles -h dir_var_h -i flg_ident - -K flg_optim_cte -G flg_listing (+genere_cre = FALSE) -p - flag_phase -f flg_ench_init -E cvt_file -g flg_debug -a flg_api -T - flg_trace_irdata *) -} - -let default_flags = - { - annee_revenu = 1991; - flg_correctif = true; - flg_iliad = false; - flg_pro = false; - flg_cfir = false; - flg_gcos = false; - flg_tri_ebcdic = false; - flg_short = false; - flg_register = false; - flg_optim_min_max = false; - flg_extraction = false; - flg_genere_libelle_restituee = false; - flg_controle_separe = false; - flg_controle_immediat = false; - flg_overlays = false; - flg_colors = false; - flg_ticket = false; - flg_trace = false; - flg_debug = false; - nb_debug_c = 0; - xflg = false; - } - let handler ~(application_names : string list) (income_year : int) (iliad_pro : bool) (cfir : bool) (batch : int option) (primitive_only : bool) (extraction : bool) (separate_controls : bool) (immediate_controls : bool) (overlays : bool) (optim_min_max : bool) (register : bool) (short : bool) (output_labels : bool) (debug : bool) (nb_debug_c : int) (trace : bool) (ticket : bool) (colored_output : bool) - (cross_references : bool) : flags = + (cross_references : bool) : Config.Dgfip_options.flags = let has_iliad = List.mem "iliad" application_names in let has_pro = List.mem "pro" application_names in - { - (* iliad, pro, (GP) *) - annee_revenu = income_year; - flg_correctif = not primitive_only; - flg_iliad = - ((iliad_pro && not cfir) || has_iliad) && not (Option.is_some batch); - flg_pro = (has_pro || iliad_pro) && not cfir; - flg_cfir = cfir && not iliad_pro; - flg_gcos = Option.is_some batch && (not iliad_pro) && not cfir; - flg_tri_ebcdic = (match batch with Some 1 -> true | _ -> false); - flg_short = short; - flg_register = register; - flg_optim_min_max = optim_min_max; - flg_extraction = extraction; - flg_genere_libelle_restituee = output_labels; - flg_controle_separe = separate_controls; - flg_controle_immediat = immediate_controls; - flg_overlays = overlays; - flg_colors = colored_output; - flg_ticket = ticket; - flg_trace = trace; - flg_debug = debug || trace; - nb_debug_c; - xflg = cross_references; - } + Config.Dgfip_options. + { + (* iliad, pro, (GP) *) + annee_revenu = income_year; + flg_correctif = not primitive_only; + flg_iliad = + ((iliad_pro && not cfir) || has_iliad) && not (Option.is_some batch); + flg_pro = (has_pro || iliad_pro) && not cfir; + flg_cfir = cfir && not iliad_pro; + flg_gcos = Option.is_some batch && (not iliad_pro) && not cfir; + flg_tri_ebcdic = (match batch with Some 1 -> true | _ -> false); + flg_short = short; + flg_register = register; + flg_optim_min_max = optim_min_max; + flg_extraction = extraction; + flg_genere_libelle_restituee = output_labels; + flg_controle_separe = separate_controls; + flg_controle_immediat = immediate_controls; + flg_overlays = overlays; + flg_colors = colored_output; + flg_ticket = ticket; + flg_trace = trace; + flg_debug = debug || trace; + nb_debug_c; + xflg = cross_references; + } let process_dgfip_options ~application_names options = let options = Array.of_list ("mlang" :: options) in diff --git a/src/mlang/utils/dgfip_options.mli b/src/mlang/utils/dgfip_options.mli new file mode 100644 index 000000000..697d2da75 --- /dev/null +++ b/src/mlang/utils/dgfip_options.mli @@ -0,0 +1,27 @@ +val handler : + application_names:string list -> + int -> + bool -> + bool -> + int option -> + bool -> + bool -> + bool -> + bool -> + bool -> + bool -> + bool -> + bool -> + bool -> + bool -> + int -> + bool -> + bool -> + bool -> + bool -> + Config.Dgfip_options.flags + +val process_dgfip_options : + application_names:string list -> + string list -> + Config.Dgfip_options.flags option diff --git a/src/mlang/utils/errors.ml b/src/mlang/utils/errors.ml index feffb2c51..dc2ea807c 100644 --- a/src/mlang/utils/errors.ml +++ b/src/mlang/utils/errors.ml @@ -27,7 +27,7 @@ let format_structured_error fmt (fun (msg, pos) -> Printf.sprintf "%s%s" (match msg with None -> "" | Some msg -> msg ^ "\n") - (Pos.retrieve_loc_text pos)) + (Cli.retrieve_loc_text pos)) pos)) (if List.length pos = 0 then "" else "\n") diff --git a/src/mlang/utils/file.ml b/src/mlang/utils/file.ml new file mode 100644 index 000000000..da1a34e0d --- /dev/null +++ b/src/mlang/utils/file.ml @@ -0,0 +1,50 @@ +let open_file_for_text_extraction (pos : Pos.t) = + let filename = Pos.get_file pos in + let sline = Pos.get_start_line pos in + let eline = Pos.get_end_line pos in + let oc, input_line_opt = + if filename == Dgfip_m.internal_m then + let input_line_opt : unit -> string option = + let curr = ref 0 in + let src = Dgfip_m.declarations in + let lng = String.length src in + let rec new_curr () = + if !curr < lng then + if src.[!curr] = '\n' then ( + let res = !curr in + incr curr; + Some res) + else ( + incr curr; + new_curr ()) + else None + in + function + | () -> ( + let p0 = !curr in + match new_curr () with + | None -> None + | Some p1 -> Some (String.sub Dgfip_m.declarations p0 (p1 - p0))) + in + (None, input_line_opt) + else + let ocf = open_in filename in + let input_line_opt () : string option = + try Some (input_line ocf) with End_of_file -> None + in + (Some ocf, input_line_opt) + in + let rec get_lines (n : int) : string list = + match input_line_opt () with + | Some line -> + if n < sline then get_lines (n + 1) + else if n >= sline && n <= eline then line :: get_lines (n + 1) + else [] + | None -> ( + match oc with + | Some ocf -> + close_in ocf; + [] + | _ -> []) + in + get_lines diff --git a/src/mlang/utils/pos.ml b/src/mlang/utils/pos.ml index f7b8dc9d3..9842836a5 100644 --- a/src/mlang/utils/pos.ml +++ b/src/mlang/utils/pos.ml @@ -15,6 +15,8 @@ (** {1 Source code position} *) +exception ConflictingFilenames of string * string + 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 *) @@ -24,9 +26,7 @@ let make (f : string) (loc : Lexing.position * Lexing.position) = 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; - failwith "Pos error" + raise @@ ConflictingFilenames (p1.pos_filename, p2.pos_filename) end else let b1, e1 = p1.pos_loc in @@ -127,121 +127,3 @@ let get_end_column (pos : t) : int = e.Lexing.pos_cnum - e.Lexing.pos_bol + 1 let get_file (pos : t) : string = (fst pos.pos_loc).Lexing.pos_fname - -let indent_number (s : string) : int = - try - let rec aux (i : int) = if s.[i] = ' ' then aux (i + 1) else i in - aux 0 - with Invalid_argument _ -> String.length s - -let retrieve_loc_text (pos : t) : string = - let filename = get_file pos in - let blue_style = [ ANSITerminal.Bold; ANSITerminal.blue ] in - if filename = "" then "No position information" - else - let sline = get_start_line pos in - let eline = get_end_line pos in - let oc, input_line_opt = - try - if filename == Dgfip_m.internal_m then - let input_line_opt : unit -> string option = - let curr = ref 0 in - let src = Dgfip_m.declarations in - let lng = String.length src in - let rec new_curr () = - if !curr < lng then - if src.[!curr] = '\n' then ( - let res = !curr in - incr curr; - Some res) - else ( - incr curr; - new_curr ()) - else None - in - function - | () -> ( - let p0 = !curr in - match new_curr () with - | None -> None - | Some p1 -> Some (String.sub Dgfip_m.declarations p0 (p1 - p0)) - ) - in - (None, input_line_opt) - else - let ocf = open_in filename in - let input_line_opt () : string option = - try Some (input_line ocf) with End_of_file -> None - in - (Some ocf, input_line_opt) - with Sys_error _ -> - Cli.error_print "File not found for displaying position : \"%s\"" - filename; - failwith "Pos error" - in - let print_matched_line (line : string) (line_no : int) : string = - let line_indent = indent_number line in - let error_indicator_style = [ ANSITerminal.red; ANSITerminal.Bold ] in - let line_start_col = - if line_no = sline then get_start_column pos else 1 - in - let line_end_col = - if line_no = eline then get_end_column pos else String.length line + 1 - in - let line_length = String.length line + 1 in - line - ^ - if line_no >= sline && line_no <= eline then - "\n" - ^ - if line_no = sline && line_no = eline then - Cli.format_with_style error_indicator_style "%*s" (line_end_col - 1) - (String.make (line_end_col - line_start_col) '^') - else if line_no = sline && line_no <> eline then - Cli.format_with_style error_indicator_style "%*s" (line_length - 1) - (String.make (line_length - line_start_col) '^') - else if line_no <> sline && line_no <> eline then - Cli.format_with_style error_indicator_style "%*s%s" line_indent "" - (String.make (line_length - line_indent) '^') - else if line_no <> sline && line_no = eline then - Cli.format_with_style error_indicator_style "%*s%*s" line_indent "" - (line_end_col - 1 - line_indent) - (String.make (line_end_col - line_indent) '^') - else assert false (* should not happen *) - else "" - in - let include_extra_count = 0 in - let rec get_lines (n : int) : string list = - match input_line_opt () with - | Some line -> - if n < sline - include_extra_count then get_lines (n + 1) - else if - n >= sline - include_extra_count && n <= eline + include_extra_count - then print_matched_line line n :: get_lines (n + 1) - else [] - | None -> [] - in - let pos_lines = get_lines 1 in - let spaces = int_of_float (log10 (float_of_int eline)) + 1 in - (match oc with Some ocf -> close_in ocf | _ -> ()); - Cli.format_with_style blue_style "%*s--> %s\n%s" spaces "" filename - (Cli.add_prefix_to_each_line - (Printf.sprintf "\n%s" (String.concat "\n" pos_lines)) - (fun i -> - let cur_line = sline - include_extra_count + i - 1 in - if - cur_line >= sline - && cur_line <= sline + (2 * (eline - sline)) - && cur_line mod 2 = sline mod 2 - then - Cli.format_with_style blue_style "%*d | " spaces - (sline + ((cur_line - sline) / 2)) - else if cur_line >= sline - include_extra_count && cur_line < sline - then Cli.format_with_style blue_style "%*d | " spaces cur_line - else if - cur_line <= sline + (2 * (eline - sline)) + 1 + include_extra_count - && cur_line > sline + (2 * (eline - sline)) + 1 - then - Cli.format_with_style blue_style "%*d | " spaces - (cur_line - (eline - sline + 1)) - else Cli.format_with_style blue_style "%*s | " spaces "")) diff --git a/src/mlang/utils/pos.mli b/src/mlang/utils/pos.mli index ce99340bf..bd43c80e3 100644 --- a/src/mlang/utils/pos.mli +++ b/src/mlang/utils/pos.mli @@ -55,12 +55,6 @@ val format : Format.formatter -> t -> unit position to the formatter [ppf]. Example: `in file foo.ml, from 10:5 to 12:20`. *) -val retrieve_loc_text : t -> string -(** [retrieve_loc_text pos] reads the source file associated with [pos] and - returns a formatted string of the code at that location, with the exact - columns highlighted. This is used to display code snippets in error - messages. *) - (** {2 Marked Value Manipulators} *) val none : t @@ -114,7 +108,3 @@ val get_file : t -> string (** [get_file pos] returns the filename associated with the position. *) (** {2 Helpers} *) - -val indent_number : string -> int -(** [indent_number s] returns the number of leading space characters in the - string [s]. *) diff --git a/src/server.ml b/src/server.ml new file mode 100644 index 000000000..47fe1be5d --- /dev/null +++ b/src/server.ml @@ -0,0 +1,122 @@ +open Ppx_yojson_conv_lib.Yojson_conv.Primitives +module Errors = Mlang.Errors +module Json = Yojson.Safe.Util + +let asf = Format.asprintf + +type file_assoc = string * string [@@deriving yojson] + +type filemap = file_assoc list [@@deriving yojson] + +module Msg = struct + type 'a msg_result = Ok of 'a | Err of string + + let yojson_of_msg_result aconv t = + match t with + | Err s -> `Assoc [ ("ok", `Bool false); ("error", `String s) ] + | Ok s -> `Assoc [ ("ok", `Bool true); ("value", aconv s) ] + + let msg_result_of_yojson _ _ = assert false + + module Out = struct + type parsing = { id : string; payload : string } [@@deriving yojson] + + let parsing name = + let m = { id = "parsing"; payload = name } in + let json = yojson_of_parsing m in + Yojson.Safe.to_string json + + type end_parsing = { id : string; payload : string } [@@deriving yojson] + + let end_parsing name = + let m = { id = "parsing-end"; payload = name } in + yojson_of_end_parsing m |> Yojson.Safe.to_string + + type 'a run_ret = { id : string; payload : 'a msg_result } + [@@deriving yojson] + + let run_ret (payload : 'a msg_result) = + let m = { id = "run-ret"; payload } in + yojson_of_run_ret yojson_of_string m |> Yojson.Safe.to_string + end + + module In = struct + type run = { + filemap : filemap; + application : string; + target : string; + irj_contents : string; + } + [@@deriving yojson] + end +end + +let make_callbacks socket : ServerDriver.callbacks = + let start_parsing name = + let msg = Msg.Out.parsing name in + Dream.send socket msg + in + let end_parsing name = + let msg = Msg.Out.end_parsing name in + Dream.send socket msg + in + { start_parsing; end_parsing } + +let parse_files socket payload = + let filemap = filemap_of_yojson payload in + let callbacks = make_callbacks socket in + ServerDriver.parse_files callbacks filemap + +let run socket payload = + let payload : Msg.In.run = Msg.In.run_of_yojson payload in + let callbacks = make_callbacks socket in + try + let%lwt dbg_info = + ServerDriver.run callbacks payload.filemap payload.irj_contents + payload.target payload.application + in + Format.printf "%s@." dbg_info; + let msg = Msg.Out.run_ret @@ Ok dbg_info in + Dream.send socket msg + with + | Errors.StructuredError (a, b, _) -> + let msg = asf "%a@." Errors.format_structured_error (a, b) in + let msg = Msg.Out.run_ret @@ Err msg in + Dream.send socket msg + | e -> + let msg = Printexc.to_string e in + let msg = Msg.Out.run_ret @@ Err msg in + let%lwt () = Dream.send socket msg in + raise e + +let () = + Dream.run ~port:4242 + @@ Dream.router + [ + Dream.get "/websocket" (fun _ -> + Dream.websocket (fun socket -> + let rec loop () = + match%lwt Dream.receive socket with + | Some msg -> + print_endline msg; + let json = Yojson.Safe.from_string msg in + let id = Json.member "id" json in + let payload = Json.member "payload" json in + let%lwt () = + match id with + | `Null -> Lwt.return () + | `String "parse-files" -> + Lwt.return @@ ignore @@ parse_files socket payload + | `String "run" -> + Lwt.return @@ ignore @@ run socket payload + | `String id -> + Dream.send socket + (Format.asprintf + {|{"msg": "unkown message '%s'"}|} id) + | _ -> assert false + in + loop () + | _ -> Dream.close_websocket socket + in + loop ())); + ] diff --git a/src/serverDriver.ml b/src/serverDriver.ml new file mode 100644 index 000000000..929b1136c --- /dev/null +++ b/src/serverDriver.ml @@ -0,0 +1,70 @@ +open Mlang + +type file_assoc = string * string + +type filemap = file_assoc list + +type callbacks = { + start_parsing : string -> unit Lwt.t; + end_parsing : string -> unit Lwt.t; +} + +let parse_file callbacks (name, contents) = + let%lwt () = callbacks.start_parsing name in + print_string "parsing "; + print_endline name; + try + let filebuf = Lexing.from_string contents in + print_endline "after lexing."; + let parsed = Mlang.Parsing.parse_lexbuf filebuf name in + let%lwt () = callbacks.end_parsing name in + Lwt.return parsed + with Errors.StructuredError (msg, pos_list, _kont) as _e -> + Cli.error_print "%a" Errors.format_structured_error (msg, pos_list); + Lwt.return [] + +let parse_files callbacks flat_filemap = + let t = Lwt_list.map_s (parse_file callbacks) flat_filemap in + t + +let run callbacks flat_filemap irj_contents target application = + Config.mpp_function := target; + Config.application_names := [ application ]; + Config.plain_output := true; + let filemap = + List.fold_left + (fun map (name, contents) -> StrMap.add name contents map) + StrMap.empty flat_filemap + in + Config.platform := Server filemap; + let dgfip_m = Mlang.Parsing.parse_m_dgfip (fun _ -> ()) [] in + let%lwt m_program = parse_files callbacks flat_filemap in + let m_program = + dgfip_m @ m_program + |> Mlang.Parsing.patch_rule_1 !Config.backend !Config.dgfip_flags + in + let m_program = Mlang.Expander.proceed m_program in + print_endline "proceeding"; + let m_program = Mlang.Validator.proceed !Config.mpp_function m_program in + print_endline "translating"; + let m_program = Mlang.Mast_to_mir.translate m_program in + print_endline "expanding functions"; + let m_program = Mir.expand_functions m_program in + print_endline "before runnning"; + let dbg_infos = + Mlang.Test_interpreter.check_test m_program (Contents irj_contents) + !Config.value_sort !Config.round_ops + in + let buf = Buffer.create 10000 in + let fmt = Format.formatter_of_buffer buf in + let delim = ref "" in + Buffer.add_char buf '['; + dbg_infos + |> List.iter (fun Test_interpreter.{ target; dbg_info } -> + Buffer.add_string buf !delim; + delim := ","; + Format.fprintf fmt {|{"target": "%s", "dbg_info": |} target; + Dbg_info.to_json fmt dbg_info; + Buffer.add_string buf "}"); + Buffer.add_char buf ']'; + Lwt.return @@ (Buffer.to_bytes buf |> Bytes.to_string) diff --git a/tests/mlang/calcul.irj b/tests/mlang/calcul.irj new file mode 100644 index 000000000..780085aca --- /dev/null +++ b/tests/mlang/calcul.irj @@ -0,0 +1,14 @@ +#NOM +TOTO +#ENTREES-PRIMITIF +V_ANCSDED/2022 +X/0 +ENTREE/24000 +#CONTROLES-PRIMITIF +#RESULTATS-PRIMITIF +X/3 +#ENTREES-RAPPELS +#CONTROLES-RAPPELS +#RESULTATS-RAPPELS +## + diff --git a/tests/mlang/calcul.m b/tests/mlang/calcul.m new file mode 100644 index 000000000..4d1ccffea --- /dev/null +++ b/tests/mlang/calcul.m @@ -0,0 +1,21 @@ +application app; + +V_ANCSDED : saisie revenu acompte = 0 avfisc = 0 categorie_TL = 0 classe = 0 cotsoc = 0 ind_abat = 0 modcat = 0 nat_code = 0 primrest = 0 priorite = 0 rapcat = 0 sanction = 0 alias V_POUET: "v_ancsed"; +X: calculee restituee primrest = 0: "x"; +Y: calculee primrest = 0: "y"; +TXMARJ: calculee primrest = 0: "TXMARJ"; +ANNEE: calculee primrest = 0: "annee en cours"; +TAUX: const=20; +REVENU : calculee restituee primrest = 0: "revenu en fin"; +ENTREE: saisie revenu acompte = 0 avfisc = 0 categorie_TL = 0 classe = 0 cotsoc = 0 ind_abat = 0 modcat = 0 nat_code = 0 primrest = 0 priorite = 0 rapcat = 0 sanction = 0 alias IDEF: "entree suite IRDV"; + +regle 1337: +application: app; + +X = 3; +Y = 3 + X * TAUX; +TXMARJ = Y - TAUX; +REVENU = ENTREE * TAUX / 100 + TXMARJ; +cible target: +application: app; +calculer domaine primitive; diff --git a/tests/mlang/demo.m b/tests/mlang/demo.m new file mode 100644 index 000000000..4d1ccffea --- /dev/null +++ b/tests/mlang/demo.m @@ -0,0 +1,21 @@ +application app; + +V_ANCSDED : saisie revenu acompte = 0 avfisc = 0 categorie_TL = 0 classe = 0 cotsoc = 0 ind_abat = 0 modcat = 0 nat_code = 0 primrest = 0 priorite = 0 rapcat = 0 sanction = 0 alias V_POUET: "v_ancsed"; +X: calculee restituee primrest = 0: "x"; +Y: calculee primrest = 0: "y"; +TXMARJ: calculee primrest = 0: "TXMARJ"; +ANNEE: calculee primrest = 0: "annee en cours"; +TAUX: const=20; +REVENU : calculee restituee primrest = 0: "revenu en fin"; +ENTREE: saisie revenu acompte = 0 avfisc = 0 categorie_TL = 0 classe = 0 cotsoc = 0 ind_abat = 0 modcat = 0 nat_code = 0 primrest = 0 priorite = 0 rapcat = 0 sanction = 0 alias IDEF: "entree suite IRDV"; + +regle 1337: +application: app; + +X = 3; +Y = 3 + X * TAUX; +TXMARJ = Y - TAUX; +REVENU = ENTREE * TAUX / 100 + TXMARJ; +cible target: +application: app; +calculer domaine primitive; diff --git a/tests/mlang/erreur.irj b/tests/mlang/erreur.irj new file mode 100644 index 000000000..3570934cc --- /dev/null +++ b/tests/mlang/erreur.irj @@ -0,0 +1,16 @@ +#NOM +TOTO +#ENTREES-PRIMITIF +V_ANCSDED/2022 +X/0 + +#CONTROLES-PRIMITIF +A100 +#RESULTATS-PRIMITIF +X/3 +#ENTREES-RAPPELS +#CONTROLES-RAPPELS +A100 +#RESULTATS-RAPPELS +## + diff --git a/tests/mlang/erreur.m b/tests/mlang/erreur.m new file mode 100644 index 000000000..3e05ed2f3 --- /dev/null +++ b/tests/mlang/erreur.m @@ -0,0 +1,21 @@ +A100:anomalie :"famille":"code_bo":"sous_code":"libelle":"is_isf"; +application app; + +V_ANCSDED : saisie revenu acompte = 0 avfisc = 0 categorie_TL = 0 classe = 0 cotsoc = 0 ind_abat = 0 modcat = 0 nat_code = 0 primrest = 0 priorite = 0 rapcat = 0 sanction = 0 alias V_ANCSDED : "v_ancsed"; +X: calculee restituee primrest = 0: "x"; + +regle 1: +application: app; +X = 3; + +verif 1: +application: app; + +si X > 1 alors erreur A100; + +cible target: +application: app; +calculer domaine primitive; +afficher_erreur "whatever\n"; +leve_erreur A100; +finalise_erreurs; diff --git a/tests/mlang/graph_deps.irj b/tests/mlang/graph_deps.irj new file mode 100644 index 000000000..82a7d0c28 --- /dev/null +++ b/tests/mlang/graph_deps.irj @@ -0,0 +1,14 @@ +#NOM +TOTO +#ENTREES-PRIMITIF +V_ANCSDED/2022 +X/0 +INPUT_DEFINED/42 +#CONTROLES-PRIMITIF +#RESULTATS-PRIMITIF +X/3 +#ENTREES-RAPPELS +#CONTROLES-RAPPELS +#RESULTATS-RAPPELS +## + diff --git a/tests/mlang/graph_deps.m b/tests/mlang/graph_deps.m new file mode 100644 index 000000000..9f2b80f14 --- /dev/null +++ b/tests/mlang/graph_deps.m @@ -0,0 +1,36 @@ +application app; + +V_ANCSDED : saisie revenu acompte = 0 avfisc = 0 categorie_TL = 0 classe = 0 cotsoc = 0 ind_abat = 0 modcat = 0 nat_code = 0 primrest = 0 priorite = 0 rapcat = 0 sanction = 0 alias V_POUET: "v_ancsed"; +X: calculee restituee primrest = 0: "x"; +Y: calculee primrest = 0: "y"; +MULTILINE: calculee primrest = 0 : "multiline"; +TXMARJ: calculee primrest = 0: "tx_marj"; +ANNEE: calculee primrest = 0: "annee"; +Z: calculee primrest = 0: "z"; +VARTMP: calculee primrest = 0: "vartmp"; +A: calculee primrest = 0: "a"; +CONST: const=6; +FLOAT: calculee primrest = 0: "float"; +BLABLA: saisie revenu acompte = 0 avfisc = 0 categorie_TL = 0 classe = 0 cotsoc = 0 ind_abat = 0 modcat = 0 nat_code = 0 primrest = 0 priorite = 0 rapcat = 0 sanction = 0 alias V_BLA: "blabla"; +INPUT_UNDEFINED: saisie revenu acompte = 0 avfisc = 0 categorie_TL = 0 classe = 0 cotsoc = 0 ind_abat = 0 modcat = 0 nat_code = 0 primrest = 0 priorite = 0 rapcat = 0 sanction = 0 alias IUND: "blabla"; +INPUT_DEFINED: saisie revenu acompte = 0 avfisc = 0 categorie_TL = 0 classe = 0 cotsoc = 0 ind_abat = 0 modcat = 0 nat_code = 0 primrest = 0 priorite = 0 rapcat = 0 sanction = 0 alias IDEF: "blabla"; +TAB: tableau[10] calculee primrest = 0 base : "tableau"; + +regle 1337: +application: app; + +VARTMP = 0; +TAB[0] = TAB[0] + VARTMP; +Z = INPUT_UNDEFINED; +FLOAT = 0.1230; +X = 0 + 1 + 2 + FLOAT - FLOAT + VARTMP; +Y = 3 + X * CONST; +TXMARJ = Y - CONST; +ANNEE = TXMARJ + INPUT_UNDEFINED + INPUT_DEFINED; +MULTILINE = X ++ Y; +VARTMP = 1; +A = VARTMP; +cible target: +application: app; +calculer domaine primitive; diff --git a/tests/mlang/m_ext.irj b/tests/mlang/m_ext.irj new file mode 100644 index 000000000..46ad09223 --- /dev/null +++ b/tests/mlang/m_ext.irj @@ -0,0 +1,10 @@ +#NOM +TOTO +#ENTREES-PRIMITIF +#CONTROLES-PRIMITIF +#RESULTATS-PRIMITIF +#ENTREES-RAPPELS +#CONTROLES-RAPPELS +#RESULTATS-RAPPELS +## + diff --git a/tests/mlang/m_ext.m b/tests/mlang/m_ext.m new file mode 100644 index 000000000..c2088a455 --- /dev/null +++ b/tests/mlang/m_ext.m @@ -0,0 +1,42 @@ +application test; + +V_ANCSDED : saisie revenu acompte = 0 avfisc = 0 categorie_TL = 0 classe = 0 cotsoc = 0 ind_abat = 0 modcat = 0 nat_code = 0 primrest = 0 priorite = 0 rapcat = 0 sanction = 0 alias V_POUET: "v_ancsed"; + + +fonction toto_fonction: +application: test; +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: test; +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: test; +variables_temporaires: A0, A1, A2, A3, AA tableau[3], A4, A5, A6, R; +afficher_erreur "entree test_args\n" indenter(2); +iterer : variable I : entre 0..6 increment 1 : dans ( + A0 = 0; + A1 = 1; + A2 = 2; + A3 = 3; + A4 = 4; + A5 = 5; + A6 = 6; +) +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 "\n"; +afficher_erreur indenter(-2) "sortie test_args\n"; diff --git a/tests/mlang/tab.irj b/tests/mlang/tab.irj new file mode 100644 index 000000000..3fb9ea955 --- /dev/null +++ b/tests/mlang/tab.irj @@ -0,0 +1,12 @@ +#NOM +TOTO +#ENTREES-PRIMITIF +V_ANCSDED/2022 +Y/12 +#CONTROLES-PRIMITIF +#RESULTATS-PRIMITIF +#ENTREES-RAPPELS +#CONTROLES-RAPPELS +#RESULTATS-RAPPELS +## + diff --git a/tests/mlang/tab.m b/tests/mlang/tab.m new file mode 100644 index 000000000..8029cc3a4 --- /dev/null +++ b/tests/mlang/tab.m @@ -0,0 +1,20 @@ +application app; + +V_ANCSDED : saisie revenu acompte = 0 avfisc = 0 categorie_TL = 0 classe = 0 cotsoc = 0 ind_abat = 0 modcat = 0 nat_code = 0 primrest = 0 priorite = 0 rapcat = 0 sanction = 0 alias V_POUET: "v_ancsed"; +X : calculee restituee primrest = 0 base : "x"; +Y : calculee restituee primrest = 0 base : "y"; +Z : calculee restituee primrest = 0 base : "z"; +TAB: tableau[10] calculee primrest = 0 base : "tableau"; + +regle 1337: +application: app; +TAB[1] = 3; +TAB[0] = Y; +TAB[2] = TAB[1]; +Z = TAB[3]; +X = TAB[0]; +Z = 123; + +cible target: +application: app; +calculer domaine primitive;