From 6b00947c58e4f4e8431f3948342a6d8829478e2e Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Wed, 5 Jul 2023 14:19:39 +0200 Subject: [PATCH 01/55] Report work on parser from ocaml-backend branch --- src/mlang/irj_parser/dune | 4 ++ src/mlang/irj_parser/irj_ast.ml | 19 ++++++ src/mlang/irj_parser/irj_file.ml | 25 ++++++++ src/mlang/irj_parser/irj_file.mli | 19 ++++++ src/mlang/irj_parser/irj_lexer.mll | 74 +++++++++++++++++++++ src/mlang/irj_parser/irj_parser.mly | 99 +++++++++++++++++++++++++++++ 6 files changed, 240 insertions(+) create mode 100644 src/mlang/irj_parser/dune create mode 100644 src/mlang/irj_parser/irj_ast.ml create mode 100644 src/mlang/irj_parser/irj_file.ml create mode 100644 src/mlang/irj_parser/irj_file.mli create mode 100644 src/mlang/irj_parser/irj_lexer.mll create mode 100644 src/mlang/irj_parser/irj_parser.mly 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..255f59e19 --- /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..eff8f4cf7 --- /dev/null +++ b/src/mlang/irj_parser/irj_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 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 +%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), 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) } From 68ea878d812ca6ead844f3ea67e9896fc8368840 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 6 Jul 2023 09:56:00 +0200 Subject: [PATCH 02/55] Reinstate old empty fields, if by chance some files from 2019 must be used --- src/mlang/irj_parser/irj_lexer.mll | 4 ++-- src/mlang/irj_parser/irj_parser.mly | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/mlang/irj_parser/irj_lexer.mll b/src/mlang/irj_parser/irj_lexer.mll index 255f59e19..2fac3cd1f 100644 --- a/src/mlang/irj_parser/irj_lexer.mll +++ b/src/mlang/irj_parser/irj_lexer.mll @@ -52,12 +52,12 @@ rule token = parse { CONTROLESRAPP } | "#RESULTATS-RAPPELS" { RESULTATSRAPP } -(*| "#DATES" +| "#DATES" { DATES } | "#AVIS_IR" { AVISIR } | "#AVIS_CSG" - { AVISCSG }*) + { AVISCSG } | "##" { ENDSHARP } | '-'? ['0' - '9']+ as i diff --git a/src/mlang/irj_parser/irj_parser.mly b/src/mlang/irj_parser/irj_parser.mly index eff8f4cf7..90ff36b40 100644 --- a/src/mlang/irj_parser/irj_parser.mly +++ b/src/mlang/irj_parser/irj_parser.mly @@ -28,7 +28,7 @@ some are characters, some are 0/1, etc. */ %token ENTREESPRIM CONTROLESPRIM RESULTATSPRIM %token ENTREESCORR CONTROLESCORR RESULTATSCORR %token ENTREESRAPP CONTROLESRAPP RESULTATSRAPP -/* %token DATES AVISIR AVISCSG*/ +%token DATES AVISIR AVISCSG %token ENDSHARP %token EOF @@ -64,7 +64,7 @@ rappels: RESULTATSRAPP resultats_attendus_rappels = list(variable_and_value) { Some (entrees_rappels, erreurs_attendues_rappels, resultats_attendus_rappels) } -| ENTREESCORR CONTROLESCORR RESULTATSCORR { None } +| ENTREESCORR CONTROLESCORR RESULTATSCORR DATES? AVISIR? AVISCSG? { None } name: | n = NAME { n } From 3d3aec5d52b40fc3122ca06ec4b99ddf60ec951c Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 6 Jul 2023 10:28:01 +0200 Subject: [PATCH 03/55] Describe tokens in comments --- src/mlang/irj_parser/irj_parser.mly | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/mlang/irj_parser/irj_parser.mly b/src/mlang/irj_parser/irj_parser.mly index 90ff36b40..8177c4e79 100644 --- a/src/mlang/irj_parser/irj_parser.mly +++ b/src/mlang/irj_parser/irj_parser.mly @@ -24,12 +24,19 @@ along with this program. If not, see . some are characters, some are 0/1, etc. */ %token SLASH +/* Used as field separator */ %token NOM FIP +/* Identifiers */ %token ENTREESPRIM CONTROLESPRIM RESULTATSPRIM -%token ENTREESCORR CONTROLESCORR RESULTATSCORR +/* 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 @@ -57,6 +64,7 @@ primitif: { (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 From 1ee211be5fc16e43ff4360dd1fdd8eff48cd1c66 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Wed, 25 May 2022 17:17:11 +0200 Subject: [PATCH 04/55] OCaml backend start --- examples/ocaml/Makefile | 26 ++++++++++ src/mlang/backend_compilers/bir_to_ocaml.ml | 50 ++++++++++++++++++++ src/mlang/backend_compilers/bir_to_ocaml.mli | 3 ++ src/mlang/driver.ml | 7 +++ 4 files changed, 86 insertions(+) create mode 100644 examples/ocaml/Makefile create mode 100644 src/mlang/backend_compilers/bir_to_ocaml.ml create mode 100644 src/mlang/backend_compilers/bir_to_ocaml.mli diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile new file mode 100644 index 000000000..0842824b7 --- /dev/null +++ b/examples/ocaml/Makefile @@ -0,0 +1,26 @@ +include ../../Makefile.include + +MLANG_BIN=dune exec --no-print-director ../../src/main.exe -- + +MLANG_DEFAULT_OPTS=\ + --display_time --debug \ + --mpp_file=$(MPP_FILE) \ + --mpp_function=compute_double_liquidation_pvro + +MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG) + +all: backend_tests $(shell find . -name "run_*.py") + +clean: + rm -f Ir_*.ml + +################################################## +# Generating and running Java files from Mlang +################################################## + +.PRECIOUS: Ir_%.ml +Ir_%.ml: ../../m_specs/%.m_spec + $(MLANG) \ + --backend ocaml --output $@ \ + --function_spec $^ \ + $(SOURCE_FILES) 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..313e5f751 --- /dev/null +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -0,0 +1,50 @@ +(* Backend OCaml *) + +let rec generate_stmts (program : Bir.program) (oc : Format.formatter) + (stmts : Bir.stmt list) : unit = + Format.pp_print_list (generate_stmt program) oc stmts + +and generate_stmt (_program : Bir.program) (oc : Format.formatter) + (stmt : Bir.stmt) : unit = + Format.fprintf oc "%s" + (match Pos.unmark stmt with + | SAssign (variable, _variable_data) -> Pos.unmark variable.mir_var.name + | SConditional (_expression, _tt, _ff) -> "Condition" + | SVerif _condition_data -> "Verif" + | SRuleCall _rule_id -> "Rule call" + | SFunctionCall (function_name, _) -> function_name) + +let generate_mpp_function (program : Bir.program) (oc : Format.formatter) + (function_name : string) : unit = + let stmts = Bir.FunctionMap.find function_name program.mpp_functions in + Format.fprintf oc "@[%s:@,%a@]" function_name (generate_stmts program) + stmts + +let generate_mpp_functions (oc : Format.formatter) (program : Bir.program) = + let functions = + Bir.FunctionMap.bindings + (Bir_interface.context_agnostic_mpp_functions program) + in + let function_names, _ = List.split functions in + Format.pp_print_list (generate_mpp_function program) oc function_names + +let generate_rule_method (program : Bir.program) (oc : Format.formatter) + (rule : Bir.rule) = + Format.fprintf oc "@[%s:@,%a@]" rule.rule_name (generate_stmts program) + rule.rule_stmts + +let generate_rule_methods (oc : Format.formatter) (program : Bir.program) : unit + = + let rules = Bir.RuleMap.bindings program.rules in + let _, rules = List.split rules in + Format.pp_print_list (generate_rule_method program) oc rules + +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 + Format.fprintf oc "@[%a@,@,%a@,%a@]@." generate_rule_methods program + generate_mpp_functions program (generate_stmts program) + (Bir.main_statements 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..0f372cbfa --- /dev/null +++ b/src/mlang/backend_compilers/bir_to_ocaml.mli @@ -0,0 +1,3 @@ + +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!" From 2f0249bb5070f6a8aa36f34ef13d8695d64cd797 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 3 Jun 2022 16:08:13 +0200 Subject: [PATCH 05/55] Add header defining M types and variables tables. --- src/mlang/backend_compilers/bir_to_ocaml.ml | 24 ++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 313e5f751..202900848 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -17,7 +17,7 @@ and generate_stmt (_program : Bir.program) (oc : Format.formatter) let generate_mpp_function (program : Bir.program) (oc : Format.formatter) (function_name : string) : unit = let stmts = Bir.FunctionMap.find function_name program.mpp_functions in - Format.fprintf oc "@[%s:@,%a@]" function_name (generate_stmts program) + Format.fprintf oc "@[%s:@,%a@]@," function_name (generate_stmts program) stmts let generate_mpp_functions (oc : Format.formatter) (program : Bir.program) = @@ -39,12 +39,30 @@ let generate_rule_methods (oc : Format.formatter) (program : Bir.program) : unit let _, rules = List.split rules in Format.pp_print_list (generate_rule_method program) oc rules +let generate_header (locals_size : int) (oc : Format.formatter) + (var_table_size : int) : unit = + Format.fprintf oc + "@[type m_value = {undefined : bool; value : float}@,\ + type m_array = m_value array@,\ + type m_context = m_value list@,\ + 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 tgv : m_array = Array.make %i m_undef@,\ + let local_variables : m_array = Array.make %i m_undef@,\ + @]" + var_table_size locals_size + 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 - Format.fprintf oc "@[%a@,@,%a@,%a@]@." generate_rule_methods program - generate_mpp_functions program (generate_stmts program) + 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@]*)@." + (generate_header locals_size) + var_table_size generate_rule_methods program generate_mpp_functions program + (generate_stmts program) (Bir.main_statements program); close_out _oc [@@ocamlformat disable] From 9e8e284c349f76d4b12443c2e639555d64b39a1f Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 3 Jun 2022 16:10:21 +0200 Subject: [PATCH 06/55] Define a M rule as an OCaml function of a list of M values. --- src/mlang/backend_compilers/bir_to_ocaml.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 202900848..e64a50bc8 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -30,8 +30,9 @@ let generate_mpp_functions (oc : Format.formatter) (program : Bir.program) = let generate_rule_method (program : Bir.program) (oc : Format.formatter) (rule : Bir.rule) = - Format.fprintf oc "@[%s:@,%a@]" rule.rule_name (generate_stmts program) - rule.rule_stmts + Format.fprintf oc + "@[let m_rule_%s (context : m_context) : unit =@,%a@]@," rule.rule_name + (generate_stmts program) rule.rule_stmts let generate_rule_methods (oc : Format.formatter) (program : Bir.program) : unit = From 57da5320bc534be962bf63ca06092109183bd86d Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 3 Jun 2022 16:14:48 +0200 Subject: [PATCH 07/55] Generate local and tgv variable assignment as OCaml array set. --- src/mlang/backend_compilers/bir_to_ocaml.ml | 177 +++++++++++++++++++- 1 file changed, 168 insertions(+), 9 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index e64a50bc8..2b16e331e 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -1,18 +1,177 @@ (* Backend OCaml *) +let none_value = "m_undef" + +let get_var_pos (var : Bir.variable) : int = var.Bir.offset + +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 -> "mNot" | Mast.Minus -> "mNeg" + +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 + ("Index", 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 _expr, local = generate_ocaml_expr arg in + ("PresentFunc", local) + | FunctionCall (NullFunc, [ arg ]) -> + let _expr, local = generate_ocaml_expr arg in + ("NullFunc", local) + | FunctionCall (ArrFunc, [ arg ]) -> + let _expr, local = generate_ocaml_expr arg in + ("ArrFunc", local) + | FunctionCall (InfFunc, [ arg ]) -> + let _expr, local = generate_ocaml_expr arg in + ("InfFunc", local) + | FunctionCall (MaxFunc, [ e1; _e2 ]) -> + let _s1, local1 = generate_ocaml_expr e1 in + ("MaxFunc", local1) + | FunctionCall (MinFunc, [ e1; _e2 ]) -> + let _s1, local1 = generate_ocaml_expr e1 in + ("MinFunc", local1) + | FunctionCall (Multimax, [ e1; (Var _v2, _) ]) -> + let _s1, local1 = generate_ocaml_expr e1 in + ("Multimax", 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 "(get tgv %d (*%s*))" (get_var_pos var) + (Pos.unmark var.mir_var.name), + [] ) + | LocalVar _lvar -> ("localvar", []) (*TODO*) + | GenericTableIndex -> ("generic table index", []) (* TODO *) + | 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 tgv %d %s;@," + variable_position variable_expression + +let format_local_defs (oc : Format.formatter) + (defs : (Mir.LocalVariable.t * Bir.expression Pos.marked) list) : unit = + Format.pp_print_list + (fun fmt (lvar, expr) -> + let se, _ = generate_ocaml_expr expr in + Format.fprintf fmt + "Array.set local_variables %d %s;@," + lvar.Mir.LocalVariable.id se) + oc defs + +let generate_var_def (variable : Bir.variable) (vdata : Bir.variable_data) + (oc : Format.formatter) : unit = + match vdata.var_definition with + | SimpleVar e -> + let tgv_expression, local_defs = generate_ocaml_expr e in + Format.fprintf oc "%a(*%s*) %a" format_local_defs local_defs + (Pos.unmark variable.mir_var.name) + (format_tgv_set tgv_expression) + (get_var_pos variable) + | TableVar (_, IndexTable es) -> + Format.fprintf oc "%a" + (fun fmt -> + Mir.IndexMap.iter (fun i v -> + let tgv_expression, local_defs = generate_ocaml_expr v in + Format.fprintf fmt "%a(*%s*) %a" format_local_defs local_defs + (Pos.unmark variable.mir_var.name) + (format_tgv_set tgv_expression) + (get_var_pos variable |> ( + ) i))) + es + | TableVar (size, IndexGeneric e) -> + let tgv_expression, local_defs = generate_ocaml_expr e in + let list_pos = + let rec integer_range first_item last_item = + if first_item > last_item then [] + else first_item :: integer_range (first_item + 1) last_item + in + integer_range (get_var_pos variable) (get_var_pos variable + size) + in + let aux_print_list (list_pos : int list) (oc : Format.formatter) + (tgv_expression : string) = + List.iter (format_tgv_set tgv_expression oc) list_pos + in + Format.fprintf oc "%a(*Table %s*)@,%a" format_local_defs local_defs + (Pos.unmark variable.mir_var.name) + (aux_print_list list_pos) tgv_expression + | InputVar -> assert false + let rec generate_stmts (program : Bir.program) (oc : Format.formatter) (stmts : Bir.stmt list) : unit = - Format.pp_print_list (generate_stmt program) oc stmts + Format.pp_print_list ~pp_sep:Format.pp_print_if_newline + (generate_stmt program) oc stmts -and generate_stmt (_program : Bir.program) (oc : Format.formatter) +and generate_stmt (program : Bir.program) (oc : Format.formatter) (stmt : Bir.stmt) : unit = - Format.fprintf oc "%s" - (match Pos.unmark stmt with - | SAssign (variable, _variable_data) -> Pos.unmark variable.mir_var.name - | SConditional (_expression, _tt, _ff) -> "Condition" - | SVerif _condition_data -> "Verif" - | SRuleCall _rule_id -> "Rule call" - | SFunctionCall (function_name, _) -> function_name) + match Pos.unmark stmt with + | SAssign (variable, variable_data) -> + generate_var_def variable variable_data oc + | SConditional (_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 + Format.fprintf oc "@[Condition %s :@,true ->@,%a@,false ->@,%a@]" + cond_name (generate_stmts program) tt (generate_stmts program) ff + | SVerif _condition_data -> Format.fprintf oc "%s" "Verif" + | SRuleCall _rule_id -> Format.fprintf oc "Rule %i call" _rule_id + | SFunctionCall (function_name, _) -> Format.fprintf oc "%s" function_name let generate_mpp_function (program : Bir.program) (oc : Format.formatter) (function_name : string) : unit = From 03d69dd0f215c655703f06c557b0cd8fb36eaf6d Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 3 Jun 2022 16:16:05 +0200 Subject: [PATCH 08/55] Ignore VSCodium config files --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 19d1ee050..50f4ea1ff 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ doc.html *~ /_opam /Makefile.config +/.vscode From f23f1261e170ab915f71ed8225c714d7d454da90 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 9 Jun 2022 10:37:27 +0200 Subject: [PATCH 09/55] Formatting --- src/mlang/backend_compilers/bir_to_ocaml.ml | 9 ++++----- src/mlang/backend_compilers/bir_to_ocaml.mli | 1 - 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 2b16e331e..1b0fc0971 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -95,16 +95,15 @@ let rec generate_ocaml_expr (e : Bir.expression Pos.marked) : let format_tgv_set (variable_expression : string) (oc : Format.formatter) (variable_position : int) : unit = - Format.fprintf oc "Array.set tgv %d %s;@," - variable_position variable_expression + Format.fprintf oc "Array.set tgv %d %s;@," variable_position + variable_expression let format_local_defs (oc : Format.formatter) (defs : (Mir.LocalVariable.t * Bir.expression Pos.marked) list) : unit = Format.pp_print_list (fun fmt (lvar, expr) -> let se, _ = generate_ocaml_expr expr in - Format.fprintf fmt - "Array.set local_variables %d %s;@," + Format.fprintf fmt "Array.set local_variables %d %s;@," lvar.Mir.LocalVariable.id se) oc defs @@ -225,4 +224,4 @@ let generate_ocaml_program (program : Bir.program) (generate_stmts program) (Bir.main_statements program); close_out _oc - [@@ocamlformat disable] + [@@ocamlformat "disable"] diff --git a/src/mlang/backend_compilers/bir_to_ocaml.mli b/src/mlang/backend_compilers/bir_to_ocaml.mli index 0f372cbfa..a4ed120b3 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.mli +++ b/src/mlang/backend_compilers/bir_to_ocaml.mli @@ -1,3 +1,2 @@ - val generate_ocaml_program : Bir.program -> Bir_interface.bir_function -> string -> unit From f232d1e30d2597be52cc1d73712cf135f4cf9daa Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 9 Jun 2022 15:44:36 +0200 Subject: [PATCH 10/55] Adjust to pull request #146 generic-table-access --- src/mlang/backend_compilers/bir_to_ocaml.ml | 32 +++++++++++---------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 1b0fc0971..7e2371289 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -86,7 +86,6 @@ let rec generate_ocaml_expr (e : Bir.expression Pos.marked) : (Pos.unmark var.mir_var.name), [] ) | LocalVar _lvar -> ("localvar", []) (*TODO*) - | GenericTableIndex -> ("generic table index", []) (* TODO *) | Error -> assert false (* should not happen *) | LocalLet (lvar, e1, e2) -> let _, local1 = generate_ocaml_expr e1 in @@ -98,6 +97,16 @@ let format_tgv_set (variable_expression : string) (oc : Format.formatter) Format.fprintf oc "Array.set 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 tgv (%d + (((*%s*) Array.get 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 format_local_defs (oc : Format.formatter) (defs : (Mir.LocalVariable.t * Bir.expression Pos.marked) list) : unit = Format.pp_print_list @@ -126,22 +135,15 @@ let generate_var_def (variable : Bir.variable) (vdata : Bir.variable_data) (format_tgv_set tgv_expression) (get_var_pos variable |> ( + ) i))) es - | TableVar (size, IndexGeneric e) -> + | TableVar (_size, IndexGeneric (v, e)) -> let tgv_expression, local_defs = generate_ocaml_expr e in - let list_pos = - let rec integer_range first_item last_item = - if first_item > last_item then [] - else first_item :: integer_range (first_item + 1) last_item - in - integer_range (get_var_pos variable) (get_var_pos variable + size) - in - let aux_print_list (list_pos : int list) (oc : Format.formatter) - (tgv_expression : string) = - List.iter (format_tgv_set tgv_expression oc) list_pos - in - Format.fprintf oc "%a(*Table %s*)@,%a" format_local_defs local_defs + Format.fprintf oc + "if (Array.get tgv %d (*%s*)).undefined then %a(*Table %s*)@,%a" + (get_var_pos v) + (Pos.unmark v.mir_var.name) + format_local_defs local_defs (Pos.unmark variable.mir_var.name) - (aux_print_list list_pos) tgv_expression + (format_tgv_set_with_offset (get_var_pos variable) v) tgv_expression | InputVar -> assert false let rec generate_stmts (program : Bir.program) (oc : Format.formatter) From 51697120a715ad5b3c3ede3ffd505d1850ff3e92 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 9 Jun 2022 15:47:42 +0200 Subject: [PATCH 11/55] Add empty expression at the end of each generated rule --- src/mlang/backend_compilers/bir_to_ocaml.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 7e2371289..168d644b0 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -82,7 +82,7 @@ let rec generate_ocaml_expr (e : Bir.expression Pos.marked) : ) | Literal Undefined -> (Format.asprintf "%s" none_value, []) | Var var -> - ( Format.asprintf "(get tgv %d (*%s*))" (get_var_pos var) + ( Format.asprintf "(Array.get tgv %d (*%s*))" (get_var_pos var) (Pos.unmark var.mir_var.name), [] ) | LocalVar _lvar -> ("localvar", []) (*TODO*) @@ -191,7 +191,7 @@ let generate_mpp_functions (oc : Format.formatter) (program : Bir.program) = let generate_rule_method (program : Bir.program) (oc : Format.formatter) (rule : Bir.rule) = Format.fprintf oc - "@[let m_rule_%s (context : m_context) : unit =@,%a@]@," rule.rule_name + "@[let m_rule_%s (context : m_context) : unit =@,%a@]@,()" rule.rule_name (generate_stmts program) rule.rule_stmts let generate_rule_methods (oc : Format.formatter) (program : Bir.program) : unit From 24e84f5beae5df67d887cae35318a5ec7ea00b8d Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 9 Jun 2022 15:49:02 +0200 Subject: [PATCH 12/55] New makefile target : compiling result to native code. --- examples/ocaml/Makefile | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile index 0842824b7..40a15cda9 100644 --- a/examples/ocaml/Makefile +++ b/examples/ocaml/Makefile @@ -12,15 +12,18 @@ MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG) all: backend_tests $(shell find . -name "run_*.py") clean: - rm -f Ir_*.ml + rm -f ir_*.ml ################################################## # Generating and running Java files from Mlang ################################################## -.PRECIOUS: Ir_%.ml -Ir_%.ml: ../../m_specs/%.m_spec +.PRECIOUS: ir_%.ml +ir_%.ml: ../../m_specs/%.m_spec $(MLANG) \ --backend ocaml --output $@ \ --function_spec $^ \ $(SOURCE_FILES) + +ir_%.exe: ir_%.ml + ocamlfind opt -o $@ $^ \ No newline at end of file From 9d92f766c22c8b1b04562e06de2185bca334666a Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 9 Jun 2022 17:32:54 +0200 Subject: [PATCH 13/55] Generate OCaml functions corresponding to M binary and unary operators --- src/mlang/backend_compilers/bir_to_ocaml.ml | 83 ++++++++++++++++++++- 1 file changed, 82 insertions(+), 1 deletion(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 168d644b0..4adcc0deb 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -206,11 +206,92 @@ let generate_header (locals_size : int) (oc : Format.formatter) "@[type m_value = {undefined : bool; value : float}@,\ type m_array = m_value array@,\ type m_context = m_value list@,\ - let m_undef : m_value = {undefined = true ; value = 0.0}@,\ + let m_undef : m_value = {undefined = true ; value = 0.0} (*Ajouter contrainte value doit être 0*) @,\ let m_zero : m_value = {undefined = false; value = 0.0}@,\ let m_one : m_value = {undefined = false; value = 1.0}@,\ let tgv : m_array = Array.make %i m_undef@,\ let local_variables : m_array = Array.make %i m_undef@,\ + @,@,\ + 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 \ + | _ -> true_value\ + @,(*ou de la forme m_value(true,_)-> ?*)@,\ + let m_cond_2 (condition : m_value) (true_value : m_value) (false_value : m_value) : m_value =\ + if condition.undefined then m_undef \ + else if condition.value = 0.0 then false_value else 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 = true ; value = Float.neg x.value}\ + @,\ @]" var_table_size locals_size From bf306c56b83ecef77a127d574ffa0f47dcfacd96 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 10 Jun 2022 11:28:36 +0200 Subject: [PATCH 14/55] Define M types and operators in a static OCaml library. --- examples/ocaml/.merlin | 1 + examples/ocaml/Makefile | 10 ++- examples/ocaml/mvalue.ml | 85 ++++++++++++++++++++ src/mlang/backend_compilers/bir_to_ocaml.ml | 87 +-------------------- 4 files changed, 95 insertions(+), 88 deletions(-) create mode 100644 examples/ocaml/.merlin create mode 100644 examples/ocaml/mvalue.ml diff --git a/examples/ocaml/.merlin b/examples/ocaml/.merlin new file mode 100644 index 000000000..1a04478a0 --- /dev/null +++ b/examples/ocaml/.merlin @@ -0,0 +1 @@ +S * diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile index 40a15cda9..d3c6ed771 100644 --- a/examples/ocaml/Makefile +++ b/examples/ocaml/Makefile @@ -12,7 +12,7 @@ MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG) all: backend_tests $(shell find . -name "run_*.py") clean: - rm -f ir_*.ml + rm -f ir_*.ml mvalue.cmi mvalue.cmo mvalue.out mvalue.o mvalue.cmx ################################################## # Generating and running Java files from Mlang @@ -26,4 +26,10 @@ ir_%.ml: ../../m_specs/%.m_spec $(SOURCE_FILES) ir_%.exe: ir_%.ml - ocamlfind opt -o $@ $^ \ No newline at end of file + ocamlopt -o $@ mvalue.ml $^ + +ir_%.out: ir_%.ml + ocamlc.opt -o $@ mvalue.ml $^ + +mvalue.out: + ocamlc.opt -c mvalue.ml \ No newline at end of file diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml new file mode 100644 index 000000000..bce423679 --- /dev/null +++ b/examples/ocaml/mvalue.ml @@ -0,0 +1,85 @@ +type m_value = { undefined : bool; value : float } + +type m_array = m_value array + +type m_context = m_value list + +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 = true; value = Float.neg x.value } diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 4adcc0deb..bd61c1988 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -203,94 +203,9 @@ let generate_rule_methods (oc : Format.formatter) (program : Bir.program) : unit let generate_header (locals_size : int) (oc : Format.formatter) (var_table_size : int) : unit = Format.fprintf oc - "@[type m_value = {undefined : bool; value : float}@,\ - type m_array = m_value array@,\ - type m_context = m_value list@,\ - let m_undef : m_value = {undefined = true ; value = 0.0} (*Ajouter contrainte value doit être 0*) @,\ - let m_zero : m_value = {undefined = false; value = 0.0}@,\ - let m_one : m_value = {undefined = false; value = 1.0}@,\ + "@[open Mvalue@,\ let tgv : m_array = Array.make %i m_undef@,\ let local_variables : m_array = Array.make %i m_undef@,\ - @,@,\ - 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 \ - | _ -> true_value\ - @,(*ou de la forme m_value(true,_)-> ?*)@,\ - let m_cond_2 (condition : m_value) (true_value : m_value) (false_value : m_value) : m_value =\ - if condition.undefined then m_undef \ - else if condition.value = 0.0 then false_value else 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 = true ; value = Float.neg x.value}\ @,\ @]" var_table_size locals_size From 6a8b168cc2e43a09d619598812cc2739b68a8ed0 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 10 Jun 2022 17:12:08 +0200 Subject: [PATCH 15/55] Cleaning --- .gitignore | 1 + examples/ocaml/.merlin | 1 - examples/ocaml/Makefile | 4 ++-- 3 files changed, 3 insertions(+), 3 deletions(-) delete mode 100644 examples/ocaml/.merlin diff --git a/.gitignore b/.gitignore index 50f4ea1ff..e4a273409 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ doc.html /_opam /Makefile.config /.vscode +examples/ocaml/**/.merlin \ No newline at end of file diff --git a/examples/ocaml/.merlin b/examples/ocaml/.merlin deleted file mode 100644 index 1a04478a0..000000000 --- a/examples/ocaml/.merlin +++ /dev/null @@ -1 +0,0 @@ -S * diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile index d3c6ed771..77dbf0f6e 100644 --- a/examples/ocaml/Makefile +++ b/examples/ocaml/Makefile @@ -12,10 +12,10 @@ MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG) all: backend_tests $(shell find . -name "run_*.py") clean: - rm -f ir_*.ml mvalue.cmi mvalue.cmo mvalue.out mvalue.o mvalue.cmx + rm -f ir_*.ml ir_*.o ir_*.cmi ir_*.cmx ir_*.exe mvalue.cmi mvalue.cmo mvalue.out mvalue.o mvalue.cmx ################################################## -# Generating and running Java files from Mlang +# Generating and running OCaml files from Mlang ################################################## .PRECIOUS: ir_%.ml From a852bab49acf865b3f192addd8e53d7ecb1013c3 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 10 Jun 2022 17:14:54 +0200 Subject: [PATCH 16/55] Add M functions to the OCaml library and use them in generated code --- examples/ocaml/mvalue.ml | 54 ++++++++++++++++ src/mlang/backend_compilers/bir_to_ocaml.ml | 71 ++++++++++++--------- 2 files changed, 96 insertions(+), 29 deletions(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index bce423679..dc06e069b 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -83,3 +83,57 @@ let m_not (x : m_value) : m_value = let m_neg (x : m_value) : m_value = if x.undefined then m_undef else { undefined = true; 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 = + { undefined = false; value = max x.value y.value } + +let m_min (x : m_value) (y : m_value) : m_value = + { 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 = + floor (if x.value < 0.0 then x.value -. 0.50005 else 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_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 get_position_value_or_zero (position) = + m_add (Array.get variable_array position) m_zero + in + let rec multimax (variable_array) (current_index) + (max_index) (reference) = + let new_max = + m_max reference (get_position_value_or_zero current_index) + in + if current_index = max_index then new_max + else multimax variable_array (current_index + 1) max_index new_max + in + if bound >= 1 then + multimax variable_array (position + 1) (position + bound) + (get_position_value_or_zero position) + else get_position_value_or_zero position diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index bd61c1988..208708e1d 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -23,7 +23,7 @@ let generate_binop (op : Mast.binop) : string = | Mast.Div -> "m_divide" let generate_unop (op : Mast.unop) : string = - match op with Mast.Not -> "mNot" | Mast.Minus -> "mNeg" + 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 = @@ -43,49 +43,60 @@ let rec generate_ocaml_expr (e : Bir.expression Pos.marked) : | 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 - ("Index", 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 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 _expr, local = generate_ocaml_expr arg in - ("PresentFunc", local) + let s, local = generate_ocaml_expr arg in + (Format.asprintf "(m_present %s)" s, local) | FunctionCall (NullFunc, [ arg ]) -> - let _expr, local = generate_ocaml_expr arg in - ("NullFunc", local) + let s, local = generate_ocaml_expr arg in + (Format.asprintf "(m_null %s)" s, local) | FunctionCall (ArrFunc, [ arg ]) -> - let _expr, local = generate_ocaml_expr arg in - ("ArrFunc", local) + let s, local = generate_ocaml_expr arg in + (Format.asprintf "(m_round %s)" s, local) | FunctionCall (InfFunc, [ arg ]) -> - let _expr, local = generate_ocaml_expr arg in - ("InfFunc", local) - | FunctionCall (MaxFunc, [ e1; _e2 ]) -> - let _s1, local1 = generate_ocaml_expr e1 in - ("MaxFunc", local1) - | FunctionCall (MinFunc, [ e1; _e2 ]) -> - let _s1, local1 = generate_ocaml_expr e1 in - ("MinFunc", local1) - | FunctionCall (Multimax, [ e1; (Var _v2, _) ]) -> - let _s1, local1 = generate_ocaml_expr e1 in - ("Multimax", local1) + let s, local = generate_ocaml_expr arg in + (Format.asprintf "(m_floor %s)" s, local) + | 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 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), []) + (Format.asprintf "{undefined = false ; value = %s}" (string_of_float f), []) ) | Literal Undefined -> (Format.asprintf "%s" none_value, []) | Var var -> ( Format.asprintf "(Array.get tgv %d (*%s*))" (get_var_pos var) (Pos.unmark var.mir_var.name), [] ) - | LocalVar _lvar -> ("localvar", []) (*TODO*) + | LocalVar lvar -> + ( Format.asprintf "(Array.get local_variables %d)" + lvar.Mir.LocalVariable.id, + [] ) | Error -> assert false (* should not happen *) | LocalLet (lvar, e1, e2) -> let _, local1 = generate_ocaml_expr e1 in @@ -97,8 +108,9 @@ let format_tgv_set (variable_expression : string) (oc : Format.formatter) Format.fprintf oc "Array.set 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 = +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 tgv (%d + (((*%s*) Array.get tgv %d).value |> int_of_float)) \ %s;@," @@ -143,7 +155,8 @@ let generate_var_def (variable : Bir.variable) (vdata : Bir.variable_data) (Pos.unmark v.mir_var.name) format_local_defs local_defs (Pos.unmark variable.mir_var.name) - (format_tgv_set_with_offset (get_var_pos variable) v) tgv_expression + (format_tgv_set_with_offset (get_var_pos variable) v) + tgv_expression | InputVar -> assert false let rec generate_stmts (program : Bir.program) (oc : Format.formatter) @@ -191,8 +204,8 @@ let generate_mpp_functions (oc : Format.formatter) (program : Bir.program) = let generate_rule_method (program : Bir.program) (oc : Format.formatter) (rule : Bir.rule) = Format.fprintf oc - "@[let m_rule_%s (context : m_context) : unit =@,%a@]@,()" rule.rule_name - (generate_stmts program) rule.rule_stmts + "@[let m_rule_%s (context : m_context) : unit =@,%a@]()@," + rule.rule_name (generate_stmts program) rule.rule_stmts let generate_rule_methods (oc : Format.formatter) (program : Bir.program) : unit = @@ -216,7 +229,7 @@ let generate_ocaml_program (program : Bir.program) 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@]*)@." + Format.fprintf oc "@[%a@,%a@,(*@,%a@,let calculate_tax = %a@]*)@." (generate_header locals_size) var_table_size generate_rule_methods program generate_mpp_functions program (generate_stmts program) From ace22fb205fd8d826e136f31c7a6fdc9ff0484bc Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Tue, 14 Jun 2022 09:13:07 +0200 Subject: [PATCH 17/55] More thorough cleaning --- examples/ocaml/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile index 77dbf0f6e..9c92328af 100644 --- a/examples/ocaml/Makefile +++ b/examples/ocaml/Makefile @@ -12,7 +12,7 @@ MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG) all: backend_tests $(shell find . -name "run_*.py") clean: - rm -f ir_*.ml ir_*.o ir_*.cmi ir_*.cmx ir_*.exe mvalue.cmi mvalue.cmo mvalue.out mvalue.o mvalue.cmx + rm -f ir_*.ml ir_*.o ir_*.cmi ir_*.cmx ir_*.exe ir_*.cmo ir_*.out mvalue.cmi mvalue.cmo mvalue.out mvalue.o mvalue.cmx ################################################## # Generating and running OCaml files from Mlang From d2dfcc70e40b781d84629e3bd8cb81a5d8928b19 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Tue, 14 Jun 2022 09:36:10 +0200 Subject: [PATCH 18/55] Generate Mpp condition, rule and function calls. --- examples/ocaml/mvalue.ml | 2 +- src/mlang/backend_compilers/bir_to_ocaml.ml | 146 ++++++++++++-------- 2 files changed, 88 insertions(+), 60 deletions(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index dc06e069b..b75fb500d 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -2,7 +2,7 @@ type m_value = { undefined : bool; value : float } type m_array = m_value array -type m_context = m_value list +type m_context = { tgv : m_array; local_variables : m_array} let m_undef : m_value = { undefined = true; value = 0.0 } diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 208708e1d..e3bb65749 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -49,7 +49,7 @@ let rec generate_ocaml_expr (e : Bir.expression Pos.marked) : let size = Option.get (Bir.var_to_mir unmarked_var).Mir.Variable.is_table in - ( Format.asprintf "(m_table_value_at_index tgv %d %s %d)" + ( Format.asprintf "(m_table_value_at_index context.tgv %d %s %d)" (get_var_pos unmarked_var) expr size, local ) | Conditional (e1, e2, e3) -> @@ -79,22 +79,24 @@ let rec generate_ocaml_expr (e : Bir.expression Pos.marked) : (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 tgv %d)" s1 (get_var_pos v2), local1) + ( 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), []) - ) + ( Format.asprintf "{undefined = false ; value = %s}" + (string_of_float f), + [] )) | Literal Undefined -> (Format.asprintf "%s" none_value, []) | Var var -> - ( Format.asprintf "(Array.get tgv %d (*%s*))" (get_var_pos 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 local_variables %d)" + ( Format.asprintf "(Array.get context.local_variables %d)" lvar.Mir.LocalVariable.id, [] ) | Error -> assert false (* should not happen *) @@ -105,55 +107,61 @@ let rec generate_ocaml_expr (e : Bir.expression Pos.marked) : let format_tgv_set (variable_expression : string) (oc : Format.formatter) (variable_position : int) : unit = - Format.fprintf oc "Array.set tgv %d %s;@," variable_position + 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 tgv (%d + (((*%s*) Array.get tgv %d).value |> int_of_float)) \ - %s;@," + "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 format_local_defs (oc : Format.formatter) +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 = - Format.pp_print_list - (fun fmt (lvar, expr) -> - let se, _ = generate_ocaml_expr expr in - Format.fprintf fmt "Array.set local_variables %d %s;@," - lvar.Mir.LocalVariable.id se) - oc defs + 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) (vdata : Bir.variable_data) (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 vdata.var_definition with - | SimpleVar e -> - let tgv_expression, local_defs = generate_ocaml_expr e in - Format.fprintf oc "%a(*%s*) %a" format_local_defs local_defs - (Pos.unmark variable.mir_var.name) - (format_tgv_set tgv_expression) - (get_var_pos variable) + | SimpleVar e -> generate_one_var (get_var_pos variable) oc e | TableVar (_, IndexTable es) -> - Format.fprintf oc "%a" - (fun fmt -> - Mir.IndexMap.iter (fun i v -> - let tgv_expression, local_defs = generate_ocaml_expr v in - Format.fprintf fmt "%a(*%s*) %a" format_local_defs local_defs - (Pos.unmark variable.mir_var.name) - (format_tgv_set tgv_expression) - (get_var_pos variable |> ( + ) i))) - 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 tgv %d (*%s*)).undefined then %a(*Table %s*)@,%a" + "if (Array.get context.tgv %d (*%s*)).undefined then %a(*Table %s*)@,%a" (get_var_pos v) (Pos.unmark v.mir_var.name) - format_local_defs local_defs + generate_local_defs local_defs (Pos.unmark variable.mir_var.name) (format_tgv_set_with_offset (get_var_pos variable) v) tgv_expression @@ -161,15 +169,15 @@ let generate_var_def (variable : Bir.variable) (vdata : Bir.variable_data) let rec generate_stmts (program : Bir.program) (oc : Format.formatter) (stmts : Bir.stmt list) : unit = - Format.pp_print_list ~pp_sep:Format.pp_print_if_newline - (generate_stmt program) oc stmts + 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 (_expression, tt, ff) -> + | SConditional (cond_expression, tt, ff) -> let pos = Pos.get_position stmt in let fname = String.map @@ -181,17 +189,30 @@ and generate_stmt (program : Bir.program) (oc : Format.formatter) (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos) in - Format.fprintf oc "@[Condition %s :@,true ->@,%a@,false ->@,%a@]" - cond_name (generate_stmts program) tt (generate_stmts program) ff + 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@,\ + | m_undef -> ()@,\ + | m_zero -> (@[%a@])@,\ + | _ -> (@[%a@]))@]" cond_name s cond_name (generate_stmts program) + tt (generate_stmts program) ff | SVerif _condition_data -> Format.fprintf oc "%s" "Verif" - | SRuleCall _rule_id -> Format.fprintf oc "Rule %i call" _rule_id - | SFunctionCall (function_name, _) -> Format.fprintf oc "%s" function_name + | SRuleCall rule_id -> + let rule = Mir.RuleMap.find rule_id program.rules in + Format.fprintf oc "m_rule_%s context" rule.rule_name + | SFunctionCall (function_name, _) -> + Format.fprintf oc "mpp_func_%s context" function_name + +let pp_function_separator (f : Format.formatter) () : unit = + Format.fprintf f "@,@," let generate_mpp_function (program : Bir.program) (oc : Format.formatter) (function_name : string) : unit = let stmts = Bir.FunctionMap.find function_name program.mpp_functions in - Format.fprintf oc "@[%s:@,%a@]@," function_name (generate_stmts program) - stmts + Format.fprintf oc + "@[let mpp_func_%s (context : m_context) : unit =@,%a@]" function_name + (generate_stmts program) stmts let generate_mpp_functions (oc : Format.formatter) (program : Bir.program) = let functions = @@ -199,29 +220,38 @@ let generate_mpp_functions (oc : Format.formatter) (program : Bir.program) = (Bir_interface.context_agnostic_mpp_functions program) in let function_names, _ = List.split functions in - Format.pp_print_list (generate_mpp_function program) oc function_names + Format.pp_print_list ~pp_sep:pp_function_separator + (generate_mpp_function program) + oc function_names let generate_rule_method (program : Bir.program) (oc : Format.formatter) (rule : Bir.rule) = - Format.fprintf oc - "@[let m_rule_%s (context : m_context) : unit =@,%a@]()@," + Format.fprintf oc "@[let m_rule_%s (context : m_context) : unit =@,%a@]" rule.rule_name (generate_stmts program) rule.rule_stmts let generate_rule_methods (oc : Format.formatter) (program : Bir.program) : unit = let rules = Bir.RuleMap.bindings program.rules in let _, rules = List.split rules in - Format.pp_print_list (generate_rule_method program) oc rules + Format.pp_print_list ~pp_sep:pp_function_separator + (generate_rule_method program) + oc rules + +let generate_header (oc : Format.formatter) () : unit = + Format.fprintf oc "@[open Mvalue@,@]" -let generate_header (locals_size : int) (oc : Format.formatter) - (var_table_size : int) : unit = +let generate_main_function (locals_size : int) (var_table_size : int) + (oc : Format.formatter) (program : Bir.program) : unit = Format.fprintf oc - "@[open Mvalue@,\ - let tgv : m_array = Array.make %i m_undef@,\ - let local_variables : m_array = Array.make %i m_undef@,\ - @,\ - @]" - var_table_size locals_size + "let calculate_tax : unit =@,\ + let tgv : m_array = Array.make %i m_undef in@,\ + let local_variables : m_array = Array.make %i m_undef in@,\ + let context : m_context = {tgv; local_variables} in@,\ + Array.set context.tgv 2062 {undefined = false ; value = 150000.0};@,\ + %a;\ + Printf.printf \"%%b %%f\" (Array.get context.tgv 4949).undefined (Array.get context.tgv 4949).value" + 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) = @@ -229,10 +259,8 @@ let generate_ocaml_program (program : Bir.program) 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@,let calculate_tax = %a@]*)@." - (generate_header locals_size) - var_table_size generate_rule_methods program generate_mpp_functions program - (generate_stmts program) - (Bir.main_statements program); + Format.fprintf oc "@[%a@,%a@,%a@,%a@]@." + generate_header () generate_rule_methods program generate_mpp_functions program + (generate_main_function locals_size var_table_size) program; close_out _oc [@@ocamlformat "disable"] From 58fb9df5e7405c0cf7c2bc9b2d3676fd85c8b05e Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Wed, 15 Jun 2022 16:11:03 +0200 Subject: [PATCH 19/55] Enable debug symbols on bytecode target --- examples/ocaml/Makefile | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile index 9c92328af..3713577dc 100644 --- a/examples/ocaml/Makefile +++ b/examples/ocaml/Makefile @@ -9,8 +9,6 @@ MLANG_DEFAULT_OPTS=\ MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG) -all: backend_tests $(shell find . -name "run_*.py") - clean: rm -f ir_*.ml ir_*.o ir_*.cmi ir_*.cmx ir_*.exe ir_*.cmo ir_*.out mvalue.cmi mvalue.cmo mvalue.out mvalue.o mvalue.cmx @@ -28,8 +26,8 @@ ir_%.ml: ../../m_specs/%.m_spec ir_%.exe: ir_%.ml ocamlopt -o $@ mvalue.ml $^ -ir_%.out: ir_%.ml - ocamlc.opt -o $@ mvalue.ml $^ +ir_%.bc: ir_%.ml + ocamlc.opt -g -o $@ mvalue.ml $^ mvalue.out: ocamlc.opt -c mvalue.ml \ No newline at end of file From 6482ec8668b1c959d5565e14ac0e6d29fc620e46 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Wed, 15 Jun 2022 16:13:54 +0200 Subject: [PATCH 20/55] Fix Mpp condition generation --- src/mlang/backend_compilers/bir_to_ocaml.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index e3bb65749..5404b0583 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -193,8 +193,8 @@ and generate_stmt (program : Bir.program) (oc : Format.formatter) Format.fprintf oc "@[let %s : m_value = %s in@,\ (match %s with@,\ - | m_undef -> ()@,\ - | m_zero -> (@[%a@])@,\ + | { undefined = true ; value = _ } -> ()@,\ + | { undefined = false ; value = 0.0 }-> (@[%a@])@,\ | _ -> (@[%a@]))@]" cond_name s cond_name (generate_stmts program) tt (generate_stmts program) ff | SVerif _condition_data -> Format.fprintf oc "%s" "Verif" From 7daae5e740031e5dcf2df744949dca39acea3e0c Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Wed, 15 Jun 2022 16:15:42 +0200 Subject: [PATCH 21/55] Formatting --- examples/ocaml/mvalue.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index b75fb500d..386f5482a 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -2,7 +2,7 @@ type m_value = { undefined : bool; value : float } type m_array = m_value array -type m_context = { tgv : m_array; local_variables : m_array} +type m_context = { tgv : m_array; local_variables : m_array } let m_undef : m_value = { undefined = true; value = 0.0 } @@ -122,11 +122,10 @@ let m_multimax (bound_variable : m_value) (variable_array : m_array) if bound_variable.undefined then failwith "Multimax bound undefined!" else let bound = int_of_float bound_variable.value in - let get_position_value_or_zero (position) = + let get_position_value_or_zero position = m_add (Array.get variable_array position) m_zero in - let rec multimax (variable_array) (current_index) - (max_index) (reference) = + let rec multimax variable_array current_index max_index reference = let new_max = m_max reference (get_position_value_or_zero current_index) in From 1047796b681ed5c22d4dc3814e4e66ad613c86a6 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Wed, 15 Jun 2022 16:18:12 +0200 Subject: [PATCH 22/55] Input handling OCaml backend --- examples/ocaml/mvalue.ml | 4 ++ src/mlang/backend_compilers/bir_to_ocaml.ml | 50 ++++++++++++++++++--- 2 files changed, 47 insertions(+), 7 deletions(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index 386f5482a..edc755f25 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -4,6 +4,10 @@ type m_array = m_value array type m_context = { tgv : m_array; local_variables : m_array } +type revenue_code = { alias : string; value : float } + +module TgvPositionMap = Map.Make (String) + let m_undef : m_value = { undefined = true; value = 0.0 } let m_zero : m_value = { undefined = false; value = 0.0 } diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 5404b0583..7ca3aa631 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -4,6 +4,8 @@ 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" @@ -240,27 +242,61 @@ let generate_rule_methods (oc : Format.formatter) (program : Bir.program) : unit let generate_header (oc : Format.formatter) () : unit = Format.fprintf oc "@[open Mvalue@,@]" +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 + "let tgv_positions = TgvPositionMap.add \"%s\" %d tgv_positions in" + alias position + | None -> () + in + let pp_print_position_map fmt input_vars = + Format.pp_print_list pp_print_line fmt + input_vars + in + Format.fprintf oc + "let input_handler (tgv : m_array) (entry_list : revenue_code list) : unit \ + =@,\ + let tgv_positions = TgvPositionMap.empty in@,\ + %a@,\ + let init_tgv_var (entry_var : revenue_code) : unit =@,\ + Array.set tgv @,\ + (TgvPositionMap.find entry_var.alias tgv_positions)@, \ + {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 : unit =@,\ + "let calculate_tax entry_list : unit =@,\ let tgv : m_array = Array.make %i m_undef in@,\ let local_variables : m_array = Array.make %i m_undef in@,\ let context : m_context = {tgv; local_variables} in@,\ - Array.set context.tgv 2062 {undefined = false ; value = 150000.0};@,\ - %a;\ - Printf.printf \"%%b %%f\" (Array.get context.tgv 4949).undefined (Array.get context.tgv 4949).value" - var_table_size locals_size (generate_stmts program) + input_handler tgv entry_list;@,\ + %a;" 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) = + (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@]@." + Format.fprintf oc "@[%a@,%a@,%a@,@,%a@,@,%a@]@." generate_header () generate_rule_methods program generate_mpp_functions program + generate_input_handler function_spec (generate_main_function locals_size var_table_size) program; close_out _oc [@@ocamlformat "disable"] From 768b8cd49d8f377e03bf3411cf241f2869125d4a Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 16 Jun 2022 10:21:57 +0200 Subject: [PATCH 23/55] Adjust OCaml backend to pull request #153 mpp function data structure --- src/mlang/backend_compilers/bir_to_ocaml.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 7ca3aa631..d9b656ead 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -210,11 +210,11 @@ let pp_function_separator (f : Format.formatter) () : unit = Format.fprintf f "@,@," let generate_mpp_function (program : Bir.program) (oc : Format.formatter) - (function_name : string) : unit = - let stmts = Bir.FunctionMap.find function_name program.mpp_functions in + (f_name : Bir.function_name) : unit = + let Bir.{mppf_stmts; _} = Bir.FunctionMap.find f_name program.mpp_functions in Format.fprintf oc - "@[let mpp_func_%s (context : m_context) : unit =@,%a@]" function_name - (generate_stmts program) stmts + "@[let mpp_func_%s (context : m_context) : unit =@,%a@]" f_name + (generate_stmts program) mppf_stmts let generate_mpp_functions (oc : Format.formatter) (program : Bir.program) = let functions = From 84e2fae371549a58bb905dca19417d38d37bffb3 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 16 Jun 2022 12:32:22 +0200 Subject: [PATCH 24/55] Add output to the sort of main function calculate_tax --- examples/ocaml/mvalue.ml | 4 ++ src/mlang/backend_compilers/bir_to_ocaml.ml | 48 +++++++++++++++------ 2 files changed, 39 insertions(+), 13 deletions(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index edc755f25..dd7035736 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -8,6 +8,10 @@ type revenue_code = { alias : string; value : float } module TgvPositionMap = Map.Make (String) +type input_list = revenue_code list + +type output_list = revenue_code list + let m_undef : m_value = { undefined = true; value = 0.0 } let m_zero : m_value = { undefined = false; value = 0.0 } diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index d9b656ead..a2f826172 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -211,7 +211,9 @@ let pp_function_separator (f : Format.formatter) () : unit = 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 + let Bir.{ mppf_stmts; _ } = + Bir.FunctionMap.find f_name program.mpp_functions + in Format.fprintf oc "@[let mpp_func_%s (context : m_context) : unit =@,%a@]" f_name (generate_stmts program) mppf_stmts @@ -242,6 +244,26 @@ let generate_rule_methods (oc : Format.formatter) (program : Bir.program) : unit 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 "{alias = \"%s\" ; value = (Array.get tgv %d).value} ::" + name position + in + let pp_print_output_get fmt output_vars = + Format.pp_print_list print_line fmt (name_and_pos_list output_vars) + in + Format.fprintf oc "let output (tgv : m_array) : output_list =@,%a []@," + pp_print_output_get output_vars + let generate_input_handler (oc : Format.formatter) (function_spec : Bir_interface.bir_function) : unit = let input_vars = @@ -260,8 +282,7 @@ let generate_input_handler (oc : Format.formatter) | None -> () in let pp_print_position_map fmt input_vars = - Format.pp_print_list pp_print_line fmt - input_vars + Format.pp_print_list pp_print_line fmt input_vars in Format.fprintf oc "let input_handler (tgv : m_array) (entry_list : revenue_code list) : unit \ @@ -269,23 +290,23 @@ let generate_input_handler (oc : Format.formatter) let tgv_positions = TgvPositionMap.empty in@,\ %a@,\ let init_tgv_var (entry_var : revenue_code) : unit =@,\ - Array.set tgv @,\ - (TgvPositionMap.find entry_var.alias tgv_positions)@, \ - {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*) + Array.set tgv @,\ + (TgvPositionMap.find entry_var.alias tgv_positions)@,\ + \ {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 : unit =@,\ + "let calculate_tax entry_list : output_list =@,\ let tgv : m_array = Array.make %i m_undef in@,\ let local_variables : m_array = Array.make %i m_undef in@,\ let context : m_context = {tgv; local_variables} in@,\ input_handler tgv entry_list;@,\ - %a;" var_table_size locals_size (generate_stmts program) + %a;@,\ + output tgv" var_table_size locals_size (generate_stmts program) (Bir.main_statements program) let generate_ocaml_program (program : Bir.program) @@ -294,9 +315,10 @@ let generate_ocaml_program (program : Bir.program) 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@]@." + Format.fprintf oc "@[%a@,%a@,%a@,@,%a@,@,%a@,@,%a@]@." generate_header () generate_rule_methods 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"] From 6552368568642b8bf07ff00534b4db1fcda568c0 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 17 Jun 2022 16:24:50 +0200 Subject: [PATCH 25/55] WIP test harness: load FIP files, call the compiled result of OCaml backend with entry parameters and write computation result to text files --- examples/ocaml/Makefile | 7 ++- examples/ocaml/test_harness.ml | 106 +++++++++++++++++++++++++++++++++ 2 files changed, 111 insertions(+), 2 deletions(-) create mode 100644 examples/ocaml/test_harness.ml diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile index 3713577dc..46f50162c 100644 --- a/examples/ocaml/Makefile +++ b/examples/ocaml/Makefile @@ -10,7 +10,7 @@ MLANG_DEFAULT_OPTS=\ MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG) clean: - rm -f ir_*.ml ir_*.o ir_*.cmi ir_*.cmx ir_*.exe ir_*.cmo ir_*.out mvalue.cmi mvalue.cmo mvalue.out mvalue.o mvalue.cmx + rm -f ir_*.ml *.o *.cmi *.cmx ir_*.exe *.cmo *.bc *_resultat.txt ################################################## # Generating and running OCaml files from Mlang @@ -29,5 +29,8 @@ ir_%.exe: ir_%.ml ir_%.bc: ir_%.ml ocamlc.opt -g -o $@ mvalue.ml $^ -mvalue.out: +test_%: ir_%.ml + ocamlc.opt -g -o $@.bc mvalue.ml $^ test_harness.ml + +mvalue.bc: ocamlc.opt -c mvalue.ml \ 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..5764f191b --- /dev/null +++ b/examples/ocaml/test_harness.ml @@ -0,0 +1,106 @@ +open Mvalue + + (* .Chargement d'un fichier FIP + .Sortir la structure revenue_code list + .Appeler Ir_xx.calculate_tax + .Récupérer les valeurs de sorties + Comparer les valeurs de sorties à celles attendues précisées dans le fichier FIP + .Écrire le résultat quelque part *)[@ocamlformat "disable"] + +type test_block = { block_name : string; block_data : Mvalue.revenue_code list } + +type test_data = { test_name : string; blocks : test_block list } + +let load_file (input_file : string) : string list = + let ic = open_in input_file in + let rec build_list line_list = + match input_line ic with + | next_line -> build_list (next_line :: line_list) + | exception End_of_file -> + close_in ic; + List.rev line_list + | exception e -> + close_in_noerr ic; + raise e + in + build_list [] + +let line2revenue_code line : Mvalue.revenue_code = + match String.split_on_char '/' line with + | [ head; tail ] -> { alias = head; value = Float.of_string tail } + | [] -> failwith "Empty line !" + | _ :: tail -> failwith "Line with multiple separators /." +(*let build_entry_list (input_file : string) : Mvalue.revenue_code list =*) + +let parse_codes line_list : Mvalue.revenue_code list = + match line_list with [] -> [] | _ -> List.map line2revenue_code line_list + +let parse_block line_list : test_block = + match line_list with + | head :: tail when String.starts_with ~prefix:"#" head -> + { block_name = head; block_data = parse_codes tail } + | _ -> failwith "Data block has not the expected structure." + +let rec split_blocks (line_list : string list) + (line_list_list : string list list) : string list list = + match line_list with + | [] -> List.rev (List.map List.rev line_list_list) + | line :: tail -> + if String.starts_with ~prefix:"#" line then + split_blocks tail ([ [ line ] ] @ line_list_list) + else + split_blocks tail + (([ line ] @ List.hd line_list_list) :: List.tl line_list_list) + +let parse_FIP line_list : test_data = + match line_list with + | head :: name :: tail -> + { test_name = name; blocks = List.map parse_block (split_blocks tail []) } + | _ -> failwith "FIP file has not the expected structure." + +let get_data_block (input_file : string) (block_name : string) : + Mvalue.revenue_code list = + (List.find + (fun block -> block.block_name = block_name) + (parse_FIP (load_file input_file)).blocks) + .block_data + +let entry_list (input_file : string) : Mvalue.revenue_code list = + get_data_block input_file "#ENTREES-PRIMITIF" + +let write_codes (_output_file : string) (result_list : Mvalue.revenue_code list) + : unit = + let _oc = open_out _output_file in + let oc = Format.formatter_of_out_channel _oc in + let print_result_line fmt (result : Mvalue.revenue_code) = + Format.fprintf fmt "%s : %f" result.alias result.value + in + let print_results fmt (result_list : Mvalue.revenue_code list) = + Format.pp_print_list print_result_line fmt result_list + in + Format.fprintf oc "@[%a@]@." print_results result_list; + close_out _oc + +let () = + Format.printf "Programme %s lancé.\nA lu dans %s\n Écrira x_%s\n" Sys.argv.(0) + Sys.argv.(1) Sys.argv.(2); + write_codes ("Aentprim_" ^ Sys.argv.(2)) (entry_list Sys.argv.(1)); + write_codes + ("Aresprim_" ^ Sys.argv.(2)) + (get_data_block Sys.argv.(1) "#RESULTATS-PRIMITIF"); + write_codes + ("Arescorr_" ^ Sys.argv.(2)) + (get_data_block Sys.argv.(1) "#RESULTATS-CORRECTIF"); + write_codes + ("Acalfix_" ^ Sys.argv.(2)) + (Ir_tests_2020.calculate_tax + [ + { alias = "1AJ"; value = 120000.0 }; + { alias = "1BJ"; value = 120000.0 }; + { alias = "0CF"; value = 0.0 }; + ]); + write_codes + ("Acalcul_" ^ Sys.argv.(2)) + (Ir_tests_2020.calculate_tax (entry_list Sys.argv.(1))) + +(* (Ir_basic_case.calculate_tax entry_list)*) \ No newline at end of file From 4bb21bc328b9c47d98693607d95f7c2e5185b630 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Tue, 21 Jun 2022 09:54:06 +0200 Subject: [PATCH 26/55] Fix m_neg function: output of defined M value should be defined --- examples/ocaml/mvalue.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index dd7035736..0ceb74206 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -90,7 +90,7 @@ let m_not (x : m_value) : m_value = let m_neg (x : m_value) : m_value = if x.undefined then m_undef - else { undefined = true; value = Float.neg x.value } + 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) = From 5f799afedc455fa6ca49ec69373461d4679a71f0 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Tue, 21 Jun 2022 09:56:49 +0200 Subject: [PATCH 27/55] Write discrepancies between FIP file and computation result as a test result --- examples/ocaml/test_harness.ml | 67 ++++++++++++++++++++++++++-------- 1 file changed, 52 insertions(+), 15 deletions(-) diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index 5764f191b..f94b5769c 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -1,8 +1,10 @@ -open Mvalue +open + Mvalue (* .Chargement d'un fichier FIP .Sortir la structure revenue_code list - .Appeler Ir_xx.calculate_tax + .Appeler Ir_xx.calculate_tax + Sélectionner la calculatrice à l'exécution et pas à la compilation .Récupérer les valeurs de sorties Comparer les valeurs de sorties à celles attendues précisées dans le fichier FIP .Écrire le résultat quelque part *)[@ocamlformat "disable"] @@ -11,6 +13,8 @@ type test_block = { block_name : string; block_data : Mvalue.revenue_code list } type test_data = { test_name : string; blocks : test_block list } +let compare_rev_code code1 code2 : int = compare code1.alias code2.alias + let load_file (input_file : string) : string list = let ic = open_in input_file in let rec build_list line_list = @@ -30,7 +34,6 @@ let line2revenue_code line : Mvalue.revenue_code = | [ head; tail ] -> { alias = head; value = Float.of_string tail } | [] -> failwith "Empty line !" | _ :: tail -> failwith "Line with multiple separators /." -(*let build_entry_list (input_file : string) : Mvalue.revenue_code list =*) let parse_codes line_list : Mvalue.revenue_code list = match line_list with [] -> [] | _ -> List.map line2revenue_code line_list @@ -68,6 +71,28 @@ let get_data_block (input_file : string) (block_name : string) : let entry_list (input_file : string) : Mvalue.revenue_code list = get_data_block input_file "#ENTREES-PRIMITIF" +let reference_list (input_file : string) : Mvalue.revenue_code list = + get_data_block input_file "#RESULTATS-PRIMITIF" + +let filter_output out_list ref_list : Mvalue.revenue_code list = + let alias_eq code1 code2 = + if code1.alias = code2.alias then true else false + in + let ref_exists code : bool = + List.exists (fun ref_code -> alias_eq code ref_code) ref_list + in + List.filter ref_exists out_list + +let list_discrepancies filtered_list ref_list : + (Mvalue.revenue_code * Mvalue.revenue_code) list = + let value_neq (code1, code2) = + if code1.value = code2.value then false else true + in + List.filter value_neq + (List.combine + (List.sort compare_rev_code filtered_list) + (List.sort compare_rev_code ref_list)) + let write_codes (_output_file : string) (result_list : Mvalue.revenue_code list) : unit = let _oc = open_out _output_file in @@ -81,26 +106,38 @@ let write_codes (_output_file : string) (result_list : Mvalue.revenue_code list) Format.fprintf oc "@[%a@]@." print_results result_list; close_out _oc +let write_discrepancies (_output_file : string) + (discrepancy_list : (Mvalue.revenue_code * Mvalue.revenue_code) list) : unit = + let _oc = open_out _output_file in + let oc = Format.formatter_of_out_channel _oc in + let print_line fmt (discrepancy : Mvalue.revenue_code * Mvalue.revenue_code) = + let result, reference = discrepancy in + Format.fprintf fmt "%s/%f %s/%f" result.alias result.value reference.alias + reference.value + in + let print_results fmt + (result_list : (Mvalue.revenue_code * Mvalue.revenue_code) list) = + Format.pp_print_list print_line fmt result_list + in + Format.fprintf oc "@[Valeur calculée | Référence@,%a@]@." print_results + discrepancy_list; + close_out _oc + let () = + let tax_result = Ir_tests_2020.calculate_tax (entry_list Sys.argv.(1)) in + let ref_list = reference_list Sys.argv.(1) in Format.printf "Programme %s lancé.\nA lu dans %s\n Écrira x_%s\n" Sys.argv.(0) Sys.argv.(1) Sys.argv.(2); write_codes ("Aentprim_" ^ Sys.argv.(2)) (entry_list Sys.argv.(1)); - write_codes - ("Aresprim_" ^ Sys.argv.(2)) - (get_data_block Sys.argv.(1) "#RESULTATS-PRIMITIF"); + write_codes ("Aresprim_" ^ Sys.argv.(2)) (List.sort compare_rev_code ref_list); write_codes ("Arescorr_" ^ Sys.argv.(2)) (get_data_block Sys.argv.(1) "#RESULTATS-CORRECTIF"); - write_codes - ("Acalfix_" ^ Sys.argv.(2)) - (Ir_tests_2020.calculate_tax - [ - { alias = "1AJ"; value = 120000.0 }; - { alias = "1BJ"; value = 120000.0 }; - { alias = "0CF"; value = 0.0 }; - ]); write_codes ("Acalcul_" ^ Sys.argv.(2)) - (Ir_tests_2020.calculate_tax (entry_list Sys.argv.(1))) + (List.sort compare_rev_code tax_result); + write_discrepancies + ("Adisc_" ^ Sys.argv.(2)) + (list_discrepancies (filter_output tax_result ref_list) ref_list) (* (Ir_basic_case.calculate_tax entry_list)*) \ No newline at end of file From 316f477caf608baf5555df09018ec68510f033c7 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Tue, 21 Jun 2022 15:12:12 +0200 Subject: [PATCH 28/55] Fix m_round: use ceil for negative values. --- examples/ocaml/mvalue.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index 0ceb74206..bd789eb01 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -114,7 +114,8 @@ let m_round (x : m_value) : m_value = { undefined = false; value = - floor (if x.value < 0.0 then x.value -. 0.50005 else x.value +. 0.50005); + (if x.value < 0.0 then ceil (x.value -. 0.50005) + else floor (x.value +. 0.50005)); } let m_null = m_not From 032bae4bcee70c37cb477f2fde2c83fa81b8064d Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Tue, 21 Jun 2022 15:15:30 +0200 Subject: [PATCH 29/55] =?UTF-8?q?Fix=20Mpp=20conditional:=C2=A0true=20and?= =?UTF-8?q?=20false=20expressions=20were=20inverted?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/mlang/backend_compilers/bir_to_ocaml.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index a2f826172..f561de4e0 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -198,7 +198,7 @@ and generate_stmt (program : Bir.program) (oc : Format.formatter) | { undefined = true ; value = _ } -> ()@,\ | { undefined = false ; value = 0.0 }-> (@[%a@])@,\ | _ -> (@[%a@]))@]" cond_name s cond_name (generate_stmts program) - tt (generate_stmts program) ff + ff (generate_stmts program) tt | SVerif _condition_data -> Format.fprintf oc "%s" "Verif" | SRuleCall rule_id -> let rule = Mir.RuleMap.find rule_id program.rules in From 428ccf1a98146228603d9204f3924d2a24df0e38 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Tue, 21 Jun 2022 16:41:42 +0200 Subject: [PATCH 30/55] Test harness for OCaml backend: can print discrepancy reports for a single FIP file or all files from a test directory. --- examples/ocaml/Makefile | 6 +- examples/ocaml/test_harness.ml | 140 +++++++++++++++++++++------------ 2 files changed, 92 insertions(+), 54 deletions(-) diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile index 46f50162c..add9fa92a 100644 --- a/examples/ocaml/Makefile +++ b/examples/ocaml/Makefile @@ -10,7 +10,7 @@ MLANG_DEFAULT_OPTS=\ MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG) clean: - rm -f ir_*.ml *.o *.cmi *.cmx ir_*.exe *.cmo *.bc *_resultat.txt + rm -f ir_*.ml *.o *.cmi *.cmx ir_*.exe *.cmo *.bc *_disc.txt ################################################## # Generating and running OCaml files from Mlang @@ -30,7 +30,7 @@ ir_%.bc: ir_%.ml ocamlc.opt -g -o $@ mvalue.ml $^ test_%: ir_%.ml - ocamlc.opt -g -o $@.bc mvalue.ml $^ test_harness.ml + ocamlc.opt -g -o $@.bc unix.cma mvalue.ml $^ test_harness.ml mvalue.bc: - ocamlc.opt -c mvalue.ml \ No newline at end of file + ocamlc.opt -c mvalue.ml diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index f94b5769c..443172b00 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -1,20 +1,9 @@ -open - Mvalue - - (* .Chargement d'un fichier FIP - .Sortir la structure revenue_code list - .Appeler Ir_xx.calculate_tax - Sélectionner la calculatrice à l'exécution et pas à la compilation - .Récupérer les valeurs de sorties - Comparer les valeurs de sorties à celles attendues précisées dans le fichier FIP - .Écrire le résultat quelque part *)[@ocamlformat "disable"] +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 compare_rev_code code1 code2 : int = compare code1.alias code2.alias - let load_file (input_file : string) : string list = let ic = open_in input_file in let rec build_list line_list = @@ -29,6 +18,22 @@ let load_file (input_file : string) : string list = in build_list [] +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 line2revenue_code line : Mvalue.revenue_code = match String.split_on_char '/' line with | [ head; tail ] -> { alias = head; value = Float.of_string tail } @@ -74,14 +79,14 @@ let entry_list (input_file : string) : Mvalue.revenue_code list = let reference_list (input_file : string) : Mvalue.revenue_code list = get_data_block input_file "#RESULTATS-PRIMITIF" -let filter_output out_list ref_list : Mvalue.revenue_code list = +let filter_rev_code_list initial_list ref_list : Mvalue.revenue_code list = let alias_eq code1 code2 = if code1.alias = code2.alias then true else false in let ref_exists code : bool = List.exists (fun ref_code -> alias_eq code ref_code) ref_list in - List.filter ref_exists out_list + List.filter ref_exists initial_list let list_discrepancies filtered_list ref_list : (Mvalue.revenue_code * Mvalue.revenue_code) list = @@ -93,51 +98,84 @@ let list_discrepancies filtered_list ref_list : (List.sort compare_rev_code filtered_list) (List.sort compare_rev_code ref_list)) -let write_codes (_output_file : string) (result_list : Mvalue.revenue_code list) - : unit = - let _oc = open_out _output_file in - let oc = Format.formatter_of_out_channel _oc in - let print_result_line fmt (result : Mvalue.revenue_code) = - Format.fprintf fmt "%s : %f" result.alias result.value - in - let print_results fmt (result_list : Mvalue.revenue_code list) = - Format.pp_print_list print_result_line fmt result_list - in - Format.fprintf oc "@[%a@]@." print_results result_list; - close_out _oc +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 write_discrepancies (_output_file : string) - (discrepancy_list : (Mvalue.revenue_code * Mvalue.revenue_code) list) : unit = - let _oc = open_out _output_file in - let oc = Format.formatter_of_out_channel _oc in +let compute_discrepancies_from_file_2020 (fip_file : string) : + (Mvalue.revenue_code * Mvalue.revenue_code) list = + let tax_result = Ir_tests_2020.calculate_tax (entry_list fip_file) in + let ref_list = reference_list fip_file in + Format.printf "Test case: %s@." fip_file; + list_discrepancies (filter_rev_code_list tax_result ref_list) 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 "%s/%f %s/%f" result.alias result.value reference.alias - reference.value + 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 - Format.fprintf oc "@[Valeur calculée | Référence@,%a@]@." print_results - discrepancy_list; + 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 run_test_directory (directory : string) (output_file_name : string) : unit = + let dir_handle = Unix.opendir directory in + let file_list = + List.map (String.cat directory) (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 = 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 () = - let tax_result = Ir_tests_2020.calculate_tax (entry_list Sys.argv.(1)) in - let ref_list = reference_list Sys.argv.(1) in - Format.printf "Programme %s lancé.\nA lu dans %s\n Écrira x_%s\n" Sys.argv.(0) - Sys.argv.(1) Sys.argv.(2); - write_codes ("Aentprim_" ^ Sys.argv.(2)) (entry_list Sys.argv.(1)); - write_codes ("Aresprim_" ^ Sys.argv.(2)) (List.sort compare_rev_code ref_list); - write_codes - ("Arescorr_" ^ Sys.argv.(2)) - (get_data_block Sys.argv.(1) "#RESULTATS-CORRECTIF"); - write_codes - ("Acalcul_" ^ Sys.argv.(2)) - (List.sort compare_rev_code tax_result); - write_discrepancies - ("Adisc_" ^ Sys.argv.(2)) - (list_discrepancies (filter_output tax_result ref_list) ref_list) - -(* (Ir_basic_case.calculate_tax entry_list)*) \ No newline at end of file + Format.printf "Starting %s.@." Sys.argv.(0); + match Sys.argv.(1) with + | "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 From f00f9f2432d8fd22262a3dac1180b80eb718dfbf Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Wed, 22 Jun 2022 16:54:24 +0200 Subject: [PATCH 31/55] Fix: if bool then true else false --- examples/ocaml/test_harness.ml | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index 443172b00..43986f2fd 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -80,9 +80,7 @@ let reference_list (input_file : string) : Mvalue.revenue_code list = get_data_block input_file "#RESULTATS-PRIMITIF" let filter_rev_code_list initial_list ref_list : Mvalue.revenue_code list = - let alias_eq code1 code2 = - if code1.alias = code2.alias then true else false - in + 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 @@ -90,9 +88,7 @@ let filter_rev_code_list initial_list ref_list : Mvalue.revenue_code list = let list_discrepancies filtered_list ref_list : (Mvalue.revenue_code * Mvalue.revenue_code) list = - let value_neq (code1, code2) = - if code1.value = code2.value then false else true - in + let value_neq (code1, code2) = not (code1.value = code2.value) in List.filter value_neq (List.combine (List.sort compare_rev_code filtered_list) From 69cd84fa3cdd0da1fba932c605ed3d761cba59ce Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 23 Jun 2022 10:20:44 +0200 Subject: [PATCH 32/55] Add warning when a FIP file expects an output variable which is not in the output variable list, generally because it's an input variable, so it is pointless to mark it as output. --- examples/ocaml/test_harness.ml | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index 43986f2fd..0df7b1d57 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -102,8 +102,26 @@ let compute_discrepancies_from_file_2020 (fip_file : string) : (Mvalue.revenue_code * Mvalue.revenue_code) list = let tax_result = Ir_tests_2020.calculate_tax (entry_list fip_file) in let ref_list = reference_list fip_file in - Format.printf "Test case: %s@." fip_file; - list_discrepancies (filter_rev_code_list tax_result ref_list) ref_list + 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 : From c2bf05a38200f23d06984b72933388ea4ea9a6c7 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 23 Jun 2022 10:21:53 +0200 Subject: [PATCH 33/55] Add a test command to write raw inputs and outputs of a FIP test --- examples/ocaml/test_harness.ml | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index 0df7b1d57..9cdaafdd5 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -159,6 +159,27 @@ let test_FIP_2020 (fip_file : string) (output_file_name : string) : unit = print_discrepancies oc discrepancy_list fip_file; close_out _oc +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 _discrepancy_list = compute_discrepancies_from_file_2020 fip_file in *) + let tax_result = Ir_tests_2020.calculate_tax (entry_list fip_file) in + let ref_list = reference_list fip_file in + let print_list fmt code_list = + Format.pp_print_list print_rev_code fmt code_list + in + Format.printf "Test case: %s@." fip_file; + Format.fprintf oc + "@[REFERENCE@,@,%a@,@,OUTPUT@,@,%a@,@,FILTERED OUTPUT@,@,%a@,@]" + 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 = @@ -190,6 +211,7 @@ let run_test_directory (directory : string) (output_file_name : string) : unit = 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 From 69e21bb8251f2362ba4efebc12eb0503cc879382 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 23 Jun 2022 18:56:26 +0200 Subject: [PATCH 34/55] M errors and verifications are now recorded and an output of the main calculate_tax function. Test command "raw" now writes also the list of triggered M errors. --- examples/ocaml/mvalue.ml | 15 ++++- examples/ocaml/test_harness.ml | 41 +++++++++---- src/mlang/backend_compilers/bir_to_ocaml.ml | 64 +++++++++++++++++---- 3 files changed, 99 insertions(+), 21 deletions(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index bd789eb01..e7415e870 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -2,7 +2,20 @@ type m_value = { undefined : bool; value : float } type m_array = m_value array -type m_context = { tgv : m_array; local_variables : m_array } +type m_error = { + name : string; + kind : string; + major_code : string; + minor_code : string; + description : string; + alias : string; +} + +type m_context = { + tgv : m_array; + local_variables : m_array; + mutable errors : m_error list; +} type revenue_code = { alias : string; value : float } diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index 9cdaafdd5..86c6b212c 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -100,7 +100,7 @@ let print_rev_code (oc : Format.formatter) (rev_code : Mvalue.revenue_code) : let compute_discrepancies_from_file_2020 (fip_file : string) : (Mvalue.revenue_code * Mvalue.revenue_code) list = - let tax_result = Ir_tests_2020.calculate_tax (entry_list fip_file) in + let tax_result, errors = Ir_tests_2020.calculate_tax (entry_list fip_file) in let ref_list = reference_list fip_file 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 @@ -111,12 +111,12 @@ let compute_discrepancies_from_file_2020 (fip_file : string) : 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 "" + 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 @@ -159,20 +159,41 @@ let test_FIP_2020 (fip_file : string) (output_file_name : string) : unit = print_discrepancies oc discrepancy_list fip_file; close_out _oc +let print_error oc (error : m_error) : unit = + Format.fprintf oc "Name: %s, kind: %s, description: %s" error.name error.kind + error.description + +let print_errors oc error_list = Format.pp_print_list print_error oc error_list + 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 _discrepancy_list = compute_discrepancies_from_file_2020 fip_file in *) - let tax_result = Ir_tests_2020.calculate_tax (entry_list fip_file) in + let tax_result, errors = Ir_tests_2020.calculate_tax (entry_list fip_file) in let ref_list = reference_list fip_file in let print_list fmt code_list = Format.pp_print_list print_rev_code fmt code_list in Format.printf "Test case: %s@." fip_file; Format.fprintf oc - "@[REFERENCE@,@,%a@,@,OUTPUT@,@,%a@,@,FILTERED OUTPUT@,@,%a@,@]" - print_list + "@[ANOMALIES@,\ + @,\ + %a@,\ + @,\ + REFERENCE@,\ + @,\ + %a@,\ + @,\ + OUTPUT@,\ + @,\ + %a@,\ + @,\ + FILTERED OUTPUT@,\ + @,\ + %a@,\ + @]" + print_errors errors print_list (List.sort compare_rev_code ref_list) print_list (List.sort compare_rev_code tax_result) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index f561de4e0..8914085d1 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -169,6 +169,42 @@ let generate_var_def (variable : Bir.variable) (vdata : Bir.variable_data) tgv_expression | InputVar -> assert false +let generate_verif (oc : Format.formatter) (condition_data : Bir.condition_data) + = + let open Strings in + let _cond_expr = condition_data.cond_expr 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 = 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\";@,\ + major_code = \"%s\";@,\ + minor_code = \"%s\";@,\ + description = \"%s\";@,\ + alias = \"%s\"} :: context.errors@,\ + @]))" + error_name error_kind error_major_code error_minor_code error_description + error_alias + 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 @@ -199,7 +235,7 @@ and generate_stmt (program : Bir.program) (oc : Format.formatter) | { undefined = false ; value = 0.0 }-> (@[%a@])@,\ | _ -> (@[%a@]))@]" cond_name s cond_name (generate_stmts program) ff (generate_stmts program) tt - | SVerif _condition_data -> Format.fprintf oc "%s" "Verif" + | SVerif condition_data -> generate_verif oc condition_data | SRuleCall rule_id -> let rule = Mir.RuleMap.find rule_id program.rules in Format.fprintf oc "m_rule_%s context" rule.rule_name @@ -209,14 +245,17 @@ and generate_stmt (program : Bir.program) (oc : Format.formatter) 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 - "@[let mpp_func_%s (context : m_context) : unit =@,%a@]" f_name - (generate_stmts program) mppf_stmts + 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 = @@ -224,9 +263,12 @@ let generate_mpp_functions (oc : Format.formatter) (program : Bir.program) = (Bir_interface.context_agnostic_mpp_functions program) in let function_names, _ = List.split functions in - Format.pp_print_list ~pp_sep:pp_function_separator - (generate_mpp_function program) - oc function_names + 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_rule_method (program : Bir.program) (oc : Format.formatter) (rule : Bir.rule) = @@ -300,13 +342,15 @@ let generate_input_handler (oc : Format.formatter) 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_list =@,\ + "let calculate_tax entry_list : (output_list * (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 context : m_context = {tgv; local_variables} in@,\ + let errors = [] in@,\ + let context : m_context = {tgv; local_variables; errors} in@,\ input_handler tgv entry_list;@,\ %a;@,\ - output tgv" var_table_size locals_size (generate_stmts program) + (output tgv, context.errors)" var_table_size locals_size + (generate_stmts program) (Bir.main_statements program) let generate_ocaml_program (program : Bir.program) From 5fdb8f51382ef51ce41d238eef7416f4bb5a0534 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 24 Jun 2022 15:25:31 +0200 Subject: [PATCH 35/55] Refactor Makefile: allow to disable m_spec file usage, to select .m_spec file, .mpp file and main MPP function, to run test suite with bytecode and native code. --- examples/ocaml/Makefile | 74 +++++++++++++++++++++++++++------- examples/ocaml/test_harness.ml | 4 +- 2 files changed, 61 insertions(+), 17 deletions(-) diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile index add9fa92a..7f535c829 100644 --- a/examples/ocaml/Makefile +++ b/examples/ocaml/Makefile @@ -1,36 +1,80 @@ 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=compute_double_liquidation_pvro + --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 + +.PHONY : clean cleangen cleancalc cleanstat cleantest cleanresult + +clean: cleancalc cleanstat cleanresult + +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/* + +################################################## +# Implicit rules for OCaml modules +################################################## + +%.cmo: %.ml + ocamlc.opt -c $(DEBUG_FLAG) $^ -clean: - rm -f ir_*.ml *.o *.cmi *.cmx ir_*.exe *.cmo *.bc *_disc.txt +%.cmx: %.ml + ocamlopt -c $(DEBUG_FLAG) $^ ################################################## # Generating and running OCaml files from Mlang ################################################## -.PRECIOUS: ir_%.ml -ir_%.ml: ../../m_specs/%.m_spec +# Generating OCaml files (MLang) +ir.ml: $(SPEC_DEP) $(MLANG) \ - --backend ocaml --output $@ \ - --function_spec $^ \ + --backend ocaml --output ir.ml \ $(SOURCE_FILES) -ir_%.exe: ir_%.ml - ocamlopt -o $@ mvalue.ml $^ +.INTERMEDIATE : test_harness.cmo test_harness.cmi test_harness.o test_harness.cmx +# Compiling bytecode +test.bc: mvalue.cmo ir.cmo test_harness.cmo + ocamlc.opt $(DEBUG_FLAG) -o $@ unix.cma $^ -ir_%.bc: ir_%.ml - ocamlc.opt -g -o $@ mvalue.ml $^ +# Compiling native code +test.exe: mvalue.cmx ir.cmx test_harness.cmx + ocamlopt $(DEBUG_FLAG) -o $@ unix.cmxa $^ -test_%: ir_%.ml - ocamlc.opt -g -o $@.bc unix.cma mvalue.ml $^ test_harness.ml +# Running test suite +run: test.bc + ./test.bc "multi" $(TESTS_DIR) "results/y$(YEAR)" -mvalue.bc: - ocamlc.opt -c mvalue.ml +runx: test.exe + ./test.exe "multi" $(TESTS_DIR) "results/y$(YEAR)" \ No newline at end of file diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index 86c6b212c..651296f05 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -100,7 +100,7 @@ let print_rev_code (oc : Format.formatter) (rev_code : Mvalue.revenue_code) : let compute_discrepancies_from_file_2020 (fip_file : string) : (Mvalue.revenue_code * Mvalue.revenue_code) list = - let tax_result, errors = Ir_tests_2020.calculate_tax (entry_list fip_file) in + let tax_result, errors = Ir.calculate_tax (entry_list fip_file) in let ref_list = reference_list fip_file 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 @@ -170,7 +170,7 @@ let compute_on_FIP_2020 (fip_file : string) (output_file_name : string) : unit = 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 *) - let tax_result, errors = Ir_tests_2020.calculate_tax (entry_list fip_file) in + let tax_result, errors = Ir.calculate_tax (entry_list fip_file) in let ref_list = reference_list fip_file in let print_list fmt code_list = Format.pp_print_list print_rev_code fmt code_list From 2f05d7d50a0768737aa6e2de0d4a3f1cbc9d484b Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 24 Jun 2022 16:11:25 +0200 Subject: [PATCH 36/55] Adjust OCaml backend to pull request #158 as M verifs are now processed like any other M rule. --- src/mlang/backend_compilers/bir_to_ocaml.ml | 38 +++++++++++++-------- 1 file changed, 24 insertions(+), 14 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 8914085d1..b525e0f3f 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -205,6 +205,11 @@ let generate_verif (oc : Format.formatter) (condition_data : Bir.condition_data) error_name error_kind error_major_code error_minor_code error_description error_alias +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 @@ -236,9 +241,9 @@ and generate_stmt (program : Bir.program) (oc : Format.formatter) | _ -> (@[%a@]))@]" cond_name s cond_name (generate_stmts program) ff (generate_stmts program) tt | SVerif condition_data -> generate_verif oc condition_data - | SRuleCall rule_id -> - let rule = Mir.RuleMap.find rule_id program.rules in - Format.fprintf oc "m_rule_%s context" rule.rule_name + | 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 @@ -270,18 +275,23 @@ let generate_mpp_functions (oc : Format.formatter) (program : Bir.program) = in Format.fprintf oc "let rec %a@," pp_print_mpp_functions function_names -let generate_rule_method (program : Bir.program) (oc : Format.formatter) - (rule : Bir.rule) = - Format.fprintf oc "@[let m_rule_%s (context : m_context) : unit =@,%a@]" - rule.rule_name (generate_stmts program) rule.rule_stmts +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_rule_methods (oc : Format.formatter) (program : Bir.program) : unit - = - let rules = Bir.RuleMap.bindings program.rules in - let _, rules = List.split rules in +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_rule_method program) - oc rules + (generate_rov_function program) + oc rovs let generate_header (oc : Format.formatter) () : unit = Format.fprintf oc "@[open Mvalue@,@]" @@ -360,7 +370,7 @@ let generate_ocaml_program (program : Bir.program) 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_rule_methods program generate_mpp_functions program + 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; From ccab1f6f8dfaabe867fe5028439d05ad0e359580 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 30 Jun 2022 15:26:57 +0200 Subject: [PATCH 37/55] M Errors of type Anomaly now abort computation raising an M Exception, with better display of M Errors. --- examples/ocaml/mvalue.ml | 2 ++ examples/ocaml/test_harness.ml | 35 +++++++++++++++------ src/mlang/backend_compilers/bir_to_ocaml.ml | 19 ++++++----- 3 files changed, 40 insertions(+), 16 deletions(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index e7415e870..a954f3199 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -11,6 +11,8 @@ type m_error = { alias : string; } +exception M_exn of m_error list + type m_context = { tgv : m_array; local_variables : m_array; diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index 651296f05..e5530119a 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -160,24 +160,42 @@ let test_FIP_2020 (fip_file : string) (output_file_name : string) : unit = close_out _oc let print_error oc (error : m_error) : unit = - Format.fprintf oc "Name: %s, kind: %s, description: %s" error.name error.kind - error.description + 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 _discrepancy_list = compute_discrepancies_from_file_2020 fip_file in *) - let tax_result, errors = Ir.calculate_tax (entry_list fip_file) in + let tax_result, errors = + try Ir.calculate_tax (entry_list fip_file) + 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 ref_list = reference_list fip_file in let print_list fmt code_list = Format.pp_print_list print_rev_code fmt code_list in - Format.printf "Test case: %s@." fip_file; Format.fprintf oc - "@[ANOMALIES@,\ + "@[TEST CASE: %s@,\ + @,\ + ANOMALIES@,\ @,\ %a@,\ @,\ @@ -191,9 +209,8 @@ let compute_on_FIP_2020 (fip_file : string) (output_file_name : string) : unit = @,\ FILTERED OUTPUT@,\ @,\ - %a@,\ - @]" - print_errors errors print_list + %a@]@." + fip_file print_errors errors print_list (List.sort compare_rev_code ref_list) print_list (List.sort compare_rev_code tax_result) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index b525e0f3f..54aa1a368 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -172,13 +172,18 @@ let generate_var_def (variable : Bir.variable) (vdata : Bir.variable_data) let generate_verif (oc : Format.formatter) (condition_data : Bir.condition_data) = let open Strings in - let _cond_expr = condition_data.cond_expr 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 = sanitize_str cond_error.Mir.Error.descr.kind 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 @@ -191,19 +196,19 @@ let generate_verif (oc : Format.formatter) (condition_data : Bir.condition_data) | None -> "" in Format.fprintf oc - "(match verif_cond with@,\ + "match verif_cond with@,\ | { undefined = true ; value = _ }@,\ | { undefined = false ; value = 0.0 } -> ()@,\ | _ -> (@[ context.errors <- {@,\ name = \"%s\";@,\ - kind = \"%s\";@,\ + kind = \"%s (%s)\";@,\ major_code = \"%s\";@,\ minor_code = \"%s\";@,\ description = \"%s\";@,\ alias = \"%s\"} :: context.errors@,\ - @]))" - error_name error_kind error_major_code error_minor_code error_description - error_alias + @])%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 = From e06888d3baa04e41c90ba081883ab279c4c18981 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 8 Sep 2022 15:23:06 +0200 Subject: [PATCH 38/55] Fix blank lines in the input map building --- src/mlang/backend_compilers/bir_to_ocaml.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 54aa1a368..c89398d68 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -252,6 +252,9 @@ and generate_stmt (program : Bir.program) (oc : Format.formatter) | 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 "@,@," @@ -334,18 +337,18 @@ let generate_input_handler (oc : Format.formatter) match get_position_and_alias variable with | Some (position, alias) -> Format.fprintf fmt - "let tgv_positions = TgvPositionMap.add \"%s\" %d tgv_positions in" + "let tgv_positions = TgvPositionMap.add \"%s\" %d tgv_positions in@," alias position | None -> () in let pp_print_position_map fmt input_vars = - Format.pp_print_list pp_print_line 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 tgv_positions = TgvPositionMap.empty in@,\ - %a@,\ + %a\ let init_tgv_var (entry_var : revenue_code) : unit =@,\ Array.set tgv @,\ (TgvPositionMap.find entry_var.alias tgv_positions)@,\ From 2a840bb07b19ff71b3707e68685f3946cd8edd42 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 8 Sep 2022 15:25:15 +0200 Subject: [PATCH 39/55] Ouput of main function is now an array, not a list. Fix multiple concatenation on this huge list. --- examples/ocaml/mvalue.ml | 2 +- examples/ocaml/test_harness.ml | 6 ++++-- src/mlang/backend_compilers/bir_to_ocaml.ml | 10 +++++----- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index a954f3199..40653e48e 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -25,7 +25,7 @@ module TgvPositionMap = Map.Make (String) type input_list = revenue_code list -type output_list = revenue_code list +type output_array = revenue_code array let m_undef : m_value = { undefined = true; value = 0.0 } diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index e5530119a..816d8ea1f 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -100,7 +100,8 @@ let print_rev_code (oc : Format.formatter) (rev_code : Mvalue.revenue_code) : let compute_discrepancies_from_file_2020 (fip_file : string) : (Mvalue.revenue_code * Mvalue.revenue_code) list = - let tax_result, errors = Ir.calculate_tax (entry_list fip_file) in + let tax_result_array, errors = Ir.calculate_tax (entry_list fip_file) in + let tax_result = Array.to_list tax_result_array in let ref_list = reference_list fip_file 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 @@ -180,7 +181,7 @@ 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 tax_result, errors = + let tax_result_array, errors = try Ir.calculate_tax (entry_list fip_file) with M_exn e_list -> Format.fprintf oc "TEST CASE %s ends with M Exception:@,@,%a@." fip_file @@ -188,6 +189,7 @@ let compute_on_FIP_2020 (fip_file : string) (output_file_name : string) : unit = close_out _oc; raise (M_exn e_list) in + let tax_result = Array.to_list tax_result_array in let ref_list = reference_list fip_file in let print_list fmt code_list = Format.pp_print_list print_rev_code fmt code_list diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index c89398d68..9e4a3960d 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -315,13 +315,13 @@ let generate_output (oc : Format.formatter) var_list in let print_line fmt (position, name) = - Format.fprintf fmt "{alias = \"%s\" ; value = (Array.get tgv %d).value} ::" + Format.fprintf fmt "{alias = \"%s\" ; value = (Array.get tgv %d).value}" name position in let pp_print_output_get fmt output_vars = - Format.pp_print_list print_line fmt (name_and_pos_list 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_list =@,%a []@," + Format.fprintf oc "let output (tgv : m_array) : output_array =[|@,%a|]@," pp_print_output_get output_vars let generate_input_handler (oc : Format.formatter) @@ -341,7 +341,7 @@ let generate_input_handler (oc : Format.formatter) alias position | None -> () in - let pp_print_position_map fmt input_vars = + 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 @@ -360,7 +360,7 @@ let generate_input_handler (oc : Format.formatter) 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_list * (m_error list)) =@,\ + "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@,\ From 4f3c39a7196989e67c08c74fd78e98172a5cec67 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Mon, 19 Sep 2022 16:38:43 +0200 Subject: [PATCH 40/55] Fix min, max & multimax having always defined result, following changes in other backends --- examples/ocaml/mvalue.ml | 16 +++++++++------- src/mlang/backend_compilers/bir_to_ocaml.ml | 11 +++++------ 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index 40653e48e..6a828c815 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -118,10 +118,12 @@ let m_table_value_at_index (variable_array : m_array) (table_start : int) | _ -> Array.get variable_array (offset + table_start) let m_max (x : m_value) (y : m_value) : m_value = - { undefined = false; value = max x.value y.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 = - { undefined = false; value = min x.value y.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 @@ -146,17 +148,17 @@ let m_multimax (bound_variable : m_value) (variable_array : m_array) if bound_variable.undefined then failwith "Multimax bound undefined!" else let bound = int_of_float bound_variable.value in - let get_position_value_or_zero position = - m_add (Array.get variable_array position) m_zero + let get_position_value position = + Array.get variable_array position in let rec multimax variable_array current_index max_index reference = let new_max = - m_max reference (get_position_value_or_zero current_index) + m_max reference (get_position_value current_index) in if current_index = max_index then new_max else multimax variable_array (current_index + 1) max_index new_max in if bound >= 1 then multimax variable_array (position + 1) (position + bound) - (get_position_value_or_zero position) - else get_position_value_or_zero position + (get_position_value position) + else get_position_value position diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 9e4a3960d..b1709a2df 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -252,8 +252,7 @@ and generate_stmt (program : Bir.program) (oc : Format.formatter) | 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_empty_separator (f : Format.formatter) () : unit = Format.fprintf f "" let pp_function_separator (f : Format.formatter) () : unit = Format.fprintf f "@,@," @@ -319,7 +318,8 @@ let generate_output (oc : Format.formatter) 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) + 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 =[|@,%a|]@," pp_print_output_get output_vars @@ -341,15 +341,14 @@ let generate_input_handler (oc : Format.formatter) alias position | None -> () in - let pp_print_position_map fmt input_vars = + 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 tgv_positions = TgvPositionMap.empty in@,\ - %a\ - let init_tgv_var (entry_var : revenue_code) : unit =@,\ + %alet init_tgv_var (entry_var : revenue_code) : unit =@,\ Array.set tgv @,\ (TgvPositionMap.find entry_var.alias tgv_positions)@,\ \ {undefined = false ; value = entry_var.value} in@,\ From 1f0e4a02787f1a29b3de1edfb0bb8eec9da99a33 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Wed, 21 Sep 2022 09:52:51 +0200 Subject: [PATCH 41/55] Adapt to Bir changes in PR #184 --- src/mlang/backend_compilers/bir_to_ocaml.ml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index b1709a2df..be596c8b2 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -270,10 +270,7 @@ let generate_mpp_function (program : Bir.program) (oc : Format.formatter) 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 - (Bir_interface.context_agnostic_mpp_functions program) - in + 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 From 48135ad6145f3f7358e5ecac363c8e1b4758b83b Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Wed, 21 Sep 2022 15:02:29 +0200 Subject: [PATCH 42/55] Fix stack overflow by building static input and output arrays of the variable position instead of computing values or map line by line --- src/mlang/backend_compilers/bir_to_ocaml.ml | 27 ++++++++++++--------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index be596c8b2..567ea88e1 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -311,14 +311,18 @@ let generate_output (oc : Format.formatter) var_list in let print_line fmt (position, name) = - Format.fprintf fmt "{alias = \"%s\" ; value = (Array.get tgv %d).value}" - name position + 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 =[|@,%a|]@," + 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) @@ -333,9 +337,7 @@ let generate_input_handler (oc : Format.formatter) let pp_print_line fmt variable : unit = match get_position_and_alias variable with | Some (position, alias) -> - Format.fprintf fmt - "let tgv_positions = TgvPositionMap.add \"%s\" %d tgv_positions in@," - alias position + Format.fprintf fmt "(\"%s\", %d);@," alias position | None -> () in let pp_print_position_map fmt input_vars = @@ -344,11 +346,14 @@ let generate_input_handler (oc : Format.formatter) Format.fprintf oc "let input_handler (tgv : m_array) (entry_list : revenue_code list) : unit \ =@,\ - let tgv_positions = TgvPositionMap.empty in@,\ - %alet init_tgv_var (entry_var : revenue_code) : unit =@,\ - Array.set tgv @,\ - (TgvPositionMap.find entry_var.alias tgv_positions)@,\ - \ {undefined = false ; value = entry_var.value} in@,\ + 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*) From d2a17079d51aeda5a16ea61349fbe12f2f0d8a3f Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Mon, 26 Sep 2022 13:58:24 +0200 Subject: [PATCH 43/55] Add a crude independant OCaml test file parser by cherry-picking relevant code from Mlang main and interpreter parsers --- examples/ocaml/parser/Makefile | 24 +++++++++ examples/ocaml/parser/fip.ml | 23 ++++++++ examples/ocaml/parser/test_lexer.mll | 69 ++++++++++++++++++++++++ examples/ocaml/parser/test_parser.mly | 75 +++++++++++++++++++++++++++ examples/ocaml/parser/types_module.ml | 35 +++++++++++++ 5 files changed, 226 insertions(+) create mode 100644 examples/ocaml/parser/Makefile create mode 100644 examples/ocaml/parser/fip.ml create mode 100644 examples/ocaml/parser/test_lexer.mll create mode 100644 examples/ocaml/parser/test_parser.mly create mode 100644 examples/ocaml/parser/types_module.ml diff --git a/examples/ocaml/parser/Makefile b/examples/ocaml/parser/Makefile new file mode 100644 index 000000000..11568430c --- /dev/null +++ b/examples/ocaml/parser/Makefile @@ -0,0 +1,24 @@ +clean: + rm -f *.cmo *.cmi test_lexer.ml test_parser.ml test_parser.mli + +# Compiling test file parser +types_module.cmo: + ocamlc.opt -c $(DEBUG_FLAG) types_module.ml + +test_parser.ml: types_module.cmo + 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_parser.cmo: test_parser.ml + ocamlc.opt -c $(DEBUG_FLAG) test_parser.mli test_parser.ml + +test_lexer.ml: test_parser.cmo + ocamllex test_lexer.mll + +test_lexer.cmo: test_lexer.ml + ocamlc.opt -c $(DEBUG_FLAG) test_lexer.ml + +fip.cmo: test_lexer.cmo test_parser.cmo + ocamlc.opt -c $(DEBUG_FLAG) fip.ml \ 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..c1a33aa25 --- /dev/null +++ b/examples/ocaml/parser/fip.ml @@ -0,0 +1,23 @@ +(*From test_interpreter.ml*) + +let parse_file (test_name : string) : Types_module.test_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.test_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 \ No newline at end of file diff --git a/examples/ocaml/parser/test_lexer.mll b/examples/ocaml/parser/test_lexer.mll new file mode 100644 index 000000000..2b0cbdda1 --- /dev/null +++ b/examples/ocaml/parser/test_lexer.mll @@ -0,0 +1,69 @@ +(* +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" + { ENTREESP } +| "#CONTROLES-PRIMITIF" + { CONTROLESP } +| "#RESULTATS-PRIMITIF" + { RESULTATSP } +| "#ENTREES-CORRECTIF" + { ENTREESC } +| "#CONTROLES-CORRECTIF" + { CONTROLESC } +| "#RESULTATS-CORRECTIF" + { RESULTATSC } +| "#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..42627e27c --- /dev/null +++ b/examples/ocaml/parser/test_parser.mly @@ -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 Types_module +%} + +%token SYMBOL NAME INTEGER FLOAT + +%token SLASH +%token NOM FIP +%token ENTREESP CONTROLESP RESULTATSP +%token ENTREESC CONTROLESC RESULTATSC +%token DATES AVISIR AVISCSG +%token ENDSHARP + +%token EOF + +%type test_file + +%start test_file + +%% + + + +test_file: +| NOM nom = name + fip? + ENTREESP + ep = list(variable_and_value) + CONTROLESP + cp = list(variable_and_value) + RESULTATSP + rp = list(variable_and_value) + corr = correctif? + DATES? + AVISIR? + AVISCSG? + ENDSHARP { { nom; ep; cp; rp; corr } } +| EOF { assert false } + +correctif: + ENTREESC + ec = list(variable_and_value) + CONTROLESC + cc = list(variable_and_value) + RESULTATSC + rc = list(variable_and_value) { (ec, cc, rc) } + + +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) } diff --git a/examples/ocaml/parser/types_module.ml b/examples/ocaml/parser/types_module.ml new file mode 100644 index 000000000..1994f8089 --- /dev/null +++ b/examples/ocaml/parser/types_module.ml @@ -0,0 +1,35 @@ +(*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 test_file = { + nom : string; + ep : var_values; + cp : var_values; + rp : var_values; + corr : (var_values * var_values * 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 From e4845d8539c29d9e53550998aea554bbeb00af80 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Mon, 26 Sep 2022 14:05:08 +0200 Subject: [PATCH 44/55] Plug the new parser in place of the old ad hoc file loading with pattern matching --- examples/ocaml/Makefile | 20 +++++++++++++++++--- examples/ocaml/test_harness.ml | 19 +++++++++++++++---- 2 files changed, 32 insertions(+), 7 deletions(-) diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile index 7f535c829..1d8afc0f0 100644 --- a/examples/ocaml/Makefile +++ b/examples/ocaml/Makefile @@ -42,6 +42,8 @@ cleanstat: cleantest rm -f mvalue.cmi mvalue.cmx mvalue.o mvalue.cmo cleanresult: rm -f results/* +cleanparser: + $(MAKE) -C parser/ clean ################################################## # Implicit rules for OCaml modules @@ -63,13 +65,25 @@ ir.ml: $(SPEC_DEP) --backend ocaml --output ir.ml \ $(SOURCE_FILES) +test_harness.cmo : test_harness.ml + ocamlc.opt -c $(DEBUG_FLAG) -I parser $^ + .INTERMEDIATE : test_harness.cmo test_harness.cmi test_harness.o test_harness.cmx # Compiling bytecode -test.bc: mvalue.cmo ir.cmo test_harness.cmo - ocamlc.opt $(DEBUG_FLAG) -o $@ unix.cma $^ +types_module.cmo: + $(MAKE) -C parser/ types_module.cmo +test_lexer.cmo : + $(MAKE) -C parser/ test_lexer.cmo +test_parser.cmo : + $(MAKE) -C parser/ 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 $@ -I parser unix.cma $^ # Compiling native code -test.exe: mvalue.cmx ir.cmx test_harness.cmx +test.exe: parser/fip.cmx mvalue.cmx ir.cmx test_harness.cmx ocamlopt $(DEBUG_FLAG) -o $@ unix.cmxa $^ # Running test suite diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index 816d8ea1f..9be3e7084 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -4,6 +4,17 @@ 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.test_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.test_file) : Mvalue.revenue_code list = revenue_code_list_from_var_values fichier.ep + +let reference_list_parsed (fichier : Types_module.test_file) : Mvalue.revenue_code list = revenue_code_list_from_var_values fichier.rp + let load_file (input_file : string) : string list = let ic = open_in input_file in let rec build_list line_list = @@ -100,9 +111,9 @@ let print_rev_code (oc : Format.formatter) (rev_code : Mvalue.revenue_code) : let compute_discrepancies_from_file_2020 (fip_file : string) : (Mvalue.revenue_code * Mvalue.revenue_code) list = - let tax_result_array, errors = Ir.calculate_tax (entry_list fip_file) in + let tax_result_array, errors = Ir.calculate_tax (entry_list_parsed (fichier fip_file)) in let tax_result = Array.to_list tax_result_array in - let ref_list = reference_list fip_file in + let ref_list = reference_list_parsed (fichier fip_file) 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 = @@ -182,7 +193,7 @@ let compute_on_FIP_2020 (fip_file : string) (output_file_name : string) : unit = let _oc = open_out (output_file_name ^ "_disc.txt") in let oc = Format.formatter_of_out_channel _oc in let tax_result_array, errors = - try Ir.calculate_tax (entry_list fip_file) + try Ir.calculate_tax (entry_list_parsed (fichier fip_file)) with M_exn e_list -> Format.fprintf oc "TEST CASE %s ends with M Exception:@,@,%a@." fip_file print_errors e_list; @@ -190,7 +201,7 @@ let compute_on_FIP_2020 (fip_file : string) (output_file_name : string) : unit = raise (M_exn e_list) in let tax_result = Array.to_list tax_result_array in - let ref_list = reference_list fip_file in + let ref_list = reference_list_parsed (fichier fip_file) in let print_list fmt code_list = Format.pp_print_list print_rev_code fmt code_list in From 498da98912d6867a3fcab1bffdf9cdc33d03ce22 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 30 Sep 2022 10:12:51 +0200 Subject: [PATCH 45/55] Remove ad hoc function for test file loading witch pattern matching --- examples/ocaml/test_harness.ml | 59 ---------------------------------- 1 file changed, 59 deletions(-) diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index 9be3e7084..a9618d6af 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -15,20 +15,6 @@ let entry_list_parsed (fichier : Types_module.test_file) : Mvalue.revenue_code l let reference_list_parsed (fichier : Types_module.test_file) : Mvalue.revenue_code list = revenue_code_list_from_var_values fichier.rp -let load_file (input_file : string) : string list = - let ic = open_in input_file in - let rec build_list line_list = - match input_line ic with - | next_line -> build_list (next_line :: line_list) - | exception End_of_file -> - close_in ic; - List.rev line_list - | exception e -> - close_in_noerr ic; - raise e - in - build_list [] - let get_file_in_dir (dir_handle : Unix.dir_handle) : string list = let rec build_list file_list = match Unix.readdir dir_handle with @@ -45,51 +31,6 @@ let get_file_in_dir (dir_handle : Unix.dir_handle) : string list = let compare_rev_code code1 code2 : int = compare code1.alias code2.alias -let line2revenue_code line : Mvalue.revenue_code = - match String.split_on_char '/' line with - | [ head; tail ] -> { alias = head; value = Float.of_string tail } - | [] -> failwith "Empty line !" - | _ :: tail -> failwith "Line with multiple separators /." - -let parse_codes line_list : Mvalue.revenue_code list = - match line_list with [] -> [] | _ -> List.map line2revenue_code line_list - -let parse_block line_list : test_block = - match line_list with - | head :: tail when String.starts_with ~prefix:"#" head -> - { block_name = head; block_data = parse_codes tail } - | _ -> failwith "Data block has not the expected structure." - -let rec split_blocks (line_list : string list) - (line_list_list : string list list) : string list list = - match line_list with - | [] -> List.rev (List.map List.rev line_list_list) - | line :: tail -> - if String.starts_with ~prefix:"#" line then - split_blocks tail ([ [ line ] ] @ line_list_list) - else - split_blocks tail - (([ line ] @ List.hd line_list_list) :: List.tl line_list_list) - -let parse_FIP line_list : test_data = - match line_list with - | head :: name :: tail -> - { test_name = name; blocks = List.map parse_block (split_blocks tail []) } - | _ -> failwith "FIP file has not the expected structure." - -let get_data_block (input_file : string) (block_name : string) : - Mvalue.revenue_code list = - (List.find - (fun block -> block.block_name = block_name) - (parse_FIP (load_file input_file)).blocks) - .block_data - -let entry_list (input_file : string) : Mvalue.revenue_code list = - get_data_block input_file "#ENTREES-PRIMITIF" - -let reference_list (input_file : string) : Mvalue.revenue_code list = - get_data_block input_file "#RESULTATS-PRIMITIF" - 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 = From 8eb89d8b10b80381366e8fce71077d1f596f8d78 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 30 Sep 2022 10:46:39 +0200 Subject: [PATCH 46/55] Compatibility change for Ocaml compiler 4.11.2 --- examples/ocaml/test_harness.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index a9618d6af..7a1191457 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -175,7 +175,7 @@ let compute_on_FIP_2020 (fip_file : string) (output_file_name : string) : unit = let run_test_directory (directory : string) (output_file_name : string) : unit = let dir_handle = Unix.opendir directory in let file_list = - List.map (String.cat directory) (get_file_in_dir dir_handle) + List.map (fun (file_name) -> directory ^ file_name) (get_file_in_dir dir_handle) in let files_discrepancies_list = List.combine file_list From 894aa86378c0791d8317a470b709a17e3544f8e1 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 7 Oct 2022 15:01:26 +0200 Subject: [PATCH 47/55] Add a run_tests build command without file output for CI --- examples/ocaml/Makefile | 11 +++++++++-- examples/ocaml/test_harness.ml | 5 ++++- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile index 1d8afc0f0..da7aca023 100644 --- a/examples/ocaml/Makefile +++ b/examples/ocaml/Makefile @@ -88,7 +88,14 @@ test.exe: parser/fip.cmx mvalue.cmx ir.cmx test_harness.cmx # Running test suite run: test.bc - ./test.bc "multi" $(TESTS_DIR) "results/y$(YEAR)" + ./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)" \ No newline at end of file + ./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/test_harness.ml b/examples/ocaml/test_harness.ml index 7a1191457..8683c8782 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -181,7 +181,10 @@ let run_test_directory (directory : string) (output_file_name : string) : unit = List.combine file_list (List.map compute_discrepancies_from_file_2020 file_list) in - let _oc = open_out (output_file_name ^ "_disc.txt") 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 From 0cd326bd22130fd02bc7d08a34d2b85f8f639d25 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 7 Oct 2022 15:05:26 +0200 Subject: [PATCH 48/55] Refactor Makefiles for Ocaml backend and parser to improve readability and enable native code compilation --- examples/ocaml/Makefile | 38 +++++++------------ .../Makefile-generic-ocaml-rules.include | 12 ++++++ examples/ocaml/parser/Makefile | 23 +++++------ 3 files changed, 34 insertions(+), 39 deletions(-) create mode 100644 examples/ocaml/Makefile-generic-ocaml-rules.include diff --git a/examples/ocaml/Makefile b/examples/ocaml/Makefile index da7aca023..d85690da4 100644 --- a/examples/ocaml/Makefile +++ b/examples/ocaml/Makefile @@ -1,3 +1,4 @@ +include Makefile-generic-ocaml-rules.include include ../../Makefile.include ######## @@ -28,9 +29,12 @@ MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG) SPEC_DEP=$(MPP_FILE) endif -.PHONY : clean cleangen cleancalc cleanstat cleantest cleanresult +# Include parser lib directory to make its module available +OCAMLC_INCLUDE_LIST= -I parser -clean: cleancalc cleanstat cleanresult +.PHONY : clean cleangen cleancalc cleanstat cleantest cleanresult run_tests + +clean: cleancalc cleanstat cleanresult cleanparser cleangen: rm -f ir.ml @@ -45,16 +49,6 @@ cleanresult: cleanparser: $(MAKE) -C parser/ clean -################################################## -# Implicit rules for OCaml modules -################################################## - -%.cmo: %.ml - ocamlc.opt -c $(DEBUG_FLAG) $^ - -%.cmx: %.ml - ocamlopt -c $(DEBUG_FLAG) $^ - ################################################## # Generating and running OCaml files from Mlang ################################################## @@ -65,26 +59,20 @@ ir.ml: $(SPEC_DEP) --backend ocaml --output ir.ml \ $(SOURCE_FILES) -test_harness.cmo : test_harness.ml - ocamlc.opt -c $(DEBUG_FLAG) -I parser $^ - .INTERMEDIATE : test_harness.cmo test_harness.cmi test_harness.o test_harness.cmx # Compiling bytecode -types_module.cmo: - $(MAKE) -C parser/ types_module.cmo -test_lexer.cmo : - $(MAKE) -C parser/ test_lexer.cmo -test_parser.cmo : - $(MAKE) -C parser/ test_parser.cmo -fip.cmo : +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 $@ -I parser unix.cma $^ + ocamlc.opt $(DEBUG_FLAG) -o $@ $(OCAMLC_INCLUDE_LIST) unix.cma $^ # Compiling native code -test.exe: parser/fip.cmx mvalue.cmx ir.cmx test_harness.cmx - ocamlopt $(DEBUG_FLAG) -o $@ unix.cmxa $^ +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 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/parser/Makefile b/examples/ocaml/parser/Makefile index 11568430c..86e898616 100644 --- a/examples/ocaml/parser/Makefile +++ b/examples/ocaml/parser/Makefile @@ -1,24 +1,19 @@ +include ../Makefile-generic-ocaml-rules.include + clean: - rm -f *.cmo *.cmi test_lexer.ml test_parser.ml test_parser.mli + rm -f *.cmo *.cmi *.cmx *.o test_lexer.ml test_parser.ml test_parser.mli # Compiling test file parser -types_module.cmo: - ocamlc.opt -c $(DEBUG_FLAG) types_module.ml -test_parser.ml: types_module.cmo +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_parser.cmo: test_parser.ml - ocamlc.opt -c $(DEBUG_FLAG) test_parser.mli test_parser.ml - -test_lexer.ml: test_parser.cmo +test_lexer.ml: test_parser.cmi test_parser.cmo test_parser.cmx ocamllex test_lexer.mll - -test_lexer.cmo: test_lexer.ml - ocamlc.opt -c $(DEBUG_FLAG) test_lexer.ml - -fip.cmo: test_lexer.cmo test_parser.cmo - ocamlc.opt -c $(DEBUG_FLAG) fip.ml \ No newline at end of file + +fip.cmo: test_lexer.cmo + +fip.cmx: test_lexer.cmx \ No newline at end of file From 291a857d100af0690f5b00f0d471bf3200fa5594 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Fri, 7 Oct 2022 15:13:50 +0200 Subject: [PATCH 49/55] Enable Ocaml backend check in continuous integration --- .github/workflows/check_correctness.yml | 6 ++++++ Makefile | 6 +++++- 2 files changed, 11 insertions(+), 1 deletion(-) 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/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 From 9e4e70ba15ab15dc44ee7f7b73d55fbb1550b89b Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Wed, 12 Oct 2022 16:12:39 +0200 Subject: [PATCH 50/55] Fix guarding condition to avoid reading out of bound values in accessing M table variables --- examples/ocaml/mvalue.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index 6a828c815..028f7d01b 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -114,7 +114,7 @@ let m_table_value_at_index (variable_array : m_array) (table_start : int) let offset = int_of_float index.value in match offset with | x when x < 0 -> m_zero - | x when x > size -> m_undef + | x when x >= size -> m_undef | _ -> Array.get variable_array (offset + table_start) let m_max (x : m_value) (y : m_value) : m_value = From 04cbf67e4240e2f5a466ac8a422d67745ec3f9dd Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Wed, 12 Oct 2022 16:13:56 +0200 Subject: [PATCH 51/55] Refactor static OCaml multimax to use Array module function properly --- examples/ocaml/mvalue.ml | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index 028f7d01b..e3fa29747 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -148,17 +148,8 @@ let m_multimax (bound_variable : m_value) (variable_array : m_array) 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 - let rec multimax variable_array current_index max_index reference = - let new_max = - m_max reference (get_position_value current_index) - in - if current_index = max_index then new_max - else multimax variable_array (current_index + 1) max_index new_max - in - if bound >= 1 then - multimax variable_array (position + 1) (position + bound) - (get_position_value position) - else get_position_value position + Array.fold_left (m_max) (get_position_value position) sub_array \ No newline at end of file From bf10615f3e766c56862d5047c246813b231edfc3 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 30 Mar 2023 13:57:39 +0200 Subject: [PATCH 52/55] Add abs function to OCaml backend, following aa702f2a (rehabilitate abs function in backends, 2022-11-22) --- examples/ocaml/mvalue.ml | 4 ++++ src/mlang/backend_compilers/bir_to_ocaml.ml | 3 +++ 2 files changed, 7 insertions(+) diff --git a/examples/ocaml/mvalue.ml b/examples/ocaml/mvalue.ml index e3fa29747..29af005b3 100644 --- a/examples/ocaml/mvalue.ml +++ b/examples/ocaml/mvalue.ml @@ -141,6 +141,10 @@ 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) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 567ea88e1..720ec98e0 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -71,6 +71,9 @@ let rec generate_ocaml_expr (e : Bir.expression Pos.marked) : | 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 From d09444b4077dc0dd0fb3a9a0ea10195ef169cb7d Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Thu, 30 Mar 2023 14:00:24 +0200 Subject: [PATCH 53/55] Use the new access to variable definition from Bir, from PR #200 --- src/mlang/backend_compilers/bir_to_ocaml.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_ocaml.ml b/src/mlang/backend_compilers/bir_to_ocaml.ml index 720ec98e0..73324ab7b 100644 --- a/src/mlang/backend_compilers/bir_to_ocaml.ml +++ b/src/mlang/backend_compilers/bir_to_ocaml.ml @@ -143,7 +143,7 @@ let generate_local_defs (oc : Format.formatter) (Format.pp_print_list ~pp_sep:pp_statement_separator format_local_set) defs -let generate_var_def (variable : Bir.variable) (vdata : Bir.variable_data) +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 @@ -152,7 +152,7 @@ let generate_var_def (variable : Bir.variable) (vdata : Bir.variable_data) (format_tgv_set tgv_expression) position in - match vdata.var_definition with + 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 From cd23ed251d482fa0dee4587f929acc3f8c062a7a Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Wed, 5 Jul 2023 11:39:34 +0200 Subject: [PATCH 54/55] Refine an independent IRJ test files parser. Compatibility with both primary and corrective test files. --- examples/ocaml/parser/fip.ml | 23 ++++++-- examples/ocaml/parser/test_lexer.mll | 22 +++++--- examples/ocaml/parser/test_parser.mly | 78 +++++++++++++++++---------- examples/ocaml/parser/types_module.ml | 12 +++-- examples/ocaml/test_harness.ml | 17 +++--- 5 files changed, 101 insertions(+), 51 deletions(-) diff --git a/examples/ocaml/parser/fip.ml b/examples/ocaml/parser/fip.ml index c1a33aa25..c2706d11e 100644 --- a/examples/ocaml/parser/fip.ml +++ b/examples/ocaml/parser/fip.ml @@ -1,6 +1,8 @@ (*From test_interpreter.ml*) -let parse_file (test_name : string) : Types_module.test_file = +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 = @@ -10,7 +12,7 @@ let parse_file (test_name : string) : Types_module.test_file = } in let f = - try Test_parser.test_file Test_lexer.token filebuf with + try Test_parser.irj_file Test_lexer.token filebuf with | Types_module.StructuredError e -> close_in input; raise (Types_module.StructuredError e) @@ -18,6 +20,19 @@ let parse_file (test_name : string) : Types_module.test_file = close_in input; Types_module.raise_spanned_error "Test syntax error" (Types_module.mk_position (filebuf.lex_start_p, filebuf.lex_curr_p)) - in + in close_in input; - f \ No newline at end of file + 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 index 2b0cbdda1..a15507eef 100644 --- a/examples/ocaml/parser/test_lexer.mll +++ b/examples/ocaml/parser/test_lexer.mll @@ -36,23 +36,29 @@ rule token = parse | "#FIP" { FIP } | "#ENTREES-PRIMITIF" - { ENTREESP } + { ENTREESPRIM } | "#CONTROLES-PRIMITIF" - { CONTROLESP } + { CONTROLESPRIM } | "#RESULTATS-PRIMITIF" - { RESULTATSP } + { RESULTATSPRIM } | "#ENTREES-CORRECTIF" - { ENTREESC } + { ENTREESCORR } | "#CONTROLES-CORRECTIF" - { CONTROLESC } + { CONTROLESCORR } | "#RESULTATS-CORRECTIF" - { RESULTATSC } -| "#DATES" + { RESULTATSCORR } +| "#ENTREES-RAPPELS" + { ENTREESRAPP } +| "#CONTROLES-RAPPELS" + { CONTROLESRAPP } +| "#RESULTATS-RAPPELS" + { RESULTATSRAPP } +(*| "#DATES" { DATES } | "#AVIS_IR" { AVISIR } | "#AVIS_CSG" - { AVISCSG } + { AVISCSG }*) | "##" { ENDSHARP } | '-'? ['0' - '9']+ as i diff --git a/examples/ocaml/parser/test_parser.mly b/examples/ocaml/parser/test_parser.mly index 42627e27c..f451ea075 100644 --- a/examples/ocaml/parser/test_parser.mly +++ b/examples/ocaml/parser/test_parser.mly @@ -20,48 +20,51 @@ along with this program. If not, see . %} %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 ENTREESP CONTROLESP RESULTATSP -%token ENTREESC CONTROLESC RESULTATSC -%token DATES AVISIR AVISCSG +%token ENTREESPRIM CONTROLESPRIM RESULTATSPRIM +%token ENTREESCORR CONTROLESCORR RESULTATSCORR +%token ENTREESRAPP CONTROLESRAPP RESULTATSRAPP +/* %token DATES AVISIR AVISCSG*/ %token ENDSHARP %token EOF -%type test_file +%type irj_file -%start test_file +%start irj_file %% - - -test_file: +irj_file: | NOM nom = name fip? - ENTREESP - ep = list(variable_and_value) - CONTROLESP - cp = list(variable_and_value) - RESULTATSP - rp = list(variable_and_value) - corr = correctif? - DATES? - AVISIR? - AVISCSG? - ENDSHARP { { nom; ep; cp; rp; corr } } + prim = primitif + rapp = rappels + ENDSHARP { { nom; prim; rapp } } | EOF { assert false } -correctif: - ENTREESC - ec = list(variable_and_value) - CONTROLESC - cc = list(variable_and_value) - RESULTATSC - rc = list(variable_and_value) { (ec, cc, rc) } - +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 } @@ -73,3 +76,24 @@ fip: 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 index 1994f8089..7201cd666 100644 --- a/examples/ocaml/parser/types_module.ml +++ b/examples/ocaml/parser/types_module.ml @@ -14,12 +14,14 @@ type literal = I of int | F of float type var_values = (string * literal * t) list -type test_file = { +type errors = (string * t) list + +type rappels = (string * string * (string * literal * t) * string * string * string * string * string) list + +type irj_file = { nom : string; - ep : var_values; - cp : var_values; - rp : var_values; - corr : (var_values * var_values * var_values) option; + prim : (var_values * errors * var_values); + rapp : (rappels * errors * var_values) option; } (*For both lexer and parser, from m_frontend/parse_utils*) diff --git a/examples/ocaml/test_harness.ml b/examples/ocaml/test_harness.ml index 8683c8782..58ca46298 100644 --- a/examples/ocaml/test_harness.ml +++ b/examples/ocaml/test_harness.ml @@ -4,16 +4,17 @@ 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.test_file = Fip.parse_file input_file +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.test_file) : Mvalue.revenue_code list = revenue_code_list_from_var_values fichier.ep +(*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.test_file) : Mvalue.revenue_code list = revenue_code_list_from_var_values fichier.rp +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 = @@ -52,9 +53,10 @@ let print_rev_code (oc : Format.formatter) (rev_code : Mvalue.revenue_code) : let compute_discrepancies_from_file_2020 (fip_file : string) : (Mvalue.revenue_code * Mvalue.revenue_code) list = - let tax_result_array, errors = Ir.calculate_tax (entry_list_parsed (fichier fip_file)) in + 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 = reference_list_parsed (fichier fip_file) 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 = @@ -133,8 +135,9 @@ 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 (entry_list_parsed (fichier fip_file)) + 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; @@ -142,7 +145,7 @@ let compute_on_FIP_2020 (fip_file : string) (output_file_name : string) : unit = raise (M_exn e_list) in let tax_result = Array.to_list tax_result_array in - let ref_list = reference_list_parsed (fichier fip_file) 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 From ebfa4e3a9475405bc58124c474c1b8474dbf4804 Mon Sep 17 00:00:00 2001 From: Mathieu Durero Date: Tue, 7 Nov 2023 00:10:14 +0100 Subject: [PATCH 55/55] Add a future dune file for Ocaml backend. Commented as work on the parser need to be done before using it. --- examples/ocaml/dune | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 examples/ocaml/dune 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))