Skip to content

Commit 4051a4b

Browse files
StevendeoStevendeo
committed
Un peu de refacto
1 parent 5e3251c commit 4051a4b

9 files changed

Lines changed: 131 additions & 141 deletions

File tree

‎dune-project‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@
22

33
(name mlang)
44

5-
(version %%VERSION%%)
5+
(version 186-81-g4e56bab8-dirty)
66

77
(generate_opam_files true)
88

‎irj_checker.opam‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
# This file is generated by dune, edit dune-project instead
22
opam-version: "2.0"
3-
version: "186-15-ga4a1d1ff"
3+
version: "186-81-g4e56bab8-dirty"
44
synopsis: "IRJ test validation tool"
55
description:
66
"This standalone module performs a syntactic validation of the DGFiP IRJ test format"

‎mlang.opam‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
# This file is generated by dune, edit dune-project instead
22
opam-version: "2.0"
3-
version: "186-15-ga4a1d1ff"
3+
version: "186-81-g4e56bab8-dirty"
44
synopsis: "Compiler for DGFiP's M language"
55
description: """
66
The Direction Générale des Finances Publiques (DGFiP)

‎src/mlang/driver.ml‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -131,7 +131,6 @@ let parse () =
131131
m_program
132132

133133
let run_single_test m_program test =
134-
Mir_interpreter.repl_debug := true;
135134
Test_interpreter.check_one_test m_program test !Config.value_sort
136135
!Config.round_ops;
137136
Cli.result_print "Test passed!"

‎src/mlang/m_ir/mir_number.ml‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -75,14 +75,14 @@ end
7575
module type NumberInterface = sig
7676
include NumberInterfaceNoCompare
7777

78-
val compare : Com.comp_op -> t -> t -> bool
78+
val compare : ?epsilon:float -> Com.comp_op -> t -> t -> bool
7979
end
8080

8181
module MakeComparable (N : NumberInterfaceNoCompare) : NumberInterface = struct
8282
include N
8383

84-
let compare op i1 i2 =
85-
let epsilon = of_float !Config.comparison_error_margin in
84+
let compare ?(epsilon = !Config.comparison_error_margin) op i1 i2 =
85+
let epsilon = of_float epsilon in
8686
let open Com in
8787
match op with
8888
| Gt -> i1 >. i2 +. epsilon

‎src/mlang/m_ir/mir_number.mli‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -69,7 +69,7 @@ module type NumberInterface = sig
6969

7070
val is_zero : t -> bool
7171

72-
val compare : Com.comp_op -> t -> t -> bool
72+
val compare : ?epsilon:float -> Com.comp_op -> t -> t -> bool
7373
(** Returns the comparison between two numbers in the precision context
7474
of the current configuration. *)
7575
end

‎src/mlang/mir_interpreter/eval.ml‎

Lines changed: 110 additions & 120 deletions
Original file line numberDiff line numberDiff line change
@@ -21,10 +21,68 @@ exception Stop_instruction of Com.stop_kind
2121

2222
let exit_on_rte = ref true
2323

24-
let repl_debug = ref false
24+
let empty_ctx (p : Mir.program) : 'a ctx =
25+
let dummy_var = Com.Var.new_ref ~name:(Pos.without "") in
26+
let init_tmp_var _i = { var = dummy_var; value = Undefined } in
27+
let init_ref _i =
28+
{
29+
var = dummy_var;
30+
var_space = p.program_var_space_def;
31+
ref_var = dummy_var;
32+
org = -1;
33+
}
34+
in
35+
let ctx_tab_map =
36+
let init i = IntMap.find i p.program_stats.table_map in
37+
Array.init (IntMap.cardinal p.program_stats.table_map) init
38+
in
39+
let ctx_var_spaces =
40+
let init i =
41+
let vsd = IntMap.find i p.program_var_spaces_idx in
42+
let input =
43+
if Com.CatVar.LocMap.mem Com.CatVar.LocInput vsd.vs_cats then
44+
Array.make p.program_stats.sz_input Undefined
45+
else Array.make 0 Undefined
46+
in
47+
let computed =
48+
if Com.CatVar.LocMap.mem Com.CatVar.LocComputed vsd.vs_cats then
49+
Array.make p.program_stats.sz_computed Undefined
50+
else Array.make 0 Undefined
51+
in
52+
let base =
53+
if Com.CatVar.LocMap.mem Com.CatVar.LocBase vsd.vs_cats then
54+
Array.make p.program_stats.sz_base Undefined
55+
else Array.make 0 Undefined
56+
in
57+
{ input; computed; base }
58+
in
59+
Array.init (IntMap.cardinal p.program_var_spaces_idx) init
60+
in
61+
{
62+
ctx_prog = p;
63+
ctx_target = snd (StrMap.min_binding p.program_targets);
64+
ctx_var_space = p.program_var_space_def.vs_id;
65+
ctx_var_spaces;
66+
ctx_tmps = Array.init p.program_stats.sz_all_tmps init_tmp_var;
67+
ctx_tmps_org = 0;
68+
ctx_ref = Array.init p.program_stats.nb_all_refs init_ref;
69+
ctx_ref_org = 0;
70+
ctx_tab_map;
71+
ctx_pr_out = { indent = 0; is_newline = true };
72+
ctx_pr_err = { indent = 0; is_newline = true };
73+
ctx_anos = [];
74+
ctx_nb_anos = 0;
75+
ctx_nb_discos = 0;
76+
ctx_nb_infos = 0;
77+
ctx_nb_bloquantes = 0;
78+
ctx_archived_anos = StrSet.empty;
79+
ctx_finalized_anos = [];
80+
ctx_exported_anos = [];
81+
ctx_events = [];
82+
}
2583

2684
module Make (N : Mir_number.NumberInterface) (RF : Mir_roundops.RoundOpsFunctor) :
27-
S = struct
85+
S with type custom_float = N.t = struct
2886
(* Careful : this behavior mimics the one imposed by the original Mlang
2987
compiler... *)
3088

@@ -34,16 +92,9 @@ module Make (N : Mir_number.NumberInterface) (RF : Mir_roundops.RoundOpsFunctor)
3492

3593
type nonrec value = custom_float value
3694

37-
type nonrec ctx_tmp_var = custom_float ctx_tmp_var
38-
3995
type nonrec ctx = custom_float ctx
4096

41-
type pctx = {
42-
std : Com.print_std;
43-
ctx : ctx;
44-
std_fmt : Format.formatter;
45-
ctx_pr : print_ctx;
46-
}
97+
type nonrec pctx = custom_float pctx
4798

4899
exception RuntimeError of run_error * ctx
49100

@@ -66,66 +117,6 @@ module Make (N : Mir_number.NumberInterface) (RF : Mir_roundops.RoundOpsFunctor)
66117
| Undefined -> Com.format_literal fmt Com.Undefined
67118
| Number x -> N.format_prec_t mi ma fmt x
68119

69-
let empty_ctx (p : Mir.program) : ctx =
70-
let dummy_var = Com.Var.new_ref ~name:(Pos.without "") in
71-
let init_tmp_var _i = { var = dummy_var; value = Undefined } in
72-
let init_ref _i =
73-
{
74-
var = dummy_var;
75-
var_space = p.program_var_space_def;
76-
ref_var = dummy_var;
77-
org = -1;
78-
}
79-
in
80-
let ctx_tab_map =
81-
let init i = IntMap.find i p.program_stats.table_map in
82-
Array.init (IntMap.cardinal p.program_stats.table_map) init
83-
in
84-
let ctx_var_spaces =
85-
let init i =
86-
let vsd = IntMap.find i p.program_var_spaces_idx in
87-
let input =
88-
if Com.CatVar.LocMap.mem Com.CatVar.LocInput vsd.vs_cats then
89-
Array.make p.program_stats.sz_input Undefined
90-
else Array.make 0 Undefined
91-
in
92-
let computed =
93-
if Com.CatVar.LocMap.mem Com.CatVar.LocComputed vsd.vs_cats then
94-
Array.make p.program_stats.sz_computed Undefined
95-
else Array.make 0 Undefined
96-
in
97-
let base =
98-
if Com.CatVar.LocMap.mem Com.CatVar.LocBase vsd.vs_cats then
99-
Array.make p.program_stats.sz_base Undefined
100-
else Array.make 0 Undefined
101-
in
102-
{ input; computed; base }
103-
in
104-
Array.init (IntMap.cardinal p.program_var_spaces_idx) init
105-
in
106-
{
107-
ctx_prog = p;
108-
ctx_target = snd (StrMap.min_binding p.program_targets);
109-
ctx_var_space = p.program_var_space_def.vs_id;
110-
ctx_var_spaces;
111-
ctx_tmps = Array.init p.program_stats.sz_all_tmps init_tmp_var;
112-
ctx_tmps_org = 0;
113-
ctx_ref = Array.init p.program_stats.nb_all_refs init_ref;
114-
ctx_ref_org = 0;
115-
ctx_tab_map;
116-
ctx_pr_out = { indent = 0; is_newline = true };
117-
ctx_pr_err = { indent = 0; is_newline = true };
118-
ctx_anos = [];
119-
ctx_nb_anos = 0;
120-
ctx_nb_discos = 0;
121-
ctx_nb_infos = 0;
122-
ctx_nb_bloquantes = 0;
123-
ctx_archived_anos = StrSet.empty;
124-
ctx_finalized_anos = [];
125-
ctx_exported_anos = [];
126-
ctx_events = [];
127-
}
128-
129120
let literal_to_value (l : Com.literal) : value =
130121
match l with
131122
| Com.Undefined -> Undefined
@@ -306,6 +297,45 @@ module Make (N : Mir_number.NumberInterface) (RF : Mir_roundops.RoundOpsFunctor)
306297
| Number n -> N.compare Eq n (N.one ()))
307298
| None -> false
308299

300+
let comparison op new_e1 new_e2 =
301+
match (op, new_e1, new_e2) with
302+
| Com.(Gt | Gte | Lt | Lte | Eq | Neq), _, Undefined
303+
| Com.(Gt | Gte | Lt | Lte | Eq | Neq), Undefined, _ ->
304+
Undefined
305+
| op, Number i1, Number i2 -> Number (real_of_bool @@ N.compare op i1 i2)
306+
307+
let unop op new_e1 =
308+
match (op, new_e1) with
309+
| Com.Not, Number b1 -> Number (real_of_bool (not (bool_of_real b1)))
310+
| Minus, Number f1 -> Number N.(zero () -. f1)
311+
| (Not | Minus), Undefined -> Undefined
312+
313+
let binop (op : Com.binop) new_e1 new_e2 =
314+
match (op, new_e1, new_e2) with
315+
| Add, Number i1, Number i2 -> Number N.(i1 +. i2)
316+
| Add, Number i1, Undefined -> Number N.(i1 +. zero ())
317+
| Add, Undefined, Number i2 -> Number N.(zero () +. i2)
318+
| Add, Undefined, Undefined -> Undefined
319+
| Sub, Number i1, Number i2 -> Number N.(i1 -. i2)
320+
| Sub, Number i1, Undefined -> Number N.(i1 -. zero ())
321+
| Sub, Undefined, Number i2 -> Number N.(zero () -. i2)
322+
| Sub, Undefined, Undefined -> Undefined
323+
| Mul, _, Undefined | Mul, Undefined, _ -> Undefined
324+
| Mul, Number i1, Number i2 -> Number N.(i1 *. i2)
325+
| Div, Undefined, _ | Div, _, Undefined -> Undefined
326+
| Div, _, l2 when is_zero l2 -> Number (N.zero ()) (* yes... *)
327+
| Div, Number i1, Number i2 -> Number N.(i1 /. i2)
328+
| Mod, Undefined, _ | Mod, _, Undefined -> Undefined
329+
| Mod, _, l2 when is_zero l2 -> Number (N.zero ()) (* yes... *)
330+
| Mod, Number i1, Number i2 -> Number N.(i1 %. i2)
331+
| And, Undefined, _ | And, _, Undefined -> Undefined
332+
| Or, Undefined, Undefined -> Undefined
333+
| Or, Undefined, Number i | Or, Number i, Undefined -> Number i
334+
| And, Number i1, Number i2 ->
335+
Number (real_of_bool (bool_of_real i1 && bool_of_real i2))
336+
| Or, Number i1, Number i2 ->
337+
Number (real_of_bool (bool_of_real i1 || bool_of_real i2))
338+
309339
exception BlockingError
310340

311341
let rec get_access_value ctx access =
@@ -494,46 +524,6 @@ module Make (N : Mir_number.NumberInterface) (RF : Mir_roundops.RoundOpsFunctor)
494524
(* interpret *)
495525

496526
and evaluate_expr (ctx : ctx) (e : Mir.expression Pos.marked) : value =
497-
let comparison op new_e1 new_e2 =
498-
match (op, new_e1, new_e2) with
499-
| Com.(Gt | Gte | Lt | Lte | Eq | Neq), _, Undefined
500-
| Com.(Gt | Gte | Lt | Lte | Eq | Neq), Undefined, _ ->
501-
Undefined
502-
| op, Number i1, Number i2 -> Number (real_of_bool @@ N.compare op i1 i2)
503-
in
504-
let unop op new_e1 =
505-
match (op, new_e1) with
506-
| Com.Not, Number b1 -> Number (real_of_bool (not (bool_of_real b1)))
507-
| Com.Minus, Number f1 -> Number N.(zero () -. f1)
508-
| Com.(Not | Minus), Undefined -> Undefined
509-
in
510-
let binop op new_e1 new_e2 =
511-
let open Com in
512-
match (op, new_e1, new_e2) with
513-
| Add, Number i1, Number i2 -> Number N.(i1 +. i2)
514-
| Add, Number i1, Undefined -> Number N.(i1 +. zero ())
515-
| Add, Undefined, Number i2 -> Number N.(zero () +. i2)
516-
| Add, Undefined, Undefined -> Undefined
517-
| Sub, Number i1, Number i2 -> Number N.(i1 -. i2)
518-
| Sub, Number i1, Undefined -> Number N.(i1 -. zero ())
519-
| Sub, Undefined, Number i2 -> Number N.(zero () -. i2)
520-
| Sub, Undefined, Undefined -> Undefined
521-
| Mul, _, Undefined | Mul, Undefined, _ -> Undefined
522-
| Mul, Number i1, Number i2 -> Number N.(i1 *. i2)
523-
| Div, Undefined, _ | Div, _, Undefined -> Undefined (* yes... *)
524-
| Div, _, l2 when is_zero l2 -> Number (N.zero ())
525-
| Div, Number i1, Number i2 -> Number N.(i1 /. i2)
526-
| Mod, Undefined, _ | Mod, _, Undefined -> Undefined (* yes... *)
527-
| Mod, _, l2 when is_zero l2 -> Number (N.zero ())
528-
| Mod, Number i1, Number i2 -> Number N.(i1 %. i2)
529-
| And, Undefined, _ | And, _, Undefined -> Undefined
530-
| Or, Undefined, Undefined -> Undefined
531-
| Or, Undefined, Number i | Or, Number i, Undefined -> Number i
532-
| And, Number i1, Number i2 ->
533-
Number (real_of_bool (bool_of_real i1 && bool_of_real i2))
534-
| Or, Number i1, Number i2 ->
535-
Number (real_of_bool (bool_of_real i1 || bool_of_real i2))
536-
in
537527
let out =
538528
try
539529
match Pos.unmark e with
@@ -1297,13 +1287,13 @@ let prepare_interp (sort : Config.value_sort) (roundops : Config.round_ops) :
12971287
MainframeLongSize.max_long := max_long
12981288
| _ -> ()
12991289

1300-
let evaluate_program (p : Mir.program) (inputs : Com.literal Com.Var.Map.t)
1301-
(events : (Com.literal, Com.Var.t) Com.event_value StrMap.t list)
1302-
(sort : Config.value_sort) (roundops : Config.round_ops) :
1290+
let evaluate_program ~(p : Mir.program) ~(inputs : Com.literal Com.Var.Map.t)
1291+
~(events : (Com.literal, Com.Var.t) Com.event_value StrMap.t list)
1292+
~(sort : Config.value_sort) ~(round_ops : Config.round_ops) :
13031293
Com.literal Com.Var.Map.t * Com.Error.Set.t =
1304-
prepare_interp sort roundops;
1305-
let module Interp = (val get_interp sort roundops : S) in
1306-
let ctx = Interp.empty_ctx p in
1294+
prepare_interp sort round_ops;
1295+
let module Interp = (val get_interp sort round_ops : S) in
1296+
let ctx = empty_ctx p in
13071297
Interp.evaluate_program ~inputs ~events ctx;
13081298
Format.pp_print_flush Format.std_formatter ();
13091299
Format.pp_print_flush Format.err_formatter ();
@@ -1331,8 +1321,8 @@ let evaluate_program (p : Mir.program) (inputs : Com.literal Com.Var.Map.t)
13311321
in
13321322
(varMap, anoSet)
13331323

1334-
let evaluate_expr (p : Mir.program) (e : Mir.expression Pos.marked)
1335-
(sort : Config.value_sort) (roundops : Config.round_ops) : Com.literal =
1336-
let module Interp = (val get_interp sort roundops : S) in
1337-
try Interp.value_to_literal (Interp.evaluate_expr (Interp.empty_ctx p) e)
1324+
let evaluate_expr ~(p : Mir.program) ~(e : Mir.expression Pos.marked)
1325+
~(sort : Config.value_sort) ~(round_ops : Config.round_ops) : Com.literal =
1326+
let module Interp = (val get_interp sort round_ops : S) in
1327+
try Interp.value_to_literal (Interp.evaluate_expr (empty_ctx p) e)
13381328
with Stop_instruction _ -> Undefined

‎src/mlang/mir_interpreter/types.ml‎

Lines changed: 12 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@
22

33
module Com = M_ir.Com
44

5-
(** A type of values *)
5+
(** The type values used in the interpreter. *)
66
type 'f value = Number of 'f | Undefined
77

88
type 'f ctx_tmp_var = { mutable var : Com.Var.t; mutable value : 'f value }
@@ -47,6 +47,13 @@ type 'f ctx = {
4747
('f value, Com.Var.t) Com.event_value Array.t Array.t list;
4848
}
4949

50+
type 'f pctx = {
51+
std : Com.print_std;
52+
ctx : 'f ctx;
53+
std_fmt : Format.formatter;
54+
ctx_pr : print_ctx;
55+
}
56+
5057
type run_error =
5158
| NanOrInf of string * M_ir.Mir.expression Pos.marked
5259
| StructuredError of
@@ -55,18 +62,12 @@ type run_error =
5562
module type S = sig
5663
type custom_float
5764

58-
type nonrec value = custom_float value
59-
60-
type nonrec ctx_tmp_var = custom_float ctx_tmp_var
61-
6265
type nonrec ctx = custom_float ctx
6366

6467
exception RuntimeError of run_error * ctx
6568

66-
val empty_ctx : M_ir.Mir.program -> ctx
67-
(** Builds an evaluation context from a given program. *)
68-
69-
val evaluate_expr : ctx -> M_ir.Mir.expression Pos.marked -> value
69+
val evaluate_expr :
70+
ctx -> M_ir.Mir.expression Pos.marked -> custom_float value
7071
(** Evaluates an expression. *)
7172

7273
val evaluate_program :
@@ -78,7 +79,7 @@ module type S = sig
7879
is required before calling this function (through [update_ctx_with_inputs]
7980
and [update_ctx_with_events]. *)
8081

81-
val literal_to_value : Com.literal -> value
82+
val literal_to_value : Com.literal -> custom_float value
8283

83-
val value_to_literal : value -> Com.literal
84+
val value_to_literal : custom_float value -> Com.literal
8485
end

0 commit comments

Comments
 (0)