OCaml backend

.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
+
+
 
 
 

.gitignore

@@ -6,3 +6,5 @@ doc.html
 *~
 /_opam
 /Makefile.config
+/.vscode
+examples/ocaml/**/.merlin

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
 

examples/ocaml/Makefile

@@ -0,0 +1,89 @@
+include Makefile-generic-ocaml-rules.include
+include ../../Makefile.include
+
+########
+# USAGE: specifiying parameters of the generated "calculette"
+########
+# Specifying a mpp file and its main function:
+# make ir.ml MPP_FILE=../../mpp_specs/dgfip_base.mpp MPP_FUNCTION=verif_calcul_primitive_raw
+# Using the default m_spec file:
+# make ir.ml TAKE_MSPEC=true
+
+MLANG_BIN=dune exec --no-print-director ../../src/main.exe --
+MPP_FUNCTION=compute_double_liquidation_pvro
+M_SPEC_FILE=$(SELF_DIR)/m_specs/tests_$(YEAR).m_spec
+
+MLANG_DEFAULT_OPTS=\
+	--display_time --debug \
+	--mpp_file=$(MPP_FILE) \
+	--mpp_function=$(MPP_FUNCTION)
+
+MLANG_MSPEC=\
+	--function_spec=$(M_SPEC_FILE)
+
+ifdef TAKE_MSPEC
+MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG) $(MLANG_MSPEC)
+SPEC_DEP=$(MPP_FILE) $(M_SPEC_FILE)
+else
+MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(OPTIMIZE_FLAG)
+SPEC_DEP=$(MPP_FILE)
+endif
+
+# Include parser lib directory to make its module available
+OCAMLC_INCLUDE_LIST= -I parser
+
+.PHONY : clean cleangen cleancalc cleanstat cleantest cleanresult run_tests
+
+clean: cleancalc cleanstat cleanresult cleanparser
+
+cleangen:
+	rm -f ir.ml
+cleancalc: cleangen
+	rm -f ir.cmi ir.cmx ir.o ir.cmo ir.exe ir.bc
+cleantest:
+	rm -f test_harness.cmi test_harness.cmx test_harness.o test_harness.cmo test.exe test.bc
+cleanstat: cleantest
+	rm -f mvalue.cmi mvalue.cmx mvalue.o mvalue.cmo
+cleanresult:
+	rm -f results/*
+cleanparser:
+	$(MAKE) -C parser/ clean
+
+##################################################
+# Generating and running OCaml files from Mlang
+##################################################
+
+# Generating OCaml files (MLang)
+ir.ml: $(SPEC_DEP)
+	$(MLANG) \
+		--backend ocaml --output ir.ml \
+		$(SOURCE_FILES)
+
+.INTERMEDIATE : test_harness.cmo test_harness.cmi test_harness.o test_harness.cmx
+# Compiling bytecode
+types_module.cmo test_lexer.cmo test_parser.cmo fip.cmo:
+	$(MAKE) -C parser/ fip.cmo
+
+test.bc: types_module.cmo test_lexer.cmo test_parser.cmo fip.cmo mvalue.cmo ir.cmo test_harness.cmo
+	ocamlc.opt $(DEBUG_FLAG) -o $@ $(OCAMLC_INCLUDE_LIST) unix.cma $^
+
+# Compiling native code
+types_module.cmx test_lexer.cmx test_parser.cmx fip.cmx:
+	$(MAKE) -C parser/ fip.cmx
+
+test.exe: types_module.cmx test_lexer.cmx test_parser.cmx fip.cmx mvalue.cmx ir.cmx test_harness.cmx
+	ocamlopt $(DEBUG_FLAG) -o $@ $(OCAMLC_INCLUDE_LIST) unix.cmxa $^
+
+# Running test suite
+run: test.bc
+	./test.bc "multi" $(TESTS_DIR) "results/y_$(YEAR)"
+
+runfile: test.bc
+	./test.bc "raw" $(FILE) "results/f_$(notdir $(FILE))"
+
+runx: test.exe
+	./test.exe "multi" $(TESTS_DIR) "results/y_$(YEAR)"
+
+# run_tests uses an empty string to disable the file output (output is enabled on stdout).
+run_tests: test.exe
+	./test.exe "multi" $(TESTS_DIR) ""

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) $^

examples/ocaml/dune

@@ -0,0 +1,3 @@
+;(executable
+; (name test_harness)
+; (libraries mlang))

examples/ocaml/mvalue.ml

@@ -0,0 +1,159 @@
+type m_value = { undefined : bool; value : float }
+
+type m_array = m_value array
+
+type m_error = {
+  name : string;
+  kind : string;
+  major_code : string;
+  minor_code : string;
+  description : string;
+  alias : string;
+}
+
+exception M_exn of m_error list
+
+type m_context = {
+  tgv : m_array;
+  local_variables : m_array;
+  mutable errors : m_error list;
+}
+
+type revenue_code = { alias : string; value : float }
+
+module TgvPositionMap = Map.Make (String)
+
+type input_list = revenue_code list
+
+type output_array = revenue_code array
+
+let m_undef : m_value = { undefined = true; value = 0.0 }
+
+let m_zero : m_value = { undefined = false; value = 0.0 }
+
+let m_one : m_value = { undefined = false; value = 1.0 }
+
+let m_add (x : m_value) (y : m_value) : m_value =
+  if x.undefined && y.undefined then m_undef
+  else { undefined = false; value = x.value +. y.value }
+
+let m_multiply (x : m_value) (y : m_value) : m_value =
+  if x.undefined || y.undefined then m_undef
+  else { undefined = false; value = x.value *. y.value }
+
+let m_subtract (x : m_value) (y : m_value) : m_value =
+  if x.undefined && y.undefined then m_undef
+  else { undefined = false; value = x.value -. y.value }
+
+let m_divide (x : m_value) (y : m_value) : m_value =
+  if x.undefined || y.undefined then m_undef
+  else
+    {
+      undefined = false;
+      value = (if y.value = 0.0 then 0.0 else x.value /. y.value);
+    }
+
+let m_and (x : m_value) (y : m_value) : m_value =
+  if x.undefined || y.undefined then m_undef
+  else if x.value <> 0.0 && y.value <> 0.0 then m_one
+  else m_zero
+
+let m_or (x : m_value) (y : m_value) : m_value =
+  if x.undefined && y.undefined then m_undef
+  else if x.value <> 0.0 || y.value <> 0.0 then m_one
+  else m_zero
+
+let m_cond (condition : m_value) (true_value : m_value) (false_value : m_value)
+    : m_value =
+  match condition with
+  | { undefined = true; value = _ } -> m_undef
+  | { undefined = false; value = 0.0 } -> false_value
+  | { undefined = false; value = _ } -> true_value
+
+let m_greater_than (x : m_value) (y : m_value) : m_value =
+  if x.undefined || y.undefined then m_undef
+  else if x.value > y.value then m_one
+  else m_zero
+
+let m_greater_than_equal (x : m_value) (y : m_value) : m_value =
+  if x.undefined || y.undefined then m_undef
+  else if x.value >= y.value then m_one
+  else m_zero
+
+let m_less_than (x : m_value) (y : m_value) : m_value =
+  if x.undefined || y.undefined then m_undef
+  else if x.value < y.value then m_one
+  else m_zero
+
+let m_less_than_equal (x : m_value) (y : m_value) : m_value =
+  if x.undefined || y.undefined then m_undef
+  else if x.value <= y.value then m_one
+  else m_zero
+
+let m_equal (x : m_value) (y : m_value) : m_value =
+  if x.undefined || y.undefined then m_undef
+  else if x.value = y.value then m_one
+  else m_zero
+
+let m_not_equal (x : m_value) (y : m_value) : m_value =
+  if x.undefined || y.undefined then m_undef
+  else if x.value <> y.value then m_one
+  else m_zero
+
+let m_not (x : m_value) : m_value =
+  if x.undefined then m_undef else if x.value = 0.0 then m_one else m_zero
+
+let m_neg (x : m_value) : m_value =
+  if x.undefined then m_undef
+  else { undefined = false; value = Float.neg x.value }
+
+let m_table_value_at_index (variable_array : m_array) (table_start : int)
+    (index : m_value) (size : int) =
+  if index.undefined then m_undef
+  else
+    let offset = int_of_float index.value in
+    match offset with
+    | x when x < 0 -> m_zero
+    | x when x >= size -> m_undef
+    | _ -> Array.get variable_array (offset + table_start)
+
+let m_max (x : m_value) (y : m_value) : m_value =
+  if x.undefined && y.undefined then m_undef
+  else { undefined = false; value = max x.value y.value }
+
+let m_min (x : m_value) (y : m_value) : m_value =
+  if x.undefined && y.undefined then m_undef
+  else { undefined = false; value = min x.value y.value }
+
+let m_round (x : m_value) : m_value =
+  if x.undefined then m_undef
+  else
+    {
+      undefined = false;
+      value =
+        (if x.value < 0.0 then ceil (x.value -. 0.50005)
+        else floor (x.value +. 0.50005));
+    }
+
+let m_null = m_not
+
+let m_floor (x : m_value) : m_value =
+  if x.undefined then m_undef
+  else { undefined = false; value = floor (x.value +. 0.000001) }
+
+let m_abs (x : m_value) : m_value =
+  if x.undefined then m_undef
+  else { undefined = false; value = abs_float x.value }
+
+let m_present (x : m_value) : m_value = if x.undefined then m_zero else m_one
+
+let m_multimax (bound_variable : m_value) (variable_array : m_array)
+    (position : int) : m_value =
+  if bound_variable.undefined then failwith "Multimax bound undefined!"
+  else
+    let bound = int_of_float bound_variable.value in
+    let sub_array = Array.sub variable_array (position+1) (bound) in
+    let get_position_value position =
+      Array.get variable_array position
+    in
+    Array.fold_left (m_max) (get_position_value position) sub_array 

examples/ocaml/parser/Makefile

@@ -0,0 +1,19 @@
+include ../Makefile-generic-ocaml-rules.include
+
+clean: 
+	rm -f *.cmo *.cmi *.cmx *.o test_lexer.ml test_parser.ml test_parser.mli
+
+# Compiling test file parser
+
+test_parser.mli test_parser.ml: types_module.cmo types_module.cmx
+	menhir --infer-write-query mock.ml test_parser.mly
+	ocamlc.opt -i mock.ml > reply
+	menhir --infer-read-reply reply test_parser.mly
+	rm mock.ml reply
+
+test_lexer.ml: test_parser.cmi test_parser.cmo test_parser.cmx
+	ocamllex test_lexer.mll
+
+fip.cmo: test_lexer.cmo
+
+fip.cmx: test_lexer.cmx

examples/ocaml/parser/fip.ml

@@ -0,0 +1,38 @@
+(*From test_interpreter.ml*)
+
+open Types_module
+
+let parse_file (test_name : string) : Types_module.irj_file =
+  let input = open_in test_name in
+  let filebuf = Lexing.from_channel input in
+  let filebuf =
+    {
+      filebuf with
+      lex_curr_p = { filebuf.lex_curr_p with pos_fname = test_name };
+    }
+  in
+  let f =
+    try Test_parser.irj_file Test_lexer.token filebuf with
+    | Types_module.StructuredError e ->
+        close_in input;
+        raise (Types_module.StructuredError e)
+    | Test_parser.Error ->
+        close_in input;
+        Types_module.raise_spanned_error "Test syntax error"
+          (Types_module.mk_position (filebuf.lex_start_p, filebuf.lex_curr_p))
+    in
+  close_in input;
+  f
+(*
+let () =
+let donnees = parse_file "alavoine-2.irj" in
+let (entrees, _, _) = donnees.prim in 
+print_string donnees.nom;print_newline();
+let (code, valeur, _) = List.hd entrees in
+print_string "première entrée : "; print_string code; print_string " avec la valeur ";
+match valeur with
+| I entier -> print_int entier; print_string " entière.";print_newline();flush stdout
+| F flottant -> print_float flottant; print_string " flottante.";
+print_newline();
+flush stdout
+*)