diff --git a/.github/workflows/check_correctness.yml b/.github/workflows/check_correctness.yml index 6be71bfbb..bf9191c14 100644 --- a/.github/workflows/check_correctness.yml +++ b/.github/workflows/check_correctness.yml @@ -73,6 +73,12 @@ jobs: eval $(opam env) make test_java_backend + - name: Test Ocaml backend + run: | + eval $(opam env) + make test_ocaml_backend + + diff --git a/.gitignore b/.gitignore index 19d1ee050..e4a273409 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,5 @@ doc.html *~ /_opam /Makefile.config +/.vscode +examples/ocaml/**/.merlin \ No newline at end of file diff --git a/Makefile b/Makefile index 7c23baa01..12e22d7e6 100644 --- a/Makefile +++ b/Makefile @@ -83,10 +83,13 @@ endif test_dgfip_c_backend: build $(MAKE) -C examples/dgfip_c/ml_primitif backend_tests +test_ocaml_backend: build + $(MAKE) -C examples/ocaml/ run_tests + quick_test: build $(MLANG) --backend interpreter --function_spec $(M_SPEC_FILE) $(SOURCE_FILES) -all: tests test_java_backend test_dgfip_c_backend quick_test +all: tests test_java_backend test_dgfip_c_backend test_ocaml_backend quick_test ################################################## # Doc @@ -99,6 +102,7 @@ doc: FORCE build clean: $(MAKE) -C examples/dgfip_c/ml_primitif cleanall $(MAKE) -C examples/java clean + $(MAKE) -C examples/ocaml clean rm -f doc/doc.html dune clean diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile new file mode 100644 index 000000000..d85690da4 --- /dev/null +++ b/examples/ocaml/Makefile @@ -0,0 +1,89 @@ +include Makefile-generic-ocaml-rules.include +include ../../Makefile.include + +######## +# USAGE: specifiying parameters of the generated "calculette" +######## +# Specifying a mpp file and its main function: +# make ir.ml MPP_FILE=../../mpp_specs/dgfip_base.mpp MPP_FUNCTION=verif_calcul_primitive_raw +# Using the default m_spec file: +# make ir.ml TAKE_MSPEC=true + +MLANG_BIN=dune exec --no-print-director ../../src/main.exe -- +MPP_FUNCTION=compute_double_liquidation_pvro +M_SPEC_FILE=$(SELF_DIR)/m_specs/tests_$(YEAR).m_spec + +MLANG_DEFAULT_OPTS=\ + --display_time --debug \ + --mpp_file=$(MPP_FILE) \ + --mpp_function=$(MPP_FUNCTION) + +MLANG_MSPEC=\ + --function_spec=$(M_SPEC_FILE) + +ifdef TAKE_MSPEC +MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG) $(MLANG_MSPEC) +SPEC_DEP=$(MPP_FILE) $(M_SPEC_FILE) +else +MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG) +SPEC_DEP=$(MPP_FILE) +endif + +# Include parser lib directory to make its module available +OCAMLC_INCLUDE_LIST= -I parser + +.PHONY : clean cleangen cleancalc cleanstat cleantest cleanresult run_tests + +clean: cleancalc cleanstat cleanresult cleanparser + +cleangen: + rm -f ir.ml +cleancalc: cleangen + rm -f ir.cmi ir.cmx ir.o ir.cmo ir.exe ir.bc +cleantest: + rm -f test_harness.cmi test_harness.cmx test_harness.o test_harness.cmo test.exe test.bc +cleanstat: cleantest + rm -f mvalue.cmi mvalue.cmx mvalue.o mvalue.cmo +cleanresult: + rm -f results/* +cleanparser: + $(MAKE) -C parser/ clean + +################################################## +# Generating and running OCaml files from Mlang +################################################## + +# Generating OCaml files (MLang) +ir.ml: $(SPEC_DEP) + $(MLANG) \ + --backend ocaml --output ir.ml \ + $(SOURCE_FILES) + +.INTERMEDIATE : test_harness.cmo test_harness.cmi test_harness.o test_harness.cmx +# Compiling bytecode +types_module.cmo test_lexer.cmo test_parser.cmo fip.cmo: + $(MAKE) -C parser/ fip.cmo + +test.bc: types_module.cmo test_lexer.cmo test_parser.cmo fip.cmo mvalue.cmo ir.cmo test_harness.cmo + ocamlc.opt $(DEBUG_FLAG) -o $@ $(OCAMLC_INCLUDE_LIST) unix.cma $^ + +# Compiling native code +types_module.cmx test_lexer.cmx test_parser.cmx fip.cmx: + $(MAKE) -C parser/ fip.cmx + +test.exe: types_module.cmx test_lexer.cmx test_parser.cmx fip.cmx mvalue.cmx ir.cmx test_harness.cmx + ocamlopt $(DEBUG_FLAG) -o $@ $(OCAMLC_INCLUDE_LIST) unix.cmxa $^ + +# Running test suite +run: test.bc + ./test.bc "multi" $(TESTS_DIR) "results/y_$(YEAR)" + +runfile: test.bc + ./test.bc "raw" $(FILE) "results/f_$(notdir $(FILE))" + +runx: test.exe + ./test.exe "multi" $(TESTS_DIR) "results/y_$(YEAR)" + +# run_tests uses an empty string to disable the file output (output is enabled on stdout). +run_tests: test.exe + ./test.exe "multi" $(TESTS_DIR) "" diff --git a/examples/ocaml/Makefile-generic-ocaml-rules.include b/examples/ocaml/Makefile-generic-ocaml-rules.include new file mode 100644 index 000000000..d28719d7f --- /dev/null +++ b/examples/ocaml/Makefile-generic-ocaml-rules.include @@ -0,0 +1,12 @@ +################################################## +# Implicit rules for OCaml modules +################################################## + +%.cmi: %.mli + ocamlc.opt -c $(DEBUG_FLAG) $^ + +%.cmo: %.ml + ocamlc.opt -c $(DEBUG_FLAG) $(OCAMLC_INCLUDE_LIST) $^ + +%.cmx: %.ml + ocamlopt -c $(DEBUG_FLAG) $(OCAMLC_INCLUDE_LIST) $^ \ No newline at end of file diff --git a/examples/ocaml/dune b/examples/ocaml/dune new file mode 100644 index 000000000..32814e5f2 --- /dev/null +++ b/examples/ocaml/dune @@ -0,0 +1,3 @@ +;(executable +; (name test_harness) +; (libraries mlang)) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml new file mode 100644 index 000000000..29af005b3 --- /dev/null +++ b/examples/ocaml/mvalue.ml @@ -0,0 +1,159 @@ +type m_value = { undefined : bool; value : float } + +type m_array = m_value array + +type m_error = { + name : string; + kind : string; + major_code : string; + minor_code : string; + description : string; + alias : string; +} + +exception M_exn of m_error list + +type m_context = { + tgv : m_array; + local_variables : m_array; + mutable errors : m_error list; +} + +type revenue_code = { alias : string; value : float } + +module TgvPositionMap = Map.Make (String) + +type input_list = revenue_code list + +type output_array = revenue_code array + +let m_undef : m_value = { undefined = true; value = 0.0 } + +let m_zero : m_value = { undefined = false; value = 0.0 } + +let m_one : m_value = { undefined = false; value = 1.0 } + +let m_add (x : m_value) (y : m_value) : m_value = + if x.undefined && y.undefined then m_undef + else { undefined = false; value = x.value +. y.value } + +let m_multiply (x : m_value) (y : m_value) : m_value = + if x.undefined || y.undefined then m_undef + else { undefined = false; value = x.value *. y.value } + +let m_subtract (x : m_value) (y : m_value) : m_value = + if x.undefined && y.undefined then m_undef + else { undefined = false; value = x.value -. y.value } + +let m_divide (x : m_value) (y : m_value) : m_value = + if x.undefined || y.undefined then m_undef + else + { + undefined = false; + value = (if y.value = 0.0 then 0.0 else x.value /. y.value); + } + +let m_and (x : m_value) (y : m_value) : m_value = + if x.undefined || y.undefined then m_undef + else if x.value <> 0.0 && y.value <> 0.0 then m_one + else m_zero + +let m_or (x : m_value) (y : m_value) : m_value = + if x.undefined && y.undefined then m_undef + else if x.value <> 0.0 || y.value <> 0.0 then m_one + else m_zero + +let m_cond (condition : m_value) (true_value : m_value) (false_value : m_value) + : m_value = + match condition with + | { undefined = true; value = _ } -> m_undef + | { undefined = false; value = 0.0 } -> false_value + | { undefined = false; value = _ } -> true_value + +let m_greater_than (x : m_value) (y : m_value) : m_value = + if x.undefined || y.undefined then m_undef + else if x.value > y.value then m_one + else m_zero + +let m_greater_than_equal (x : m_value) (y : m_value) : m_value = + if x.undefined || y.undefined then m_undef + else if x.value >= y.value then m_one + else m_zero + +let m_less_than (x : m_value) (y : m_value) : m_value = + if x.undefined || y.undefined then m_undef + else if x.value < y.value then m_one + else m_zero + +let m_less_than_equal (x : m_value) (y : m_value) : m_value = + if x.undefined || y.undefined then m_undef + else if x.value <= y.value then m_one + else m_zero + +let m_equal (x : m_value) (y : m_value) : m_value = + if x.undefined || y.undefined then m_undef + else if x.value = y.value then m_one + else m_zero + +let m_not_equal (x : m_value) (y : m_value) : m_value = + if x.undefined || y.undefined then m_undef + else if x.value <> y.value then m_one + else m_zero + +let m_not (x : m_value) : m_value = + if x.undefined then m_undef else if x.value = 0.0 then m_one else m_zero + +let m_neg (x : m_value) : m_value = + if x.undefined then m_undef + else { undefined = false; value = Float.neg x.value } + +let m_table_value_at_index (variable_array : m_array) (table_start : int) + (index : m_value) (size : int) = + if index.undefined then m_undef + else + let offset = int_of_float index.value in + match offset with + | x when x < 0 -> m_zero + | x when x >= size -> m_undef + | _ -> Array.get variable_array (offset + table_start) + +let m_max (x : m_value) (y : m_value) : m_value = + if x.undefined && y.undefined then m_undef + else { undefined = false; value = max x.value y.value } + +let m_min (x : m_value) (y : m_value) : m_value = + if x.undefined && y.undefined then m_undef + else { undefined = false; value = min x.value y.value } + +let m_round (x : m_value) : m_value = + if x.undefined then m_undef + else + { + undefined = false; + value = + (if x.value < 0.0 then ceil (x.value -. 0.50005) + else floor (x.value +. 0.50005)); + } + +let m_null = m_not + +let m_floor (x : m_value) : m_value = + if x.undefined then m_undef + else { undefined = false; value = floor (x.value +. 0.000001) } + +let m_abs (x : m_value) : m_value = + if x.undefined then m_undef + else { undefined = false; value = abs_float x.value } + +let m_present (x : m_value) : m_value = if x.undefined then m_zero else m_one + +let m_multimax (bound_variable : m_value) (variable_array : m_array) + (position : int) : m_value = + if bound_variable.undefined then failwith "Multimax bound undefined!" + else + let bound = int_of_float bound_variable.value in + let sub_array = Array.sub variable_array (position+1) (bound) in + let get_position_value position = + Array.get variable_array position + in + Array.fold_left (m_max) (get_position_value position) sub_array \ No newline at end of file diff --git a/examples/ocaml/parser/Makefile b/examples/ocaml/parser/Makefile new file mode 100644 index 000000000..86e898616 --- /dev/null +++ b/examples/ocaml/parser/Makefile @@ -0,0 +1,19 @@ +include ../Makefile-generic-ocaml-rules.include + +clean: + rm -f *.cmo *.cmi *.cmx *.o test_lexer.ml test_parser.ml test_parser.mli + +# Compiling test file parser + +test_parser.mli test_parser.ml: types_module.cmo types_module.cmx + menhir --infer-write-query mock.ml test_parser.mly + ocamlc.opt -i mock.ml > reply + menhir --infer-read-reply reply test_parser.mly + rm mock.ml reply + +test_lexer.ml: test_parser.cmi test_parser.cmo test_parser.cmx + ocamllex test_lexer.mll + +fip.cmo: test_lexer.cmo + +fip.cmx: test_lexer.cmx \ No newline at end of file diff --git a/examples/ocaml/parser/fip.ml b/examples/ocaml/parser/fip.ml new file mode 100644 index 000000000..c2706d11e --- /dev/null +++ b/examples/ocaml/parser/fip.ml @@ -0,0 +1,38 @@ +(*From test_interpreter.ml*) + +open Types_module + +let parse_file (test_name : string) : Types_module.irj_file = + let input = open_in test_name in + let filebuf = Lexing.from_channel input in + let filebuf = + { + filebuf with + lex_curr_p = { filebuf.lex_curr_p with pos_fname = test_name }; + } + in + let f = + try Test_parser.irj_file Test_lexer.token filebuf with + | Types_module.StructuredError e -> + close_in input; + raise (Types_module.StructuredError e) + | Test_parser.Error -> + close_in input; + Types_module.raise_spanned_error "Test syntax error" + (Types_module.mk_position (filebuf.lex_start_p, filebuf.lex_curr_p)) + in + close_in input; + f +(* +let () = +let donnees = parse_file "alavoine-2.irj" in +let (entrees, _, _) = donnees.prim in +print_string donnees.nom;print_newline(); +let (code, valeur, _) = List.hd entrees in +print_string "première entrée : "; print_string code; print_string " avec la valeur "; +match valeur with +| I entier -> print_int entier; print_string " entière.";print_newline();flush stdout +| F flottant -> print_float flottant; print_string " flottante."; +print_newline(); +flush stdout +*) diff --git a/examples/ocaml/parser/test_lexer.mll b/examples/ocaml/parser/test_lexer.mll new file mode 100644 index 000000000..a15507eef --- /dev/null +++ b/examples/ocaml/parser/test_lexer.mll @@ -0,0 +1,75 @@ +(* +Copyright Inria, contributors: + Raphaël Monat (2019) + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see . +*) + +{ +open Lexing +open Test_parser +open Types_module +} + +rule token = parse +| [' ' '\t'] (* also ignore newlines, not only whitespace and tabs *) + { token lexbuf } +| '*' [^ '\n']* '\n' (* ignore comments *) + { new_line lexbuf; token lexbuf } +| '\n' | "\r\n" + { new_line lexbuf; token lexbuf} +| "/" + { SLASH } +| "#NOM" + { NOM } +| "#FIP" + { FIP } +| "#ENTREES-PRIMITIF" + { ENTREESPRIM } +| "#CONTROLES-PRIMITIF" + { CONTROLESPRIM } +| "#RESULTATS-PRIMITIF" + { RESULTATSPRIM } +| "#ENTREES-CORRECTIF" + { ENTREESCORR } +| "#CONTROLES-CORRECTIF" + { CONTROLESCORR } +| "#RESULTATS-CORRECTIF" + { RESULTATSCORR } +| "#ENTREES-RAPPELS" + { ENTREESRAPP } +| "#CONTROLES-RAPPELS" + { CONTROLESRAPP } +| "#RESULTATS-RAPPELS" + { RESULTATSRAPP } +(*| "#DATES" + { DATES } +| "#AVIS_IR" + { AVISIR } +| "#AVIS_CSG" + { AVISCSG }*) +| "##" + { ENDSHARP } +| '-'? ['0' - '9']+ as i + { INTEGER i } +| '-'? ['0' - '9']+ '.' ['0' - '9']* as f + { FLOAT f } +| ['a'-'z' 'A'-'Z' '0'-'9' '_']+ as s + { SYMBOL s } +| ['a'-'z' 'A'-'Z' ' ' '0'-'9' ';' '-']+ as s + { NAME s } +| eof + { EOF } +| _ + { raise_spanned_error "Test file lexer error" (mk_position (Lexing.lexeme_start_p lexbuf, Lexing.lexeme_end_p lexbuf)) } diff --git a/examples/ocaml/parser/test_parser.mly b/examples/ocaml/parser/test_parser.mly new file mode 100644 index 000000000..f451ea075 --- /dev/null +++ b/examples/ocaml/parser/test_parser.mly @@ -0,0 +1,99 @@ +(* +Copyright Inria, contributors: + Raphaël Monat (2019) + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see . +*) + +%{ open Types_module +%} + +%token SYMBOL NAME INTEGER FLOAT +/* Possibly use stronger constraints than just string on rappel's fields +some are characters, some are 0/1, etc. */ + +%token SLASH +%token NOM FIP +%token ENTREESPRIM CONTROLESPRIM RESULTATSPRIM +%token ENTREESCORR CONTROLESCORR RESULTATSCORR +%token ENTREESRAPP CONTROLESRAPP RESULTATSRAPP +/* %token DATES AVISIR AVISCSG*/ +%token ENDSHARP + +%token EOF + +%type irj_file + +%start irj_file + +%% + +irj_file: +| NOM nom = name + fip? + prim = primitif + rapp = rappels + ENDSHARP { { nom; prim; rapp } } +| EOF { assert false } + +primitif: + ENTREESPRIM + entrees_primitif = list(variable_and_value) + CONTROLESPRIM + erreurs_attendues_primitif = list(error_code) + RESULTATSPRIM + resultats_attendus_primitif = list(variable_and_value) + { (entrees_primitif, erreurs_attendues_primitif, resultats_attendus_primitif) } + +rappels: +| ENTREESRAPP + entrees_rappels = list(rappel) + CONTROLESRAPP + erreurs_attendues_rappels = list(error_code) + RESULTATSRAPP + resultats_attendus_rappels = list(variable_and_value) + { Some (entrees_rappels, erreurs_attendues_rappels, resultats_attendus_rappels) } +| ENTREESCORR CONTROLESCORR RESULTATSCORR { None } + +name: +| n = NAME { n } +| n = SYMBOL { n } + +fip: + FIP SLASH option(SYMBOL) { } + +variable_and_value: +| var = SYMBOL SLASH value = INTEGER { (var, I (int_of_string value), mk_position $sloc) } +| var = SYMBOL SLASH value = FLOAT { (var, F (float_of_string value), mk_position $sloc) } + +error_code: + error = SYMBOL { (error, mk_position $sloc) } + +rappel: + event_nb = INTEGER SLASH + rappel_nb = INTEGER SLASH + variable_change = variable_and_value SLASH + direction = SYMBOL SLASH + penalty_code = INTEGER SLASH + base_tolerance_legale = INTEGER SLASH + month_year = INTEGER SLASH + decl_2042_rect = INTEGER + { (event_nb, + rappel_nb, + variable_change, + direction, + penalty_code, + base_tolerance_legale, + month_year, + decl_2042_rect) } diff --git a/examples/ocaml/parser/types_module.ml b/examples/ocaml/parser/types_module.ml new file mode 100644 index 000000000..7201cd666 --- /dev/null +++ b/examples/ocaml/parser/types_module.ml @@ -0,0 +1,37 @@ +(*From utils/pos.ml*) + +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 *) + +let make_position (f : string) (loc : Lexing.position * Lexing.position) = + { pos_filename = f; pos_loc = loc } + + +(*From test_ast.ml*) + +type literal = I of int | F of float + +type var_values = (string * literal * t) list + +type errors = (string * t) list + +type rappels = (string * string * (string * literal * t) * string * string * string * string * string) list + +type irj_file = { + nom : string; + prim : (var_values * errors * var_values); + rapp : (rappels * errors * var_values) option; +} + +(*For both lexer and parser, from m_frontend/parse_utils*) +let mk_position sloc = make_position (fst sloc).Lexing.pos_fname sloc +(*For lexer, from utils/errors.ml*) + +exception + StructuredError of + (string * (string option * t) list * (unit -> unit) option) + +let raise_spanned_error (msg : string) ?(span_msg : string option) + (span : t) : 'a = + raise (StructuredError (msg, [ (span_msg, span) ], None)) \ No newline at end of file diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml new file mode 100644 index 000000000..58ca46298 --- /dev/null +++ b/examples/ocaml/test_harness.ml @@ -0,0 +1,215 @@ +open Mvalue + +type test_block = { block_name : string; block_data : Mvalue.revenue_code list } + +type test_data = { test_name : string; blocks : test_block list } + +let fichier (input_file : string) : Types_module.irj_file = Fip.parse_file input_file + +let revenue_code_list_from_var_values (values : Types_module.var_values) : Mvalue.revenue_code list = + List.map (fun (var, value, pos) -> match value with + | Types_module.F value -> Mvalue.{alias=var; value=value } + | Types_module.I _ -> assert false) values + +(*let entry_list_parsed (fichier : Types_module.irj_file) : Mvalue.revenue_code list = revenue_code_list_from_var_values fichier.ep + +let reference_list_parsed (fichier : Types_module.irj_file) : Mvalue.revenue_code list = revenue_code_list_from_var_values fichier.rp +*) + +let get_file_in_dir (dir_handle : Unix.dir_handle) : string list = + let rec build_list file_list = + match Unix.readdir dir_handle with + | next_file when next_file = "." || next_file = ".." -> build_list file_list + | next_file -> build_list (next_file :: file_list) + | exception End_of_file -> + Unix.closedir dir_handle; + file_list + | exception e -> + Unix.closedir dir_handle; + raise e + in + build_list [] + +let compare_rev_code code1 code2 : int = compare code1.alias code2.alias + +let filter_rev_code_list initial_list ref_list : Mvalue.revenue_code list = + let alias_eq code1 code2 = code1.alias = code2.alias in + let ref_exists code : bool = + List.exists (fun ref_code -> alias_eq code ref_code) ref_list + in + List.filter ref_exists initial_list + +let list_discrepancies filtered_list ref_list : + (Mvalue.revenue_code * Mvalue.revenue_code) list = + let value_neq (code1, code2) = not (code1.value = code2.value) in + List.filter value_neq + (List.combine + (List.sort compare_rev_code filtered_list) + (List.sort compare_rev_code ref_list)) + +let print_rev_code (oc : Format.formatter) (rev_code : Mvalue.revenue_code) : + unit = + Format.fprintf oc "%s/%f" rev_code.alias rev_code.value + +let compute_discrepancies_from_file_2020 (fip_file : string) : + (Mvalue.revenue_code * Mvalue.revenue_code) list = + let (entry_list, _, result_list) = (fichier fip_file).prim in + let tax_result_array, errors = Ir.calculate_tax (revenue_code_list_from_var_values entry_list) in + let tax_result = Array.to_list tax_result_array in + let ref_list = revenue_code_list_from_var_values result_list in + let filtered_ref_list = filter_rev_code_list ref_list tax_result in + let was_erased ref_list code : bool = not (List.mem code ref_list) in + let erased_codes : revenue_code list = + List.filter (was_erased filtered_ref_list) ref_list + in + let print_list fmt code_list = + Format.pp_print_list print_rev_code fmt code_list + in + let warning_string fmt () = + if List.length erased_codes <> 0 then + Format.fprintf fmt + "@.Warning: following codes were expected results but are not part of \ + the output variable list@.%a" + print_list erased_codes + else Format.fprintf fmt "" + in + Format.printf "Test case: %s%a@." fip_file warning_string (); + list_discrepancies + (filter_rev_code_list tax_result filtered_ref_list) + filtered_ref_list + +let print_file_discrepancies (oc : Format.formatter) + (file_discrepancies_list : + string * (Mvalue.revenue_code * Mvalue.revenue_code) list) : unit = + let print_line fmt (discrepancy : Mvalue.revenue_code * Mvalue.revenue_code) = + let result, reference = discrepancy in + Format.fprintf fmt "%a instead of %a" print_rev_code result print_rev_code + reference + in + let print_results fmt + (result_list : (Mvalue.revenue_code * Mvalue.revenue_code) list) = + Format.pp_print_list print_line fmt result_list + in + let filename, discrepancy_list = file_discrepancies_list in + Format.fprintf oc "@[File: %s@,%a@]@." filename print_results + discrepancy_list + +let print_discrepancies (oc : Format.formatter) + (discrepancy_list : (Mvalue.revenue_code * Mvalue.revenue_code) list) + (fip_file : string) : unit = + let print_if_empty fmt (file, _) = + Format.fprintf fmt "No discrepancy for file %s" file + in + Format.fprintf oc + "@[OCaml computed value | Reference value from file@,%a@]@." + (if List.length discrepancy_list <> 0 then print_file_discrepancies + else print_if_empty) + (fip_file, discrepancy_list) + +let test_FIP_2020 (fip_file : string) (output_file_name : string) : unit = + Format.printf "Simple test on file %s.@." fip_file; + let _oc = open_out (output_file_name ^ "_disc.txt") in + let oc = Format.formatter_of_out_channel _oc in + let discrepancy_list = compute_discrepancies_from_file_2020 fip_file in + print_discrepancies oc discrepancy_list fip_file; + close_out _oc + +let print_error oc (error : m_error) : unit = + Format.fprintf oc + "@[Codename: %s@,\ + kind: %s@,\ + codes: major %s minor %s@,\ + description: %s@,\ + alias: %s@]" error.name error.kind error.major_code error.minor_code + error.description error.alias + +let print_errors oc error_list = Format.pp_print_list print_error oc error_list + +let () = + Printexc.register_printer (function + | M_exn e_list -> + Some (Format.asprintf "M_exn@;<0 4>M Exception: %a" print_errors e_list) + | _ -> None) + +let compute_on_FIP_2020 (fip_file : string) (output_file_name : string) : unit = + Format.printf "Simple test on file %s.@." fip_file; + let _oc = open_out (output_file_name ^ "_disc.txt") in + let oc = Format.formatter_of_out_channel _oc in + let (entry_list, _, result_list) = (fichier fip_file).prim in + let tax_result_array, errors = + try Ir.calculate_tax (revenue_code_list_from_var_values entry_list) + with M_exn e_list -> + Format.fprintf oc "TEST CASE %s ends with M Exception:@,@,%a@." fip_file + print_errors e_list; + close_out _oc; + raise (M_exn e_list) + in + let tax_result = Array.to_list tax_result_array in + let ref_list = revenue_code_list_from_var_values result_list in + let print_list fmt code_list = + Format.pp_print_list print_rev_code fmt code_list + in + Format.fprintf oc + "@[TEST CASE: %s@,\ + @,\ + ANOMALIES@,\ + @,\ + %a@,\ + @,\ + REFERENCE@,\ + @,\ + %a@,\ + @,\ + OUTPUT@,\ + @,\ + %a@,\ + @,\ + FILTERED OUTPUT@,\ + @,\ + %a@]@." + fip_file print_errors errors print_list + (List.sort compare_rev_code ref_list) + print_list + (List.sort compare_rev_code tax_result) + print_list + (List.sort compare_rev_code (filter_rev_code_list tax_result ref_list)); + close_out _oc + +let run_test_directory (directory : string) (output_file_name : string) : unit = + let dir_handle = Unix.opendir directory in + let file_list = + List.map (fun (file_name) -> directory ^ file_name) (get_file_in_dir dir_handle) + in + let files_discrepancies_list = + List.combine file_list + (List.map compute_discrepancies_from_file_2020 file_list) + in + let _oc = + if String.length output_file_name = 0 then stdout + else open_out (output_file_name ^ "_disc.txt") + in + let oc = Format.formatter_of_out_channel _oc in + let print_discrepancy_report fmt files_discrepancies_list = + Format.pp_print_list print_file_discrepancies fmt files_discrepancies_list + in + let result_to_print = + List.filter + (fun (filename, discrepancy_list) -> List.length discrepancy_list <> 0) + files_discrepancies_list + in + let print_if_empty fmt _placeholder = + Format.fprintf fmt "Nothing to see here…" + in + Format.fprintf oc "@[Discrepancy report@,%a@]@." + (if List.length result_to_print <> 0 then print_discrepancy_report + else print_if_empty) + result_to_print; + close_out _oc + +let () = + Format.printf "Starting %s.@." Sys.argv.(0); + match Sys.argv.(1) with + | "raw" -> compute_on_FIP_2020 Sys.argv.(2) Sys.argv.(3) + | "mono" -> test_FIP_2020 Sys.argv.(2) Sys.argv.(3) + | "multi" -> run_test_directory Sys.argv.(2) Sys.argv.(3) + | other -> Format.printf "Unknown command: %s@." other diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml new file mode 100644 index 000000000..73324ab7b --- /dev/null +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -0,0 +1,390 @@ +(* Backend OCaml *) + +let none_value = "m_undef" + +let get_var_pos (var : Bir.variable) : int = var.Bir.offset + +let get_var_alias (v : Bir.variable) : string option = (Bir.var_to_mir v).alias + +let generate_comp_op (op : Mast.comp_op) : string = + match op with + | Mast.Gt -> "m_greater_than" + | Mast.Gte -> "m_greater_than_equal" + | Mast.Lt -> "m_less_than" + | Mast.Lte -> "m_less_than_equal" + | Mast.Eq -> "m_equal" + | Mast.Neq -> "m_not_equal" + +let generate_binop (op : Mast.binop) : string = + match op with + | Mast.And -> "m_and" + | Mast.Or -> "m_or" + | Mast.Add -> "m_add" + | Mast.Sub -> "m_subtract" + | Mast.Mul -> "m_multiply" + | Mast.Div -> "m_divide" + +let generate_unop (op : Mast.unop) : string = + match op with Mast.Not -> "m_not" | Mast.Minus -> "m_neg" + +let rec generate_ocaml_expr (e : Bir.expression Pos.marked) : + string * (Mir.LocalVariable.t * Bir.expression Pos.marked) list = + match Pos.unmark e with + | Comparison (op, e1, e2) -> + let expr1, local1 = generate_ocaml_expr e1 in + let expr2, local2 = generate_ocaml_expr e2 in + ( Format.asprintf "(%s %s %s)" + (generate_comp_op (Pos.unmark op)) + expr1 expr2, + local1 @ local2 ) + | Binop (op, e1, e2) -> + let s1, local1 = generate_ocaml_expr e1 in + let s2, local2 = generate_ocaml_expr e2 in + ( Format.asprintf "(%s %s %s)" (generate_binop (Pos.unmark op)) s1 s2, + local1 @ local2 ) + | Unop (op, e) -> + let expr, local = generate_ocaml_expr e in + (Format.asprintf "(%s %s)" (generate_unop op) expr, local) + | Index (var, e) -> + let expr, local = generate_ocaml_expr e in + let unmarked_var = Pos.unmark var in + let size = + Option.get (Bir.var_to_mir unmarked_var).Mir.Variable.is_table + in + ( Format.asprintf "(m_table_value_at_index context.tgv %d %s %d)" + (get_var_pos unmarked_var) expr size, + local ) + | Conditional (e1, e2, e3) -> + let se1, s1 = generate_ocaml_expr e1 in + let se2, s2 = generate_ocaml_expr e2 in + let se3, s3 = generate_ocaml_expr e3 in + (Format.asprintf "(m_cond %s %s %s)" se1 se2 se3, s1 @ s2 @ s3) + | FunctionCall (PresentFunc, [ arg ]) -> + let s, local = generate_ocaml_expr arg in + (Format.asprintf "(m_present %s)" s, local) + | FunctionCall (NullFunc, [ arg ]) -> + let s, local = generate_ocaml_expr arg in + (Format.asprintf "(m_null %s)" s, local) + | FunctionCall (ArrFunc, [ arg ]) -> + let s, local = generate_ocaml_expr arg in + (Format.asprintf "(m_round %s)" s, local) + | FunctionCall (InfFunc, [ arg ]) -> + let s, local = generate_ocaml_expr arg in + (Format.asprintf "(m_floor %s)" s, local) + | FunctionCall (AbsFunc, [ arg ]) -> + let se, s = generate_ocaml_expr arg in + (Format.asprintf "(m_abs %s)" se, s) + | FunctionCall (MaxFunc, [ e1; e2 ]) -> + let s1, local1 = generate_ocaml_expr e1 in + let s2, local2 = generate_ocaml_expr e2 in + (Format.asprintf "(%s %s %s)" "m_max" s1 s2, local1 @ local2) + | FunctionCall (MinFunc, [ e1; e2 ]) -> + let s1, local1 = generate_ocaml_expr e1 in + let s2, local2 = generate_ocaml_expr e2 in + (Format.asprintf "(%s %s %s)" "m_min" s1 s2, local1 @ local2) + | FunctionCall (Multimax, [ e1; (Var v2, _) ]) -> + let s1, local1 = generate_ocaml_expr e1 in + ( Format.asprintf "(m_multimax %s context.tgv %d)" s1 (get_var_pos v2), + local1 ) + | FunctionCall _ -> assert false (* should not happen *) + | Literal (Float f) -> ( + match f with + | 0. -> (Format.asprintf "m_zero", []) + | 1. -> (Format.asprintf "m_one", []) + | _ -> + ( Format.asprintf "{undefined = false ; value = %s}" + (string_of_float f), + [] )) + | Literal Undefined -> (Format.asprintf "%s" none_value, []) + | Var var -> + ( Format.asprintf "(Array.get context.tgv %d (*%s*))" (get_var_pos var) + (Pos.unmark var.mir_var.name), + [] ) + | LocalVar lvar -> + ( Format.asprintf "(Array.get context.local_variables %d)" + lvar.Mir.LocalVariable.id, + [] ) + | Error -> assert false (* should not happen *) + | LocalLet (lvar, e1, e2) -> + let _, local1 = generate_ocaml_expr e1 in + let se2, local2 = generate_ocaml_expr e2 in + (Format.asprintf "%s" se2, local1 @ ((lvar, e1) :: local2)) + +let format_tgv_set (variable_expression : string) (oc : Format.formatter) + (variable_position : int) : unit = + Format.fprintf oc "Array.set context.tgv %d %s" variable_position + variable_expression + +let format_tgv_set_with_offset (variable_position : int) + (offset_tgv_variable : Bir.variable) (oc : Format.formatter) + (variable_expression : string) : unit = + Format.fprintf oc + "Array.set context.tgv (%d + (((*%s*) Array.get context.tgv %d).value |> \ + int_of_float)) %s" + variable_position + (Pos.unmark offset_tgv_variable.mir_var.name) + (get_var_pos offset_tgv_variable) + variable_expression + +let pp_statement_separator (f : Format.formatter) () : unit = + Format.fprintf f ";@," + +let format_local_set (oc : Format.formatter) (lvar, expr) : unit = + let se, _ = generate_ocaml_expr expr in + Format.fprintf oc "Array.set context.local_variables %d %s" + lvar.Mir.LocalVariable.id se + +let generate_local_defs (oc : Format.formatter) + (defs : (Mir.LocalVariable.t * Bir.expression Pos.marked) list) : unit = + match defs with + | [] -> () + | _ :: _ -> + Format.fprintf oc "%a;@," + (Format.pp_print_list ~pp_sep:pp_statement_separator format_local_set) + defs + +let generate_var_def (variable : Bir.variable) (def : Bir.variable_def) + (oc : Format.formatter) : unit = + let generate_one_var position oc (e : Bir.expression Pos.marked) : unit = + let tgv_expression, local_defs = generate_ocaml_expr e in + Format.fprintf oc "%a(*%s*) %a" generate_local_defs local_defs + (Pos.unmark variable.mir_var.name) + (format_tgv_set tgv_expression) + position + in + match def with + | SimpleVar e -> generate_one_var (get_var_pos variable) oc e + | TableVar (_, IndexTable es) -> + let bindings_list = Mir.IndexMap.bindings es in + Format.pp_print_list ~pp_sep:pp_statement_separator + (fun fmt (i, v) -> + generate_one_var (get_var_pos variable |> ( + ) i) fmt v) + oc bindings_list + | TableVar (_size, IndexGeneric (v, e)) -> + let tgv_expression, local_defs = generate_ocaml_expr e in + Format.fprintf oc + "if (Array.get context.tgv %d (*%s*)).undefined then %a(*Table %s*)@,%a" + (get_var_pos v) + (Pos.unmark v.mir_var.name) + generate_local_defs local_defs + (Pos.unmark variable.mir_var.name) + (format_tgv_set_with_offset (get_var_pos variable) v) + tgv_expression + | InputVar -> assert false + +let generate_verif (oc : Format.formatter) (condition_data : Bir.condition_data) + = + let open Strings in + Format.fprintf oc "let verif_cond = %s in@," + (let se, _ = generate_ocaml_expr condition_data.cond_expr in + se); + let cond_error, alias = condition_data.cond_error in + let error_name = sanitize_str cond_error.Mir.Error.name in + let error_kind, exception_raising = + match cond_error.Mir.Error.typ with + | Anomaly -> ("Anomaly", ";raise (M_exn context.errors)") + | Discordance -> ("Discordance", "") + | Information -> ("Information", "") + in + let error_kind_code = sanitize_str cond_error.Mir.Error.descr.kind in + let error_major_code = sanitize_str cond_error.Mir.Error.descr.major_code in + let error_minor_code = sanitize_str cond_error.Mir.Error.descr.minor_code in + let error_description = sanitize_str cond_error.Mir.Error.descr.description in + let error_alias = + match alias with + | Some v -> ( + match (Bir.var_to_mir v).Mir.Variable.alias with + | Some alias -> "(( " ^ alias ^ " ))" + | None -> "") + | None -> "" + in + Format.fprintf oc + "match verif_cond with@,\ + | { undefined = true ; value = _ }@,\ + | { undefined = false ; value = 0.0 } -> ()@,\ + | _ -> (@[ context.errors <- {@,\ + name = \"%s\";@,\ + kind = \"%s (%s)\";@,\ + major_code = \"%s\";@,\ + minor_code = \"%s\";@,\ + description = \"%s\";@,\ + alias = \"%s\"} :: context.errors@,\ + @])%s@," + error_name error_kind error_kind_code error_major_code error_minor_code + error_description error_alias exception_raising + +let generate_rov_header (oc : Format.formatter) (rov : Bir.rule_or_verif) : unit + = + let tname = match rov.rov_code with Rule _ -> "rule" | Verif _ -> "verif" in + Format.fprintf oc "m_%s_%s context" tname (Pos.unmark rov.rov_name) + +let rec generate_stmts (program : Bir.program) (oc : Format.formatter) + (stmts : Bir.stmt list) : unit = + Format.pp_print_list ~pp_sep:pp_statement_separator (generate_stmt program) oc + stmts + +and generate_stmt (program : Bir.program) (oc : Format.formatter) + (stmt : Bir.stmt) : unit = + match Pos.unmark stmt with + | SAssign (variable, variable_data) -> + generate_var_def variable variable_data oc + | SConditional (cond_expression, tt, ff) -> + let pos = Pos.get_position stmt in + let fname = + String.map + (fun c -> if c = '.' then '_' else c) + (Filename.basename (Pos.get_file pos)) + in + let cond_name = + Format.asprintf "cond_%s_%d_%d_%d_%d" fname (Pos.get_start_line pos) + (Pos.get_start_column pos) (Pos.get_end_line pos) + (Pos.get_end_column pos) + in + let s, _ = generate_ocaml_expr (Pos.same_pos_as cond_expression stmt) in + Format.fprintf oc + "@[let %s : m_value = %s in@,\ + (match %s with@,\ + | { undefined = true ; value = _ } -> ()@,\ + | { undefined = false ; value = 0.0 }-> (@[%a@])@,\ + | _ -> (@[%a@]))@]" cond_name s cond_name (generate_stmts program) + ff (generate_stmts program) tt + | SVerif condition_data -> generate_verif oc condition_data + | SRovCall r -> + let rov = Bir.ROVMap.find r program.rules_and_verifs in + generate_rov_header oc rov + | SFunctionCall (function_name, _) -> + Format.fprintf oc "mpp_func_%s context" function_name + +let pp_empty_separator (f : Format.formatter) () : unit = Format.fprintf f "" + +let pp_function_separator (f : Format.formatter) () : unit = + Format.fprintf f "@,@," + +let pp_mpp_function_separator (f : Format.formatter) () : unit = + Format.fprintf f "@,@,and " + +let generate_mpp_function (program : Bir.program) (oc : Format.formatter) + (f_name : Bir.function_name) : unit = + let Bir.{ mppf_stmts; _ } = + Bir.FunctionMap.find f_name program.mpp_functions + in + Format.fprintf oc "@[mpp_func_%s (context : m_context) : unit =@," f_name; + if List.length mppf_stmts = 0 then Format.fprintf oc "%s@]" "()" + else Format.fprintf oc "%a@]" (generate_stmts program) mppf_stmts + +let generate_mpp_functions (oc : Format.formatter) (program : Bir.program) = + let functions = Bir.FunctionMap.bindings program.Bir.mpp_functions in + let function_names, _ = List.split functions in + let pp_print_mpp_functions fmt function_names = + Format.pp_print_list ~pp_sep:pp_mpp_function_separator + (generate_mpp_function program) + fmt function_names + in + Format.fprintf oc "let rec %a@," pp_print_mpp_functions function_names + +let generate_rov_function (program : Bir.program) (oc : Format.formatter) + (rov : Bir.rule_or_verif) = + let tname, stmts = + match rov.rov_code with + | Rule stmts -> ("rule", stmts) + | Verif stmt -> ("verif", [ stmt ]) + in + Format.fprintf oc "@[let m_%s_%s (context : m_context) : unit =@,%a@]" + tname (Pos.unmark rov.rov_name) (generate_stmts program) stmts + +let generate_rov_functions (oc : Format.formatter) (program : Bir.program) : + unit = + let rovs = Bir.ROVMap.bindings program.rules_and_verifs in + let _, rovs = List.split rovs in + Format.pp_print_list ~pp_sep:pp_function_separator + (generate_rov_function program) + oc rovs + +let generate_header (oc : Format.formatter) () : unit = + Format.fprintf oc "@[open Mvalue@,@]" + +let generate_output (oc : Format.formatter) + (function_spec : Bir_interface.bir_function) : unit = + let output_vars = + List.map fst (Bir.VariableMap.bindings function_spec.func_outputs) + in + let name_and_pos_list var_list = + List.map + (fun var -> (get_var_pos var, Pos.unmark var.mir_var.name)) + var_list + in + let print_line fmt (position, name) = + Format.fprintf fmt "(\"%s\", %d)" name position + in + let pp_print_output_get fmt output_vars = + Format.pp_print_list ~pp_sep:pp_statement_separator print_line fmt + (name_and_pos_list output_vars) + in + Format.fprintf oc + "let output (tgv : m_array) : output_array =@,\ + let rev_code_from_position (x , p) : revenue_code = {alias = x; value = \ + (Array.get tgv p).value} in@,\ + let output_positions_array = @[[|%a|]@] in@,\ + Array.map rev_code_from_position output_positions_array" + pp_print_output_get output_vars + +let generate_input_handler (oc : Format.formatter) + (function_spec : Bir_interface.bir_function) : unit = + let input_vars = + List.map fst (Bir.VariableMap.bindings function_spec.func_variable_inputs) + in + let get_position_and_alias variable : (int * string) option = + let tgv_pos = get_var_pos variable in + Option.map (fun alias -> (tgv_pos, alias)) (get_var_alias variable) + in + let pp_print_line fmt variable : unit = + match get_position_and_alias variable with + | Some (position, alias) -> + Format.fprintf fmt "(\"%s\", %d);@," alias position + | None -> () + in + let pp_print_position_map fmt input_vars = + Format.pp_print_list ~pp_sep:pp_empty_separator pp_print_line fmt input_vars + in + Format.fprintf oc + "let input_handler (tgv : m_array) (entry_list : revenue_code list) : unit \ + =@,\ + let entry_positions_array = @[[|%a|]@] in@,\ + let entry_positions_map = @,\ + Array.fold_left (fun pos_map (alias, position) -> TgvPositionMap.add \ + alias position pos_map)@,\ + TgvPositionMap.empty entry_positions_array in@,\ + let init_tgv_var (entry_var : revenue_code) : unit =@,\ + Array.set tgv (TgvPositionMap.find entry_var.alias entry_positions_map)@,\ + {undefined = false ; value = entry_var.value} in@,\ + List.iter init_tgv_var entry_list" pp_print_position_map input_vars +(* Prévoir les cas : variable manquante, variable en trop dans entry_list, + variable définie n fois*) + +let generate_main_function (locals_size : int) (var_table_size : int) + (oc : Format.formatter) (program : Bir.program) : unit = + Format.fprintf oc + "let calculate_tax entry_list : (output_array * (m_error list)) =@,\ + let tgv : m_array = Array.make %i m_undef in@,\ + let local_variables : m_array = Array.make %i m_undef in@,\ + let errors = [] in@,\ + let context : m_context = {tgv; local_variables; errors} in@,\ + input_handler tgv entry_list;@,\ + %a;@,\ + (output tgv, context.errors)" var_table_size locals_size + (generate_stmts program) + (Bir.main_statements program) + +let generate_ocaml_program (program : Bir.program) + (function_spec : Bir_interface.bir_function) (_output_file : string) = + let _oc = open_out _output_file in + let oc = Format.formatter_of_out_channel _oc in + let locals_size = Bir.get_locals_size program |> ( + ) 1 in + let var_table_size = Bir.size_of_tgv () in + Format.fprintf oc "@[%a@,%a@,%a@,@,%a@,@,%a@,@,%a@]@." + generate_header () generate_rov_functions program generate_mpp_functions program + generate_input_handler function_spec + generate_output function_spec + (generate_main_function locals_size var_table_size) program; + close_out _oc + [@@ocamlformat "disable"] diff --git a/src/mlang/backend_compilers/bir_to_ocaml.mli b/src/mlang/backend_compilers/bir_to_ocaml.mli new file mode 100644 index 000000000..a4ed120b3 --- /dev/null +++ b/src/mlang/backend_compilers/bir_to_ocaml.mli @@ -0,0 +1,2 @@ +val generate_ocaml_program : + Bir.program -> Bir_interface.bir_function -> string -> unit diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index b60f0f21e..407a3715e 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -286,6 +286,13 @@ let driver (files : string list) (debug : bool) (var_info_debug : string list) function_spec !Cli.output_file vm; Cli.debug_print "Result written to %s" !Cli.output_file end + else if String.lowercase_ascii backend = "ocaml" then begin + Cli.debug_print "Compiling codebase to OCaml"; + if !Cli.output_file = "" then + Errors.raise_error "an output file must be defined with --output"; + Bir_to_ocaml.generate_ocaml_program combined_program function_spec + !Cli.output_file + end else Errors.raise_error (Format.asprintf "Unknown backend: %s" backend) | None -> Errors.raise_error "No backend specified!" diff --git a/src/mlang/irj_parser/dune b/src/mlang/irj_parser/dune new file mode 100644 index 000000000..ff3cc36dc --- /dev/null +++ b/src/mlang/irj_parser/dune @@ -0,0 +1,4 @@ +(ocamllex irj_lexer) + +(menhir + (modules irj_parser)) diff --git a/src/mlang/irj_parser/irj_ast.ml b/src/mlang/irj_parser/irj_ast.ml new file mode 100644 index 000000000..207e868cd --- /dev/null +++ b/src/mlang/irj_parser/irj_ast.ml @@ -0,0 +1,19 @@ +(*From test_ast.ml*) + +type literal = I of int | F of float + +type var_value = string * literal * Pos.t + +type var_values = var_value list + +type errors = (string * Pos.t) list + +type rappels = + (string * string * var_value * string * string * string * string * string) + list + +type irj_file = { + nom : string; + prim : var_values * errors * var_values; + rapp : (rappels * errors * var_values) option; +} diff --git a/src/mlang/irj_parser/irj_file.ml b/src/mlang/irj_parser/irj_file.ml new file mode 100644 index 000000000..a7a23cb97 --- /dev/null +++ b/src/mlang/irj_parser/irj_file.ml @@ -0,0 +1,25 @@ +(*From test_interpreter.ml*) + +open Irj_ast + +let parse_file (test_name : string) : irj_file = + let input = open_in test_name in + let filebuf = Lexing.from_channel input in + let filebuf = + { + filebuf with + lex_curr_p = { filebuf.lex_curr_p with pos_fname = test_name }; + } + in + let f = + try Irj_parser.irj_file Irj_lexer.token filebuf with + | Errors.StructuredError e -> + close_in input; + raise (Errors.StructuredError e) + | Irj_parser.Error -> + close_in input; + Errors.raise_spanned_error "Test syntax error" + (Parse_utils.mk_position (filebuf.lex_start_p, filebuf.lex_curr_p)) + in + close_in input; + f diff --git a/src/mlang/irj_parser/irj_file.mli b/src/mlang/irj_parser/irj_file.mli new file mode 100644 index 000000000..c0dab0c7f --- /dev/null +++ b/src/mlang/irj_parser/irj_file.mli @@ -0,0 +1,19 @@ +(* Copyright Inria, contributors: Raphaël Monat (2019) + Mathieu Durero (2023) + + This program is free software: you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free Software + Foundation, either version 3 of the License, or (at your option) any later + version. + + This program is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + 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 +(** [parse_file file] loads the content of a given IRJ [file] in a simple + datastructure. *) diff --git a/src/mlang/irj_parser/irj_lexer.mll b/src/mlang/irj_parser/irj_lexer.mll new file mode 100644 index 000000000..2fac3cd1f --- /dev/null +++ b/src/mlang/irj_parser/irj_lexer.mll @@ -0,0 +1,74 @@ +(* +Copyright Inria, contributors: + Raphaël Monat (2019) + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see . +*) + +{ +open Lexing +open Irj_parser +} + +rule token = parse +| [' ' '\t'] (* also ignore newlines, not only whitespace and tabs *) + { token lexbuf } +| '*' [^ '\n']* '\n' (* ignore comments *) + { new_line lexbuf; token lexbuf } +| '\n' | "\r\n" + { new_line lexbuf; token lexbuf} +| "/" + { SLASH } +| "#NOM" + { NOM } +| "#FIP" + { FIP } +| "#ENTREES-PRIMITIF" + { ENTREESPRIM } +| "#CONTROLES-PRIMITIF" + { CONTROLESPRIM } +| "#RESULTATS-PRIMITIF" + { RESULTATSPRIM } +| "#ENTREES-CORRECTIF" + { ENTREESCORR } +| "#CONTROLES-CORRECTIF" + { CONTROLESCORR } +| "#RESULTATS-CORRECTIF" + { RESULTATSCORR } +| "#ENTREES-RAPPELS" + { ENTREESRAPP } +| "#CONTROLES-RAPPELS" + { CONTROLESRAPP } +| "#RESULTATS-RAPPELS" + { RESULTATSRAPP } +| "#DATES" + { DATES } +| "#AVIS_IR" + { AVISIR } +| "#AVIS_CSG" + { AVISCSG } +| "##" + { ENDSHARP } +| '-'? ['0' - '9']+ as i + { INTEGER i } +| '-'? ['0' - '9']+ '.' ['0' - '9']* as f + { FLOAT f } +| ['a'-'z' 'A'-'Z' '0'-'9' '_']+ as s + { SYMBOL s } +| ['a'-'z' 'A'-'Z' ' ' '0'-'9' ';' '-']+ as s + { NAME s } +| eof + { EOF } +| _ + { Errors.raise_spanned_error "Test file lexer error" (Parse_utils.mk_position (Lexing.lexeme_start_p lexbuf, Lexing.lexeme_end_p lexbuf)) } diff --git a/src/mlang/irj_parser/irj_parser.mly b/src/mlang/irj_parser/irj_parser.mly new file mode 100644 index 000000000..8177c4e79 --- /dev/null +++ b/src/mlang/irj_parser/irj_parser.mly @@ -0,0 +1,107 @@ +(* +Copyright Inria, contributors: + Raphaël Monat (2019) + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see . +*) + +%{ open Irj_ast +%} + +%token SYMBOL NAME INTEGER FLOAT +/* Possibly use stronger constraints than just string on rappel's fields +some are characters, some are 0/1, etc. */ + +%token SLASH +/* Used as field separator */ +%token NOM FIP +/* Identifiers */ +%token ENTREESPRIM CONTROLESPRIM RESULTATSPRIM +/* Primary computation data blocks */ +%token ENTREESRAPP CONTROLESRAPP RESULTATSRAPP +/* Corrective computation data blocks */ +%token ENTREESCORR CONTROLESCORR RESULTATSCORR +/* Old form of corrective data blocks, always present and empty in primary computation test files */ +%token DATES AVISIR AVISCSG +/* Old empty data blocks rarely found in primary files from 2019 and older */ +%token ENDSHARP +/* Mark the end of a record */ + +%token EOF + +%type irj_file + +%start irj_file + +%% + +irj_file: +| NOM nom = name + fip? + prim = primitif + rapp = rappels + ENDSHARP { { nom; prim; rapp } } +| EOF { assert false } + +primitif: + ENTREESPRIM + entrees_primitif = list(variable_and_value) + CONTROLESPRIM + erreurs_attendues_primitif = list(error_code) + RESULTATSPRIM + resultats_attendus_primitif = list(variable_and_value) + { (entrees_primitif, erreurs_attendues_primitif, resultats_attendus_primitif) } + +rappels: +/* The two constructions match respectively corrective test files and primary test files */ +| ENTREESRAPP + entrees_rappels = list(rappel) + CONTROLESRAPP + erreurs_attendues_rappels = list(error_code) + RESULTATSRAPP + resultats_attendus_rappels = list(variable_and_value) + { Some (entrees_rappels, erreurs_attendues_rappels, resultats_attendus_rappels) } +| ENTREESCORR CONTROLESCORR RESULTATSCORR DATES? AVISIR? AVISCSG? { None } + +name: +| n = NAME { n } +| n = SYMBOL { n } + +fip: + FIP SLASH option(SYMBOL) { } + +variable_and_value: +| var = SYMBOL SLASH value = INTEGER { (var, I (int_of_string value), Parse_utils.mk_position $sloc) } +| var = SYMBOL SLASH value = FLOAT { (var, F (float_of_string value), Parse_utils.mk_position $sloc) } + +error_code: + error = SYMBOL { (error, Parse_utils.mk_position $sloc) } + +rappel: + event_nb = INTEGER SLASH + rappel_nb = INTEGER SLASH + variable_change = variable_and_value SLASH + direction = SYMBOL SLASH + penalty_code = INTEGER SLASH + base_tolerance_legale = INTEGER SLASH + month_year = INTEGER SLASH + decl_2042_rect = INTEGER + { (event_nb, + rappel_nb, + variable_change, + direction, + penalty_code, + base_tolerance_legale, + month_year, + decl_2042_rect) }